分享一下收集整理并测试成功的代码，小功能

绿草地

       使用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:}