时间戳

首页 > 解决方案 > 如何在 PowerPoint VBA 中检查每个字符是否为数字或字符并相应地更改其字体？

vba - 如何在 PowerPoint VBA 中检查每个字符是否为数字或字符并相应地更改其字体？

问题描述

我需要查看所有字符并检查它们是数字还是文本项。如果它们属于任何一种，我需要相应地更改它们的字体。我已经使用一些内置函数在 excel vba 中做到了这一点。但在powerpoint中似乎是不可能的。

它相当原始但确实有效。然而，奇怪的是，有些部分可以正确完成，有些则不能。我无法弄清楚。

我用过这段代码：

Sub FontChange()

Dim sld As Slide
Dim shp As Shape
Dim foundText As Variant
Dim findNumber As Variant
Dim findCharacter As Variant
Dim x As Long
Dim y As Long
'Dim i As Integer
'Dim j As Character

findNumber = Array("0", "1", "2", "3", "4", "5", "6", "7", "8", "9")
findCharacter = Array("a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", "n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z", "A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z")
For Each sld In ActivePresentation.Slides
    For Each shp In sld.Shapes
    If shp.HasTextFrame Then  ' Not all shapes do
        If shp.TextFrame.HasText Then  ' the shape may contain no text
            For x = LBound(findNumber) To UBound(findNumber)
              Set foundText = shp.TextFrame.TextRange.Find(FindWhat:=findNumber(x))
                 Do While Not (foundText Is Nothing)
                     With foundText
                      .Font.Size = 18
                      .Font.Name = "Meta-Normal"
                      '.Bold = False
                      '.Color.RGB = RGB(255, 127, 255)
                     Set foundText = _
                        shp.TextFrame.TextRange.Find(FindWhat:="findNumber(x)", _
                        After:=.Start + .Length - 1)
                    End With
                 Loop
              Next x
        End If
    End If
    Next shp
Next sld
For Each sld In ActivePresentation.Slides
    For Each shp In sld.Shapes
    If shp.HasTextFrame Then  ' Not all shapes do
        If shp.TextFrame.HasText Then  ' the shape may contain no text
            For y = LBound(findCharacter) To UBound(findCharacter)
              Set foundText = shp.TextFrame.TextRange.Find(FindWhat:=findCharacter(y))
                 Do While Not (foundText Is Nothing)
                     With foundText
                      .Font.Size = 18
                      .Font.Name = "Neo Sans Pro Light"
                      '.Bold = False
                      '.Color.RGB = RGB(255, 127, 255)
                     Set foundText = _
                        shp.TextFrame.TextRange.Find(FindWhat:="findCharacter(y)", _
                        After:=.Start + .Length - 1)
                    End With
                 Loop
              Next y
        End If
    End If
    Next shp
Next sld
End Sub

标签： vbapowerpoint

解决方案

这可能是一种更优雅的方法。两个单独检查文本的私有函数。您可以合并 OR 语句，但为简单起见，我将其保留为两个单独的项目。

Sub FontChange()

Dim sld As Slide
Dim shp As Shape
Dim x As Long
Dim y As Long

For Each sld In ActivePresentation.Slides
    For Each shp In sld.Shapes
    If shp.HasTextFrame Then  ' Not all shapes do
        If shp.TextFrame.HasText Then  ' the shape may contain no text

            If NumbersExist(shp.TextFrame.TextRange) Then
                'if Number exists
            End If

            If LettersExist(shp.TextFrame.TextRange) Then
                'What to do if text exists)

            End If

     Next shp             
Next sld
End Sub


Private Function LettersExist(yourText As String) As Boolean
Dim FindCharacter As Variant, i As Integer
FindCharacter = Array("a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", "n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z", "A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z")

For i = 0 To 25
If InStr(1, yourText, FindCharacter(i), vbTextCompare) > 0 Then
    LettersExist = True
    Exit Function
End If

Next i

End Function

Private Function NumbersExist(yourText As String) As Boolean
Dim FindNumber As Variant, i As Integer

FindNumber = Array("0", "1", "2", "3", "4", "5", "6", "7", "8", "9")

For i = 0 To 9

If InStr(1, yourText, FindNumber(i), vbTextCompare) > 0 Then
    NumbersExist = True
    Exit Function
End If
Next i

End Function

推荐阅读