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

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

我创建了一个脚本，将文本从文本框移动到占位符中，效果非常好；然而，我无法维护链接，列表总是显示为项目符号，尽管有些是数字。基本上，如果文本框中有链接，它仍然应该是占位符中的链接。仅供参考，此脚本还会将每张幻灯片上的形状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

---

这可能有一些格式问题需要解决，但这将插入您正在寻找的超链接。代码可能不是最干净的，但它可以工作。您还需要设置VBA只对未处理的错误进行破坏，否则将在代码中间中断。看

类模块-超

 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

常规模块（随你怎么叫）

---

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

请参见下面的“我的更新”：

重用类模块-超

 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中的Exists函数中删除“On Error GoTo 0”

 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

修订的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

---

如果via

link

您指的是超链接，并且希望将其添加到shape对象，请选中此项：谢谢！这给了我一个很好的开始。对我来说，它不能直接开箱即用，但经过一些小的修改，它工作得非常完美。请参阅我的修订答案