ppt vba 拆分文本框

芝麻陷汤圆

小白让AI写了个代码，想要的实现的功能是，假设文本框中5个字，运行后，拆分为5个文本框，文本框中各一个字，且保留文字格式。
前门没有问题，但运行到.TextFrame.TextRange.PasteSpecial ppPasteShape ，总是运行出错，求助大佬

1. Sub SplitAndApplyFormatPainter()
   
2.     Dim slide As Slide
   
3.     Dim shape As Shape
   
4.     Dim textBox As Shape
   
5.     Dim text As String
   
6.     Dim i As Integer
   
7. 
   
8.     ' 设置当前幻灯片
   
9.     Set slide = ActivePresentation.Slides(1) ' 更改为您想要拆分文本框的幻灯片索引
   
10.    
    
11.     ' 设置文本框
    
12.     Set shape = slide.Shapes("文本框 10") ' 更改为您想要拆分的文本框名称
    
13.    
    
14.     ' 获取文本框内容
    
15.     text = shape.TextFrame.TextRange.Text
    
16.    
    
17.     ' 拆分文本为单个字，并创建新的文本框
    
18.     For i = 1 To Len(text)
    
19.    
    
20.         ' 创建新文本框
    
21.         Set textBox = slide.Shapes.AddTextbox(msoTextOrientationHorizontal, shape.Left + (i - 1) * shape.Width / Len(text), shape.Top, shape.Width / Len(text), shape.Height)
    
22.         
    
23.         ' 设置文本框内容与格式
    
24.         With textBox
    
25.             .TextFrame.TextRange.Text = Mid(text, i, 1)
    
26.             shape.TextFrame.TextRange.Copy ' 复制原文本框的格式
    
27.             .TextFrame.TextRange.PasteSpecial ppPasteShape ' 应用格式刷到新文本框
    
28.             ' 可根据需要进一步设置文本框外观、对齐方式等属性
    
29.         End With
    
30.     Next i
    
31. End Sub

复制代码

shenjianrong163

1. Sub SplitAndApplyFormatPainter()
   
2.     Dim slide As slide
   
3.     Dim shape As shape
   
4.     Dim textBox As shape
   
5.     Dim text As String
   
6.     Dim i As Integer
   
7.     ' 设置当前幻灯片
   
8.     Set slide = ActivePresentation.Slides(1) ' 更改为您想要拆分文本框的幻灯片索引
   
9.     ' 设置文本框
   
10.     Set shape = slide.Shapes("文本框 10") ' 更改为您想要拆分的文本框名称
    
11.     shape.PickUp
    
12.     ' 获取文本框内容
    
13.     text = shape.TextFrame.TextRange.text
    
14.     ' 拆分文本为单个字，并创建新的文本框
    
15.     For i = 1 To Len(text)
    
16.         ' 创建新文本框
    
17.         Set textBox = slide.Shapes.AddTextbox(msoTextOrientationHorizontal, shape.Left + (i - 1) * shape.Width / Len(text), shape.Top, shape.Width / Len(text), shape.Height)
    
18.         ' 设置文本框内容与格式
    
19.         With textBox
    
20.             .TextFrame.TextRange.text = Mid(text, i, 1)
    
21.             .Apply
    
22.         End With
    
23.     Next i
    
24. End Sub
    

复制代码

芝麻陷汤圆

shenjianrong163 发表于 2023-6-29 12:07

谢谢大大，太好用了

dongdonggege

请问：ActiveWindow.Selection.ShapeRange为什么不能代替slide.Shapes("文本框 10")？不都是shape吗?

shenjianrong163

dongdonggege 发表于 2023-8-19 09:52
请问：ActiveWindow.Selection.ShapeRange为什么不能代替slide.Shapes("文本框 10")？不都是shape吗?

ActiveWindow.Selection.ShapeRange是一个集合，要用ActiveWindow.Selection.ShapeRange(1)，使用前，通过ActiveWindow.Selection.ShapeRange.Count先判断是否有所选对象

dongdonggege

shenjianrong163 发表于 2023-6-29 12:07

Set shape = ActiveWindow.Selection.ShapeRange(ActiveWindow.Selection.ShapeRange.Name)
这样，行了。

dongdonggege

shenjianrong163 发表于 2023-8-19 11:40
ActiveWindow.Selection.ShapeRange是一个集合，要用ActiveWindow.Selection.ShapeRange(1)，使用前，通 ...

谢谢讲解，理解了，谢谢。