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