Convert a word VBA code to PowerPoint VBA code

laith93 · #1 11-08-2023, 10:37 PM

I have this VBA code, which was developed by DougRobbin
This code Format Scientific Names which are present in the main body of the document and in the text boxes in a word document according to the list of microbial names in Excel file.
Now I want the same code for the same purpose, but to work inside PowerPoint,
Nowadays I made many seminars, which include microbial names and I change formatting for each one manually, which is so annoying.
So I want a code to do this automatically in PowerPoint.
Thanks

Code:

Sub FormatByExcel()

Dim xlapp As Object

Dim xlbook As Object

Dim xlsheet As Object

Dim myarray As Variant

Dim FD As FileDialog

Dim strSource As String

Dim i As Long, lognum As Long

Dim myStoryRange As range


Set FD = Application.FileDialog(msoFileDialogFilePicker)

With FD

    .Title = "Select the workbook that contains the terms to be italicized"

    .Filters.Clear

    .Filters.Add "Excel Workbooks", "*.xlsx"

    .AllowMultiSelect = False

    If .Show = -1 Then

        strSource = .SelectedItems(1)

    Else

        MsgBox "You did not select the workbook that contains the data"

        Exit Sub

    End If

End With

On Error Resume Next

Set xlapp = GetObject(, "Excel.Application")

If Err Then

    bStartApp = True

    Set xlapp = CreateObject("Excel.Application")

End If

On Error GoTo 0

Set xlbook = xlapp.Workbooks.Open(strSource)

Set xlsheet = xlbook.Worksheets(1)

myarray = xlsheet.range("A1").CurrentRegion.Value

If bStartApp = True Then

    xlapp.Quit

End If

Set xlapp = Nothing

Set xlbook = Nothing

Set xlsheet = Nothing

Application.ScreenUpdating = False

For i = LBound(myarray) To UBound(myarray)

    Selection.HomeKey wdStory

    Selection.Find.ClearFormatting

    With Selection.Find

        Do While .Execute(findText:=myarray(i, 1), Forward:=True, _
MatchWildcards:=False, Wrap:=wdFindStop, MatchCase:=True) = True

            Set Rng = Selection.range

            Selection.Collapse wdCollapseEnd

            Rng.Font.Italic = True

        Loop

    End With

    For Each myStoryRange In ActiveDocument.StoryRanges

        myStoryRange.Select

        With Selection.Find

            Do While .Execute(findText:=myarray(i, 1), Forward:=True, _
MatchWildcards:=False, Wrap:=wdFindStop, MatchCase:=True) = True

                Set Rng = Selection.range

                Selection.Collapse wdCollapseEnd

                Rng.Font.Italic = True

            Loop

        End With

        Do While Not (myStoryRange.NextStoryRange Is Nothing)

            Set myStoryRange = myStoryRange.NextStoryRange

            myStoryRange.Select

            With Selection.Find

                Do While .Execute(findText:=myarray(i, 1), Forward:=True, _
MatchWildcards:=False, Wrap:=wdFindStop, MatchCase:=True) = True

                    Set Rng = Selection.range

                    Selection.Collapse wdCollapseEnd

                    Rng.Font.Italic = True

                Loop

            End With

        Loop

    Next myStoryRange

Next i

With Application

    .ScreenUpdating = True

    .ScreenRefresh

    .ActiveWindow.View = wdPrintView

End With
End Sub

gmaxey · #2 11-09-2023, 05:08 AM

This is not a PowerPoint forum but perhaps:

Code:

Sub FormatByExcel()
'Code by Gregory K. Maxey
Dim xlapp As Object
Dim xlbook As Object
Dim xlsheet As Object
Dim bStartApp As Boolean
Dim varArray As Variant
Dim FD As FileDialog
Dim strSource As String
Dim lngIndex As Long
Dim oSld As Slide
Dim oShp As Shape
Dim oTxtRng As TextRange
Dim oFoundTxt As TextRange
  '**** This is the basically the same as Doug's original code
  Set FD = Application.FileDialog(msoFileDialogFilePicker)
  With FD
    .Title = "Select the workbook that contains the terms to be italicized"
    .Filters.Clear
    .Filters.Add "Excel Workbooks", "*.xlsx"
    .AllowMultiSelect = False
    If .Show = -1 Then
      strSource = .SelectedItems(1)
    Else
      MsgBox "You did not select the workbook that contains the data"
      Exit Sub
    End If
  End With
  On Error Resume Next
  Set xlapp = GetObject(, "Excel.Application")
  If Err Then
    bStartApp = True
    Set xlapp = CreateObject("Excel.Application")
  End If
  On Error GoTo 0
  Set xlbook = xlapp.Workbooks.Open(strSource)
  Set xlsheet = xlbook.Worksheets(1)
  varArray = xlsheet.Range("A1").CurrentRegion.Value
  If bStartApp = True Then xlapp.Quit
  Set xlapp = Nothing
  Set xlbook = Nothing
  Set xlsheet = Nothing
  '****
  '#### Since I don't have your Excel file, this is simply for testing
  ReDim varArray(1)
  varArray(0) = "Apples"
  varArray(1) = "Oranges"
  '####
  '@@@@ I am far from a PowerPoint expert, but a causal Google search turned up something that I could adapt to suit.
  For lngIndex = 0 To UBound(varArray)
    'Loop through each slide in presentation
    For Each oSld In ActivePresentation.Slides
      'Loop through each shape on slide
      For Each oShp In oSld.Shapes
        'Is there text in the shape?
        If oShp.HasTextFrame Then
          Set oTxtRng = oShp.TextFrame.TextRange
          Set oFoundTxt = oTxtRng.Find(FindWhat:=varArray(lngIndex))
          Do While Not (oFoundTxt Is Nothing)
            With oFoundTxt
              .Font.Italic = True
              Set oFoundTxt = oTxtRng.Find(FindWhat:=varArray(lngIndex), After:=.Start + .Length - 1)
            End With
          Loop
        End If
      Next oShp
    Next oSld
  Next lngIndex
lbl_Exit:
  Exit Sub
End Sub

laith93 · #3 11-09-2023, 05:28 AM

Quote:

Originally Posted by gmaxey

This is not a PowerPoint forum but perhaps:

Excuse me, I am sorry for this misposting
Dear gmaxey, after running the code and choosing the Excel file, nothing happens
I attached my files to apply.
Thanks with my best regards

gmaxey · #4 11-09-2023, 06:49 AM

It was an array dimension issue. Try:

Code:

Sub FormatByExcel()
'Code by Gregory K. Maxey
Dim xlapp As Object
Dim xlbook As Object
Dim xlsheet As Object
Dim bStartApp As Boolean
Dim varArray As Variant
Dim FD As FileDialog
Dim strSource As String
Dim lngIndex As Long
Dim oSld As Slide
Dim oShp As Shape
Dim oTxtRng As TextRange
Dim oFoundTxt As TextRange
  '**** This is the basically the same as Doug's original code
  Set FD = Application.FileDialog(msoFileDialogFilePicker)
  With FD
    .Title = "Select the workbook that contains the terms to be italicized"
    .Filters.Clear
    .Filters.Add "Excel Workbooks", "*.xlsx"
    .AllowMultiSelect = False
    If .Show = -1 Then
      strSource = .SelectedItems(1)
    Else
      MsgBox "You did not select the workbook that contains the data"
      Exit Sub
    End If
  End With
  On Error Resume Next
  Set xlapp = GetObject(, "Excel.Application")
  If Err Then
    bStartApp = True
    Set xlapp = CreateObject("Excel.Application")
  End If
  On Error GoTo 0
  Set xlbook = xlapp.Workbooks.Open(strSource)
  Set xlsheet = xlbook.Worksheets(1)
  varArray = xlsheet.Range("A1").CurrentRegion.Value
  If bStartApp = True Then xlapp.Quit
  Set xlapp = Nothing
  Set xlbook = Nothing
  Set xlsheet = Nothing
  '****
'  '#### Since I don't have your Excel file, this is simply for testing
'  ReDim varArray(1)
'  varArray(0) = "Apples"
'  varArray(1) = "Oranges"
'  '####
  '@@@@ I am far from a PowerPoint expert, but a causal Google search turned up something that I could adapt to suit.
  For lngIndex = 1 To UBound(varArray)
    'Loop through each slide in presentation
    For Each oSld In ActivePresentation.Slides
      'Loop through each shape on slide
      For Each oShp In oSld.Shapes
        'Is there text in the shape?
        If oShp.HasTextFrame Then
          Set oTxtRng = oShp.TextFrame.TextRange
          Set oFoundTxt = oTxtRng.Find(FindWhat:=varArray(lngIndex, 1))
          Do While Not (oFoundTxt Is Nothing)
            With oFoundTxt
              .Font.Italic = True
              Set oFoundTxt = oTxtRng.Find(FindWhat:=varArray(lngIndex, 1), After:=.Start + .Length - 1)
            End With
          Loop
        End If
      Next oShp
    Next oSld
  Next lngIndex
lbl_Exit:
  Exit Sub
End Sub

laith93 · #5 11-09-2023, 07:06 AM

Quote:

Originally Posted by gmaxey

It was an array dimension issue.

Dear Greg Maxey

It works perfectly

Thanks so much
You saved my time
Thank you, That’s very kind of you
Thanks for your time and consideration
I can't thank you enough
I wholeheartedly appreciate everything you’ve done for me
Thank you again
Best wishes

gmaxey · #6 11-09-2023, 08:40 AM

You are certainly welcome. Again, not a PowerPoint coder so how efficient it is questionable.

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Convert Text Boxes to Normal Text in Word Using VBA Code	laith93	Word VBA	2	03-09-2023 11:51 PM
List of ascii code of Character Symbols or code for all symbols used in Word	SamDsouza	Word VBA	3	03-12-2020 04:49 AM
How I convert formua into VBA code I need help	Moot70	Excel Programming	1	10-27-2019 06:15 AM
Code to convert numbers to superscript	SidCharming	Word VBA	2	08-09-2018 08:21 AM
VBA code to convert Heading 1, 2, 3 etc. numbering	Lady_Laughsalot	Word VBA	4	04-18-2018 12:32 AM