CoreDraw的几个VBA代码

Sub SaveTextOnly() '备份文本
    Dim p As Page
    Dim nPos As Long
    Dim strName As String
    Dim srAllShapes As New ShapeRange
   
    For Each p In ActiveDocument.Pages
        srAllShapes.AddRange p.Shapes.FindShapes() 'Add each shape to our ShapeRange
    Next p
   
    srAllShapes.RemoveRange srAllShapes.FindAnyOfType(cdrGroupShape, cdrTextShape) 'Remove any groups and Text Objects
    srAllShapes.Delete 'Delete the ShapeRange now contaning all shapes but Text
   
    'Get the FileName of the ActiveDocument
    strName = ActiveDocument.FileName
    nPos = InStrRev(strName, ".")
    If nPos > 0 Then strName = Left(strName, nPos - 1)
    strName = ActiveDocument.FilePath & strName & " - Text Backup.cdr" 'New name for Document
   
    ActiveDocument.SaveAs strName 'Save the Document with new name
End Sub

Sub s删外框改尺寸()
Dim d As Document
Dim p As Page
Dim s As Shape
For Each d In Documents
d.Unit = cdrMillimeter
d.ReferencePoint = cdrCenter
d.MasterPage.GuidesLayer.Shapes.All.Delete
    For Each p In d.Pages
      For Each s In p.Shapes.FindShapes(, cdrCurveShape)
      If s.SizeHeight > 235 Then
      s.Delete
      End If
      Next s
p.Shapes.All.SetSize 170, 240
p.Shapes.All.Group
p.Shapes.All.AlignToPageCenter cdrAlignVCenter + cdrAlignHCenter
p.Shapes.All.Ungroup
   Next p
Next d
End Sub
Sub fgym() '分割页面中所有图像
    On Error GoTo 10
    Dim s1 As Shape, s2 As Shape, p As Page
    For Each p In ActiveDocument.Pages
        Set s1 = p.Shapes.FindShapes(, cdrBitmapShape).Group
        '设置一个容器
        Set s2 = p.ActiveLayer.CreateGridBoxes(0, p.SizeHeight, p.SizeWidth, 0, 2, 1)
        s2.Fill.ApplyNoFill
        s2.Outline.Width = 0
        s1.AddToPowerClip s2, cdrFalse
        s2.OrderToBack
        s2.Ungroup
    Next p
10 End Sub
Sub tr选框删物()
Dim x1 As Double, y1 As Double, x2 As Double, y2 As Double
Dim Shift As Long
Dim b As Boolean
Dim s As Shape, os As Shape, ts As Shape, s1 As Shape
Dim cr As Long, cg As Long, cb As Long
ActiveDocument.BeginCommandGroup "置入容器做修剪" '设定还原步骤

b = ActiveDocument.GetUserArea(x1, y1, x2, y2, Shift, 10, False, 428)
    If Not b Then
        ActivePage.SelectShapesFromRectangle x1, y1, x2, y2, True
        Set s = ActiveSelection.Group
        Set os = ActiveSelection.CustomCommand("Boundary", "CreateBoundary")
            os.Outline.Width = 0
        Set ts = ActiveDocument.ActiveLayer.CreateRectangle(x1, y1, x2, y2)
        Set s1 = ts.Trim(os, True, True)
            ts.Delete
            os.Delete
            s.AddToPowerClip s1, cdrFalse
            SendKeys "{ESC}", True
   End If
ActiveDocument.EndCommandGroup
End Sub
Sub bmptrace把图片转成矢量图()
Dim b As Bitmap
Dim trace As TraceSettings
On Error Resume Next
If ActiveShape.Type <> cdrBitmapShape Or ActiveSelection.Shapes.Count <> 1 Then
MsgBox "请先选择一个要转成矢量的点阵图": Exit Sub
End If
Set b = ActiveShape.Bitmap
Set trace = b.trace(cdrTraceClipart, RemoveBackground:=False)

        trace.Finish
End Sub