vba ppt删除文本框中的空格和空行

banjinjiu

我使用的是ppt2003，多页面有多个文本框，删除所有页面文本框中的空格和空行，测试通过。欢迎指导、拍砖。
先给个思路：
1、遍历所有幻灯片。
2、遍历所有图形形状。
3、判断图形形状是否文本框。
4、当前文本框是否有文本。
5、遍历所有文本的每一个字符。
6、利用正则表达式判断“字符”是否是“空格”，是则删除（包括段前、段中、段后）。
7、利用正则表达式判断“字符”是否是空回车，是则删除（包括第一行、行与行间、最后一行）。
最后两点我思考的时间比较长，因为网络上ppt的资料比较少，几乎就找不到，用了三天时间，东拼西凑了一下，本人目前还是菜鸟级，欢迎高手指点。
部分代码如下：

1. 
   
2. trng.Characters(i).Delete '清除行前行中的空格
   
3. trng.Characters = Replace(trng.Characters, " " + vbCrLf, vbCrLf) '清除行末的空格

复制代码

1. trng.Characters = Replace(trng.Characters, vbCrLf + vbCrLf, vbCrLf) '清除行与行之间的空行
   
2. If Left(trng.Characters, 2) = vbCrLf Then trng.Characters = Right(trng.Characters, Len(trng.Characters) - 2) '清除第一行的空行
   
3. If Right(trng.Characters, 2) = vbCrLf Then trng.Characters = Left(trng.Characters, Len(trng.Characters) - 2) '清除最后一行的空行

复制代码

事实上，行末最后的空格，即使删除了应该还是存在1个的。一点遗憾的是应该在两个单词之间存在一个空格，就没保留了，下次再搞吧。已发表在“锐普”。http://portal.rapidbbs.cn/forum.php?mod=viewthread&tid=66126
附件如下：

banjinjiu

我搜索了好久，没找到关于PPT文本框的操作，包括在excelhome家里，也没有，所以我献丑了，有愿意搞PPT的同道一起切磋，这个家中PPT的内容太少了，即使其他网站，关于VBA PPT的更少之又少，我特别想学习，愿我们共同提高。

banjinjiu

1. Sub a() '删除ppt所有图形
   
2. For Each SlideToCheck In ActivePresentation.Slides
   
3.     For ShapeIndex = SlideToCheck.Shapes.Count To 1 Step -1
   
4.         SlideToCheck.Shapes(ShapeIndex).Delete
   
5.     Next
   
6. Next
   
7. End Sub

复制代码

1. Sub b() '删除ppt文本框
   
2. Dim SlideToCheck As Slide
   
3. Dim ShapeIndex As Integer
   
4. For Each SlideToCheck In ActivePresentation.Slides
   
5.     For ShapeIndex = SlideToCheck.Shapes.Count To 1 Step -1
   
6.     If SlideToCheck.Shapes(ShapeIndex).Type = msoTextBox Then
   
7.        SlideToCheck.Shapes(ShapeIndex).Delete
   
8.     End If
   
9.     Next
   
10. Next
    
11. End Sub[code]Sub c() '删除空文本框
    
12. Dim SlideToCheck As Slide
    
13. Dim ShapeIndex As Integer
    
14. For Each SlideToCheck In ActivePresentation.Slides
    
15.     For ShapeIndex = SlideToCheck.Shapes.Count To 1 Step -1
    
16.     If SlideToCheck.Shapes(ShapeIndex).Type = msoTextBox And Not SlideToCheck.Shapes(ShapeIndex).TextFrame.HasText Then
    
17.        SlideToCheck.Shapes(ShapeIndex).Delete
    
18.     End If
    
19.     Next
    
20. Next
    
21. End Sub

复制代码

[/code]

banjinjiu

网络上搜集一些有关PPT文本框的代码或许对您有点作用，自己也留下个记号。

1. Sub a() '删除所有图形
   
2. For Each SlideToCheck In ActivePresentation.Slides
   
3.     For ShapeIndex = SlideToCheck.Shapes.Count To 1 Step -1
   
4.         SlideToCheck.Shapes(ShapeIndex).Delete
   
5.     Next
   
6. Next
   
7. End Sub

复制代码

1. Sub b() '删除文本框
   
2. Dim SlideToCheck As Slide
   
3. Dim ShapeIndex As Integer
   
4. For Each SlideToCheck In ActivePresentation.Slides
   
5.     For ShapeIndex = SlideToCheck.Shapes.Count To 1 Step -1
   
6.     If SlideToCheck.Shapes(ShapeIndex).Type = msoTextBox Then
   
7.        SlideToCheck.Shapes(ShapeIndex).Delete
   
8.     End If
   
9.     Next
   
10. Next
    
11. End Sub

复制代码

1. Sub c() '删除空文本框
   
2. Dim SlideToCheck As Slide
   
3. Dim ShapeIndex As Integer
   
4. For Each SlideToCheck In ActivePresentation.Slides
   
5.     For ShapeIndex = SlideToCheck.Shapes.Count To 1 Step -1
   
6.     If SlideToCheck.Shapes(ShapeIndex).Type = msoTextBox And Not SlideToCheck.Shapes(ShapeIndex).TextFrame.HasText Then
   
7.        SlideToCheck.Shapes(ShapeIndex).Delete
   
8.     End If
   
9.     Next
   
10. Next
    
11. End Sub

复制代码

huazai688

收藏学习!!!!!!!

leikaiyi123

我只研究了删除空行，见下或附件

'ppt2010中要将vbCrLf改为chr$(13)，但2003中改了删首行和末行的空行失效，不知为什么？
'以下方法用vb6封装为dll文件加载项后，中间有些两行会合并为一行，造成多删，不知为什么？

Sub 删空行() '此方法不会使文本框中的字体丢格式
    For Each sld In Application.ActivePresentation.Slides
        For Each shp In sld.Shapes
            If shp.HasTextFrame Then
                Do While shp.TextFrame.TextRange.Characters(1).Text = vbCrLf    '删首行空行
                      If shp.TextFrame.TextRange.Characters(1).Text = vbCrLf Then shp.TextFrame.TextRange.Characters(1).Delete
                Loop

                Set txtRng = shp.TextFrame.TextRange
                Set foundText = txtRng.Find(FindWhat:=vbCrLf & vbCrLf)
                Do While Not (foundText Is Nothing) '清除中间的空行
                    With foundText
                        .Text = Chr$(13)
                        Set foundText = txtRng.Find(FindWhat:=vbCrLf & vbCrLf, After:=.Start - 1)
                    End With
                Loop

                'Set txtRng = shp.TextFrame.TextRange
                If Right(txtRng.Characters, 2) = vbCrLf Then txtRng.Characters(txtRng.Length, 1).Delete '删末行空行
            End If
        Next
    Next
End Sub

leikaiyi123

vb6封装已解决