IloveSD
03-27-2013, 01:49 AM
Hi Everybody,
I am fairly new to VBA. And I am currently implementing a search engine in a PPT deck. The basic search function works already however you can search only for one word. I would love to enlarge the function to a wild card search or so that you could at least search for two consecutive words divided by a blank.
I attached the code that is working now and hope one of you might have a great idea to broaden the seach :) THANX.
Option Explicit
Public oLastSlide As Long
'-----------------------------------------------------------------------------------
'Searches for the text in a shape and check if it is a whole word
'-----------------------------------------------------------------------------------
Private Function bTextInShape(ByVal sTextToFind As String, _
ByRef oShape As Shape) As Boolean
Dim bResult As Boolean
Dim sShapeText As String
Dim oCurrentTextRange As TextRange2
Dim oWord As TextRange2
bResult = False
If oShape.HasTextFrame Then
Set oCurrentTextRange = oShape.TextFrame2.TextRange
sShapeText = oCurrentTextRange.Text
If sShapeText <> "" Then
If InStr(1, sShapeText, sTextToFind, vbTextCompare) > 0 Then
bResult = True
End If
End If
'Check only for whole word
If bResult Then
bResult = False
For Each oWord In oCurrentTextRange.Words
If Trim(UCase(oWord.Text)) = Trim(UCase(sTextToFind)) Then
bResult = True
End If
Next oWord
End If
End If
NormalExit:
bTextInShape = bResult
Exit Function
ErrorHandler:
Resume NormalExit
End Function
'-----------------------------------------------------------------------------------
'Searches for the text in a table
'-----------------------------------------------------------------------------------
Private Function bTextInTable(ByVal sTextToFind As String, _
ByRef oTable As Table) As Boolean
Dim bResult As Boolean
Dim oCell As Shape
Dim sShapeText As String
Dim lRow As Long
Dim lCol As Long
bResult = False
With oTable
'Go through each cells
For lRow = 1 To .Rows.Count
For lCol = 1 To .Rows(lRow).Cells.Count
If Not (bResult) Then
With .Rows(lRow).Cells(lCol)
Set oCell = .Shape
If bTextInShape(sTextToFind, oCell) Then
bResult = True
End If
End With
End If
Next lCol
Next lRow
End With
NormalExit:
bTextInTable = bResult
Exit Function
ErrorHandler:
Resume NormalExit
End Function
'-----------------------------------------------------------------------------------
'Searches for the text in a group
'-----------------------------------------------------------------------------------
Private Function bTextInGroup(ByVal sTextToFind As String, _
ByRef oCurrentGroup As Shape) As Boolean
Dim bResult As Boolean
Dim oShape As Shape
Dim sShapeText As String
bResult = False
For Each oShape In oCurrentGroup.GroupItems
If Not (bResult) Then
If oShape.Type = msoGroup Then
If bTextInGroup(sTextToFind, oShape) Then
bResult = True
End If
ElseIf oShape.Type = msoTable Then
If bTextInTable(sTextToFind, oShape.Table) Then
bResult = True
End If
Else
If bTextInShape(sTextToFind, oShape) Then
bResult = True
End If
End If
End If
Next oShape
NormalExit:
bTextInGroup = bResult
Exit Function
ErrorHandler:
Resume NormalExit
End Function
'-----------------------------------------------------------------------------------
'Searches for the text in shapes and calls on the shape, table and group function
'-----------------------------------------------------------------------------------
Private Function bTextInShapes(ByVal sTextToFind As String, _
ByVal oCurrentSlide As Slide) As Boolean
Dim bResult As Boolean
Dim oShape As Shape
bResult = False
For Each oShape In oCurrentSlide.Shapes
If Not (bResult) Then
If oShape.Type = msoGroup Then
If bTextInGroup(sTextToFind, oShape) Then
bResult = True
End If
ElseIf oShape.Type = msoTable Then
If bTextInTable(sTextToFind, oShape.Table) Then
bResult = True
End If
Else
If bTextInShape(sTextToFind, oShape) Then
bResult = True
End If
End If
End If
Next oShape
NormalExit:
bTextInShapes = bResult
Exit Function
ErrorHandler:
Resume NormalExit
End Function
'-----------------------------------------------------------------------------------
'The actual search functionality
'-----------------------------------------------------------------------------------
Public Sub FindText()
Dim sTextToFind As String
Dim oListSlides As Collection
Dim oCurrentPresentation As Presentation
Dim oCurrentSlide As Slide
Dim oItem As Variant
Dim i As Long
'Executes the function to save the slide where the search was initiated
Call SaveLastSlide
sTextToFind = InputBox("Please enter the text you want to find", "CFEx Incentive Cookbook Search Engine v1.01")
'Checks if text was entered and if so proceeds with the data collection
If sTextToFind <> "" Then
Set oCurrentPresentation = Application.ActivePresentation
Set oListSlides = New Collection
'Collects the data
For Each oCurrentSlide In oCurrentPresentation.Slides
If bTextInShapes(sTextToFind, oCurrentSlide) Then
oListSlides.Add (oCurrentSlide.SlideNumber)
End If
Next oCurrentSlide
'Puts the data into the From_Slidelist or displays error message if no results where found
If oListSlides.Count = 0 Then
Call MsgBox("Text """ & sTextToFind & """ not found.", vbOKOnly)
Else
i = 0
Load Form_SlideList
With Form_SlideList
.Button_Last.Caption = "Back to original slide (Page " & oLastSlide & ")"
.L_Results = ""
.LB_Results.Clear
.L_Results = "The text """ & sTextToFind & """ was found on the following slides:"
For Each oItem In oListSlides
With .LB_Results
.ColumnCount = 3
.ColumnWidths = "30;120;360"
.AddItem
'Adds the slide number
.List(i, 0) = oItem
'Adds the chapter of the slide (section name)
.List(i, 1) = ActivePresentation.SectionProperties.Name(ActivePresentation.Slides(oItem). sectionIndex)
'Adds the Slide Title or name if no title exists
If ActivePresentation.Slides(oItem).Shapes.HasTitle Then
.List(i, 2) = ActivePresentation.Slides(oItem).Shapes.Title.TextFrame.TextRange.Text
Else: .List(i, 2) = ActivePresentation.Slides(oItem).Name
End If
i = i + 1
End With
Next oItem
.Show
End With
Unload Form_SlideList
End If
End If
NormalExit:
Exit Sub
ErrorHandler:
Resume NormalExit
End Sub
'-----------------------------------------------------------------------------------
'Saves the slide where the search function was executed
'-----------------------------------------------------------------------------------
Sub SaveLastSlide()
oLastSlide = SlideShowWindows(1).View.CurrentShowPosition
End Sub
'-----------------------------------------------------------------------------------
'Visits the slide where the search function was executed
'-----------------------------------------------------------------------------------
Sub GoToLastSlide()
ActivePresentation.SlideShowWindow.View.GotoSlide (oLastSlide)
End Sub
I am fairly new to VBA. And I am currently implementing a search engine in a PPT deck. The basic search function works already however you can search only for one word. I would love to enlarge the function to a wild card search or so that you could at least search for two consecutive words divided by a blank.
I attached the code that is working now and hope one of you might have a great idea to broaden the seach :) THANX.
Option Explicit
Public oLastSlide As Long
'-----------------------------------------------------------------------------------
'Searches for the text in a shape and check if it is a whole word
'-----------------------------------------------------------------------------------
Private Function bTextInShape(ByVal sTextToFind As String, _
ByRef oShape As Shape) As Boolean
Dim bResult As Boolean
Dim sShapeText As String
Dim oCurrentTextRange As TextRange2
Dim oWord As TextRange2
bResult = False
If oShape.HasTextFrame Then
Set oCurrentTextRange = oShape.TextFrame2.TextRange
sShapeText = oCurrentTextRange.Text
If sShapeText <> "" Then
If InStr(1, sShapeText, sTextToFind, vbTextCompare) > 0 Then
bResult = True
End If
End If
'Check only for whole word
If bResult Then
bResult = False
For Each oWord In oCurrentTextRange.Words
If Trim(UCase(oWord.Text)) = Trim(UCase(sTextToFind)) Then
bResult = True
End If
Next oWord
End If
End If
NormalExit:
bTextInShape = bResult
Exit Function
ErrorHandler:
Resume NormalExit
End Function
'-----------------------------------------------------------------------------------
'Searches for the text in a table
'-----------------------------------------------------------------------------------
Private Function bTextInTable(ByVal sTextToFind As String, _
ByRef oTable As Table) As Boolean
Dim bResult As Boolean
Dim oCell As Shape
Dim sShapeText As String
Dim lRow As Long
Dim lCol As Long
bResult = False
With oTable
'Go through each cells
For lRow = 1 To .Rows.Count
For lCol = 1 To .Rows(lRow).Cells.Count
If Not (bResult) Then
With .Rows(lRow).Cells(lCol)
Set oCell = .Shape
If bTextInShape(sTextToFind, oCell) Then
bResult = True
End If
End With
End If
Next lCol
Next lRow
End With
NormalExit:
bTextInTable = bResult
Exit Function
ErrorHandler:
Resume NormalExit
End Function
'-----------------------------------------------------------------------------------
'Searches for the text in a group
'-----------------------------------------------------------------------------------
Private Function bTextInGroup(ByVal sTextToFind As String, _
ByRef oCurrentGroup As Shape) As Boolean
Dim bResult As Boolean
Dim oShape As Shape
Dim sShapeText As String
bResult = False
For Each oShape In oCurrentGroup.GroupItems
If Not (bResult) Then
If oShape.Type = msoGroup Then
If bTextInGroup(sTextToFind, oShape) Then
bResult = True
End If
ElseIf oShape.Type = msoTable Then
If bTextInTable(sTextToFind, oShape.Table) Then
bResult = True
End If
Else
If bTextInShape(sTextToFind, oShape) Then
bResult = True
End If
End If
End If
Next oShape
NormalExit:
bTextInGroup = bResult
Exit Function
ErrorHandler:
Resume NormalExit
End Function
'-----------------------------------------------------------------------------------
'Searches for the text in shapes and calls on the shape, table and group function
'-----------------------------------------------------------------------------------
Private Function bTextInShapes(ByVal sTextToFind As String, _
ByVal oCurrentSlide As Slide) As Boolean
Dim bResult As Boolean
Dim oShape As Shape
bResult = False
For Each oShape In oCurrentSlide.Shapes
If Not (bResult) Then
If oShape.Type = msoGroup Then
If bTextInGroup(sTextToFind, oShape) Then
bResult = True
End If
ElseIf oShape.Type = msoTable Then
If bTextInTable(sTextToFind, oShape.Table) Then
bResult = True
End If
Else
If bTextInShape(sTextToFind, oShape) Then
bResult = True
End If
End If
End If
Next oShape
NormalExit:
bTextInShapes = bResult
Exit Function
ErrorHandler:
Resume NormalExit
End Function
'-----------------------------------------------------------------------------------
'The actual search functionality
'-----------------------------------------------------------------------------------
Public Sub FindText()
Dim sTextToFind As String
Dim oListSlides As Collection
Dim oCurrentPresentation As Presentation
Dim oCurrentSlide As Slide
Dim oItem As Variant
Dim i As Long
'Executes the function to save the slide where the search was initiated
Call SaveLastSlide
sTextToFind = InputBox("Please enter the text you want to find", "CFEx Incentive Cookbook Search Engine v1.01")
'Checks if text was entered and if so proceeds with the data collection
If sTextToFind <> "" Then
Set oCurrentPresentation = Application.ActivePresentation
Set oListSlides = New Collection
'Collects the data
For Each oCurrentSlide In oCurrentPresentation.Slides
If bTextInShapes(sTextToFind, oCurrentSlide) Then
oListSlides.Add (oCurrentSlide.SlideNumber)
End If
Next oCurrentSlide
'Puts the data into the From_Slidelist or displays error message if no results where found
If oListSlides.Count = 0 Then
Call MsgBox("Text """ & sTextToFind & """ not found.", vbOKOnly)
Else
i = 0
Load Form_SlideList
With Form_SlideList
.Button_Last.Caption = "Back to original slide (Page " & oLastSlide & ")"
.L_Results = ""
.LB_Results.Clear
.L_Results = "The text """ & sTextToFind & """ was found on the following slides:"
For Each oItem In oListSlides
With .LB_Results
.ColumnCount = 3
.ColumnWidths = "30;120;360"
.AddItem
'Adds the slide number
.List(i, 0) = oItem
'Adds the chapter of the slide (section name)
.List(i, 1) = ActivePresentation.SectionProperties.Name(ActivePresentation.Slides(oItem). sectionIndex)
'Adds the Slide Title or name if no title exists
If ActivePresentation.Slides(oItem).Shapes.HasTitle Then
.List(i, 2) = ActivePresentation.Slides(oItem).Shapes.Title.TextFrame.TextRange.Text
Else: .List(i, 2) = ActivePresentation.Slides(oItem).Name
End If
i = i + 1
End With
Next oItem
.Show
End With
Unload Form_SlideList
End If
End If
NormalExit:
Exit Sub
ErrorHandler:
Resume NormalExit
End Sub
'-----------------------------------------------------------------------------------
'Saves the slide where the search function was executed
'-----------------------------------------------------------------------------------
Sub SaveLastSlide()
oLastSlide = SlideShowWindows(1).View.CurrentShowPosition
End Sub
'-----------------------------------------------------------------------------------
'Visits the slide where the search function was executed
'-----------------------------------------------------------------------------------
Sub GoToLastSlide()
ActivePresentation.SlideShowWindow.View.GotoSlide (oLastSlide)
End Sub