版块 › CorelDRAW专区 › VBA CDR文件8.0版本保存+转曲

KEROWJ 发表于 2017-4-22 18:00:06

VBA CDR文件8.0版本保存+转曲

'保存低版本
Sub SaveLowS()
    Dim ExpfltShapes As Shapes
    Set ExpfltShapes = ActiveSelectionRange.UngroupAllEx.Shapes
    If ExpfltShapes.Count = 0 Then Exit Sub
    Dim Count As Integer
    For Count = 1 To ExpfltShapes.Count
      Call ToCurve(ExpfltShapes(Count))
    Next
    ExpfltShapes.All '将多个形状转成活动选区
    Dim SaveOptions As StructSaveAsOptions
    Set SaveOptions = CreateStructSaveAsOptions
    With SaveOptions
      .EmbedVBAProject = True
      .Filter = cdrCDR
      .IncludeCMXData = False
      .Range = cdrSelection
      .EmbedICCProfile = True
      .Version = cdrVersion8
    End With
    ActiveDocument.SaveAs GetExpfltPath + "_通用版.cdr", SaveOptions
End Sub
'单个形状转曲
Public Sub ToCurve(InputShape As Shape, Optional ShapeType As Integer = cdrTextShape)
    If InputShape.Type = cdrTextShape Then
    InputShape.ConvertToCurves
    End If
End Sub
'获取文档名称
    Public Function GetDocumentName() As String
      Dim Count As Integer
      Count = InStrRev(ActiveDocument.Name, ".")
      If Count > 0 Then
      GetDocumentName = Left(ActiveDocument.Name, Count - 1)
      Else
      GetDocumentName = ActiveDocument.Name
      End If
    End Function
'获取导出路径
    Public Function GetExpfltPath() As String
      GetExpfltPath = "C:\Users\Administrator\Desktop\" + GetDocumentName
    End Function

A-Ming 发表于 2017-4-22 18:43:11

VB源码   干货 我现在用不到，但要收藏下

离晒谱 发表于 2017-4-23 01:01:12

发现最近论坛灌水的兄弟比较多，为了论坛有个良好的讨论环境

查看完整版本: VBA CDR文件8.0版本保存+转曲