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

KEROWJ

'保存低版本
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

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

离晒谱

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