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

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 .

类模块 - Hyper

 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