分享一下收集整理并测试成功的代码，小功能
使用cd的高手都知道，魔镜是它的超级伴侣，功能很多，也非常的实用，经常使用的人建议使用，提高工作效率。本人在使用的过程中，也很满意。所以对宏也很感兴趣，于是在百度中苦苦搜索，整理，测试，做出了以下几个有点实用功能的小代码，希望学习宏代码的朋友有所帮助。Attribute VB_Name = "RecordedMacros"
Sub 复制到所有页面()
Dim p As Page
Dim Org As ShapeRange
Dim Cname As String
If ActiveSelection.Shapes.Count = 0 Then
pp = MsgBox("没有选择任何对象，请选择至少一个对象！", vbExclamation + vbdefaultbuttonl, "错误提示")
Exit Sub
End If
Cname = InputBox("输入名称", "名称", Default)
If Cname = "" Then Exit Sub
Set Org = ActiveSelectionRange
Org.Copy
ActiveLayer.Paste
If ActiveSelection.Shapes.Item(1).Type = cdrGroupShape Then
Org.Ungroup
End If
For I = 1 To ActiveSelectionRange.Count
Org(I).ObjectData("Name").Value = Cname
Next I
Org.Cut
For Each p In ActiveDocument.Pages '在各页中循环
p.Activate
ActiveLayer.Paste
Set Paste1 = ActiveSelectionRange
Next p
End Sub
Sub 给选择的对象命名()
' Recorded 2015/10/6
Dim OrigSelection As ShapeRange
Dim I As Integer
Dim Cname As String
If ActiveSelection.Shapes.Count = 0 Then
pp = MsgBox("没有选择任何对象，请选择至少一个对象！", vbExclamation + vbdefaultbuttonl, "错误提示")
Exit Sub
End If
Cname = InputBox("输入名称", "名称", Default)
If Cname = "" Then Exit Sub
Set OrigSelection = ActiveSelectionRange
For I = 1 To ActiveSelectionRange.Count
OrigSelection(I).ObjectData("Name").Value = Cname
Next I
End Sub
Sub 删除指定的名称对象()
Dim p As Page
Dim Cname As String
Cname = InputBox("想删除哪个对象名", "名称", Default)
If Cname = "" Then Exit Sub
For Each p In ActiveDocument.Pages '在各页中循环
' p.Activate
p.Shapes.FindShapes(Cname).Delete'把筛选出来的对象全部删除
Next p
End Sub
Sub 每页同名对象群组()
Dim p As Page
Dim Org As ShapeRange
Dim Cname As String
Cname = InputBox("想全选对象的对象名", "名称", Default)
If Cname = "" Then Exit Sub
For Each p In ActiveDocument.Pages '在各页中循环
p.Activate
p.Shapes.FindShapes(Cname).AddToSelection '把筛选出来的对象全部选中
Set Org = ActiveSelectionRange
Org.Group
' For I = 1 To ActiveSelectionRange.Count '针对选择的全部对象进行处理
' Org(I).ApplyEffectHSL -103, 0, 0'改变对象的色相
'Next I
Next p
End Sub
Sub 复制旋转()
' Recorded 2015/10/11
Dim OrigSelection As ShapeRange
Set OrigSelection = ActiveSelectionRange
Dim dup1 As ShapeRange
Set dup1 = OrigSelection.Duplicate
Set dup1 = ActiveSelectionRange
ActiveDocument.ReferencePoint = cdrCenter
dup1.Stretch 0.9
dup1.Rotate -10#
End Sub
我也满喜欢VBA的，要是有个交流群多好。{:1_143:}
页:
[1]