Как проверить, является ли каждый символ числом или символом в PowerPoint VBA, и соответствующим образом изменить их шрифты? - PullRequest
Новая
       5

Как проверить, является ли каждый символ числом или символом в PowerPoint VBA, и соответствующим образом изменить их шрифты?

0 голосов
/ 24 мая 2018

Мне нужно просмотреть все символы и проверить, являются ли они цифрами или текстовыми элементами.Если они того или иного вида, мне нужно соответствующим образом изменить их шрифт.Мне удалось сделать это в 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

1 Ответ

0 голосов
/ 24 мая 2018

Это может быть более элегантный подход.Две частные функции для индивидуальной проверки текста.Вы могли бы объединить для оператора ИЛИ, но я оставил как два отдельных элемента для простоты. 

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
...