PPT的宏 - 将TextBox内容移动到占位符 - 维护链接和列表

Question

我有通过我无法控制的软件生成的PPT。生成后，软件会将所有文本放入TextBoxes而不是我的占位符。

我创建了一个脚本来将文本从TextBoxes移动到占位符中，这很有效;但是，我无法维护链接，并且列表总是显示为Bulleted，尽管有些是数字。基本上，如果文本框中有链接，它仍应是占位符中的链接。仅供参考，此脚本还会将每张幻灯片上的形状3更改为标题占位符

当我移动文本时，如何保留格式？我尝试使用pastespecial，但仍然只是将文本移动到占位符的格式。

Sub TextBoxFix()
   Dim osld As Slide, oshp As Shape, oTxR As TextRange, SlideIndex As Long, myCount As Integer, numShapesOnSlide As Integer
Dim tempBulletFormat As PowerPoint.PpBulletType
For Each osld In ActivePresentation.Slides
    myCount = 1

    With ActivePresentation
    'For Each oshp In osld.Shapes
    osld.CustomLayout = ActivePresentation.Designs(1).SlideMaster.CustomLayouts(2)
    For i = osld.Shapes.Count To 1 Step -1
        Set oshp = osld.Shapes(i)
        If i = 3 Then
            osld.Shapes.Placeholders.Item(1).TextFrame.TextRange = oshp.TextFrame.TextRange.Characters
            osld.Shapes.Placeholders.Item(1).Visible = msoTrue
            oshp.Delete
          ElseIf i > 3 And oshp.Type = msoTextBox Then
          oshp.TextFrame.TextRange.Copy
          osld.Shapes.Placeholders.Item(2).TextFrame.TextRange.InsertBefore(oshp.TextFrame.TextRange.TrimText).ParagraphFormat.Bullet.Type = oshp.TextFrame.TextRange.ParagraphFormat.Bullet.Type
                   oshp.Delete
           End If
    Next i
    End With
 Next osld
End Sub

Answer 1

这可能有一些需要解决的格式问题，但这会插入您要查找的超链接。代码可能不是最干净的，但它确实有效。您还需要将vba设置为仅在未处理的错误上中断，否则它将在代码中间中断。请参阅here。

课程模块 - 超级

 Private shp As Shape
 Private chrStart As Integer
 Private hypAddr As String
 Private hypText As String

 Private Sub Class_Initialize()

 End Sub

 Public Sub InitializeWithValues(newShp As Shape, newChrStart As Integer, newHypAddress As String, newHypText As String)

     Set shp = newShp
     chrStart = newChrStart
     hypAddr = newHypAddress
     hypText = newHypText

 End Sub
 Public Function getShape() As Shape

     Set getShape = shp

 End Function
 Public Function getchrStart() As Integer


     getchrStart = chrStart
 End Function

 Public Function getHypAddr() As String

     getHypAddr = hypAddr

 End Function

 Public Function getHypText() As String

     getHypText = hypText

 End Function

课程模块 - hyperColl

 Private myCollection As Collection

 Private Sub Class_Initialize()

     Set myCollection = New Collection

  End Sub

  Public Sub Add_Item(newHyper As Hyper)

       Dim newArray() As Hyper
       If Me.Exists(newHyper.getShape().Name) Then
            newArray = myCollection(newHyper.getShape().Name)
            ReDim Preserve newArray(0 To UBound(newArray) + 1)
            Set newArray(UBound(newArray)) = newHyper
            myCollection.Remove (newHyper.getShape().Name)
            myCollection.Add newArray, newHyper.getShape().Name
       Else
            ReDim newArray(0)
            Set newArray(0) = newHyper
            myCollection.Add newArray, newHyper.getShape().Name
       End If



  End Sub
  Public Function GetArray(shapeName As String) As Hyper()

       GetArray = myCollection(shapeName)

  End Function

 Public Function Exists(shapeName As String) As Boolean
      Dim myHyper() As Hyper
      On Error Resume Next
      myHyper = myCollection(shapeName)
      On Error GoTo 0
      If Err.Number = 5 Then 'Not found in collection
          Exists = False
      Else
          Exists = True
      End If

      Err.Clear

  End Function

常规模块（随心所欲地调用它）

 Sub textBoxFix()

 Dim sld As Slide
 Dim shp As Shape
 Dim shp2 As Shape
 Dim oHl As Hyperlink
 Dim hypAddr As String
 Dim hypText As String
 Dim hypTextLen As Integer
 Dim hypTextStart As Integer
 Dim hypShape As Shape
 Dim hypCollection As hyperColl
 Dim newHyper As Hyper
 Dim hypArray() As Hyper
 Dim hypToAdd As Hyper
 Dim i As Long
 Dim j As Long
 Dim bolCopy As Boolean

 Set sld = ActivePresentation.Slides(1)
 sld.CustomLayout = ActivePresentation.Designs(1).SlideMaster.CustomLayouts(2)

 Set hypCollection = New hyperColl 'Set the collection of arrays - 1 for each shape

 Set shp = sld.Shapes(1)

 For Each oHl In sld.Hyperlinks

     If oHl.Type = msoHyperlinkRange Then 'Hyperlink is associated with part of a TextRange, not a whole shape
         hypAddr = oHl.Address
         hypText = oHl.TextToDisplay
         hypTextLen = Len(hypText)
         If TypeName(oHl.Parent.Parent) = "TextRange" Then
             hypTextStart = oHl.Parent.Parent.start
             Set hypShape = oHl.Parent.Parent.Parent.Parent
         End If
         Set newHyper = New Hyper
         newHyper.InitializeWithValues hypShape, hypTextStart, hypAddr, hypText
         hypCollection.Add_Item newHyper
     End If

 Next oHl
For j = sld.Shapes.Count To 1 Step -1
     Set shp = sld.Shapes(j)
     bolCopy = False
     If j = 3 Then
         Set shp2 = sld.Shapes.Placeholders.Item(1)
         bolCopy = True
    ElseIf j > 3 And shp.Type = msoTextBox Then
         Set shp2 = sld.Shapes.Placeholders.Item(2)
         bolCopy = True
    End If
    If bolCopy = True Then
         shp2.TextFrame.TextRange.InsertBefore(shp.TextFrame.TextRange.TrimText).ParagraphFormat.Bullet.Type =  shp.TextFrame.TextRange.ParagraphFormat.Bullet.Type
         If hypCollection.Exists(shp.Name) Then
              hypArray = hypCollection.GetArray(shp.Name)
              For i = LBound(hypArray) To UBound(hypArray)
                  Set hypToAdd = hypArray(i)
                  With shp2.TextFrame.TextRange.Characters(hypToAdd.getchrStart, Len(hypToAdd.getHypText)).ActionSettings.Item(1)
                       .Action = ppActionHyperlink
                       .Hyperlink.Address = hypToAdd.getHypAddr
                  End With
              Next i
         End If
      End If
      shp.Delete
 Next j

End Sub

Answer 2

我使用OpiesDad的代码作为起点，并做了一些小修改。当文本框不存在时，我收到了与GetArray函数相关的错误。另外，我修改了代码以在PPT的所有幻灯片上运行。我还必须对TextBoxFix Sub进行一些修改，因为内容被删除了，但是我的占位符中没有填充。

请参阅以下我的更新：

重用类模块 - Hyper

从hyperColl中的Exists函数中删除了“On Error GoTo 0”

修改下面的TextBoxFix：

 Sub TextBoxFix()
 Dim shp As Shape
 Dim shp2 As Shape
 Dim oHl As Hyperlink
 Dim hypAddr As String
 Dim hypText As String
 Dim hypTextLen As Integer
 Dim hypTextStart As Integer
 Dim hypShape As Shape
 Dim hypCollection As hyperColl
 Dim newHyper As Hyper
 Dim hypArray() As Hyper
 Dim hypToAdd As Hyper
 Dim i As Long
 Dim j As Long
 Dim bolCopy As Boolean

 For Each sld In ActivePresentation.Slides
 With ActivePresentation
 sld.CustomLayout = ActivePresentation.Designs(1).SlideMaster.CustomLayouts(2)

 Set hypCollection = New hyperColl 'Set the collection of arrays - 1 for each shape

 Set shp = sld.Shapes(1)

 For Each oHl In sld.Hyperlinks

     If oHl.Type = msoHyperlinkRange Then 'Hyperlink is associated with part of a TextRange, not a whole shape
         hypAddr = oHl.Address
         hypText = oHl.TextToDisplay
         hypTextLen = Len(hypText)
         If TypeName(oHl.Parent.Parent) = "TextRange" Then
             hypTextStart = oHl.Parent.Parent.Start
             Set hypShape = oHl.Parent.Parent.Parent.Parent
         End If
         Set newHyper = New Hyper
         newHyper.InitializeWithValues hypShape, hypTextStart, hypAddr, hypText
         hypCollection.Add_Item newHyper
     End If

 Next oHl
    For j = sld.Shapes.Count To 1 Step -1
     Set shp = sld.Shapes(j)
     bolCopy = False
     If j = 3 Then
         sld.Shapes.Placeholders.Item(1).TextFrame.TextRange = shp.TextFrame.TextRange.Characters
         sld.Shapes.Placeholders.Item(1).Visible = msoTrue
         shp.Delete

    ElseIf j > 3 And shp.Type = msoTextBox Then
      sld.Shapes.Placeholders.Item(2).TextFrame.TextRange.InsertBefore(shp.TextFrame.TextRange.TrimText).ParagraphFormat.Bullet.Type = shp.TextFrame.TextRange.ParagraphFormat.Bullet.Type
         If hypCollection.Exists(shp.Name) Then
              hypArray = hypCollection.GetArray(shp.Name)
              For i = LBound(hypArray) To UBound(hypArray)
                  Set hypToAdd = hypArray(i)
                 With sld.Shapes.Placeholders.Item(2).TextFrame.TextRange.Characters(hypToAdd.getchrStart, Len(hypToAdd.getHypText)).ActionSettings.Item(1)
                       .Action = ppActionHyperlink
                       .Hyperlink.Address = hypToAdd.getHypAddr
                 End With
              Next i
         End If

       shp.Delete
    End If
 Next j
 End With
 Next sld

End Sub