Option Explicit
Private strSearch As String
Private oTmpDoc As Document
Private lngCompare As Long
Private Sub UserForm_Initialize()
If Val(Application.Version) > 14 Then
Width = 232
Else
Width = 225
End If
lstFoundBBs.AddItem "...Pending Search..."
cmdInsert.Enabled = False
cmdInsertandClose.Enabled = False
cmdSearch.Enabled = False
lbl_Exit:
Exit Sub
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = 0 Then
Cancel = False
cmdCancel_Click
End If
lbl_Exit:
Exit Sub
End Sub
Private Sub cmdSearch_Click()
Dim oTemplate As Template
lstFoundBBs.Clear
lngCompare = 1
If chkMatchCase Then lngCompare = 0
If chkBI Then Templates.LoadBuildingBlocks
If chkAll Then
For Each oTemplate In Templates
With lstTemplates
.AddItem
.List(.ListCount - 1, 0) = oTemplate.FullName
End With
Next
End If
With lblFound
.Caption = "Building list ... please wait"
.ForeColor = &HC000&
End With
Repaint
strSearch = txtSearch.Text
Select Case True
Case chkAll
For Each oTemplate In Templates
BuildList oTemplate
Set oTemplate = Nothing
Next oTemplate
Case Else
If chkNormal Then
Set oTemplate = NormalTemplate
BuildList oTemplate
Set oTemplate = Nothing
End If
If chkBI Then
For Each oTemplate In Templates
If oTemplate.Name = "Built-In Building Blocks.dotx" Then Exit For
Next oTemplate
If Not oTemplate Is Nothing Then
BuildList oTemplate
Set oTemplate = Nothing
End If
End If
If chkAttached Then
Set oTemplate = ThisDocument.AttachedTemplate
BuildList oTemplate
Set oTemplate = Nothing
End If
End Select
With lblFound
If lstFoundBBs.ListCount > 0 Then
.Caption = "Found Blocks w\Name and Description (if defined)"
Else
.Caption = "Nothing found"
End If
.ForeColor = &H80000012
End With
lbl_Exit:
Set oTemplate = Nothing
Exit Sub
End Sub
Private Sub cmdInsert_Click()
Dim oTemplate As Template
Set oTemplate = Templates(lstFoundBBs.List(lstFoundBBs.ListCount - 1, 5))
oTemplate.BuildingBlockTypes(lstFoundBBs.List(lstFoundBBs.ListIndex, 2)) _
.Categories(lstFoundBBs.List(lstFoundBBs.ListIndex, 3)) _
.BuildingBlocks(lstFoundBBs.List(lstFoundBBs.ListIndex, 0)).Insert _
Where:=Selection.Range, RichText:=True
lbl_Exit:
Set oTemplate = Nothing
End Sub
Private Sub cmdInsertAndClose_Click()
Dim oTemplate As Template
Set oTemplate = Templates(lstFoundBBs.List(lstFoundBBs.ListCount - 1, 5))
oTemplate.BuildingBlockTypes(lstFoundBBs.List(lstFoundBBs.ListIndex, 2)) _
.Categories(lstFoundBBs.List(lstFoundBBs.ListIndex, 3)) _
.BuildingBlocks(lstFoundBBs.List(lstFoundBBs.ListIndex, 0)).Insert _
Where:=Selection.Range, RichText:=True
lbl_Exit:
Set oTemplate = Nothing
cmdCancel_Click
End Sub
Private Sub cmdCancel_Click()
If Not oTmpDoc Is Nothing Then oTmpDoc.Close wdDoNotSaveChanges
Unload Me
lbl_Exit:
Exit Sub
End Sub
Private Sub lstFoundBBs_Click()
If lstFoundBBs.ListIndex <> -1 Then
cmdInsert.Enabled = True
Else
cmdInsert.Enabled = False
End If
lbl_Exit:
Exit Sub
End Sub
Private Sub txtSearch_Change()
cmdInsert.Enabled = False
cmdSearch.Enabled = True
If txtSearch.Text = vbNullString Then cmdSearch.Enabled = False
With lstFoundBBs
.Clear
.AddItem "...Pending Search..."
End With
lblFound.Caption = "Select found building block and click Insert"
lbl_Exit:
Exit Sub
End Sub
Private Sub chkNormal_Change()
txtSearch_Change
lbl_Exit:
Exit Sub
End Sub
Private Sub chkBI_Change()
txtSearch_Change
lbl_Exit:
Exit Sub
End Sub
Private Sub chkAttached_Change()
txtSearch_Change
lbl_Exit:
Exit Sub
End Sub
Private Sub All_Change()
txtSearch_Change
lbl_Exit:
Exit Sub
End Sub
Private Sub chkMatchCase_Change()
txtSearch_Change
lbl_Exit:
Exit Sub
End Sub
Private Sub chkMWW_Change()
txtSearch_Change
lbl_Exit:
Exit Sub
End Sub
Private Sub chkShapeRanges_Change()
txtSearch_Change
lbl_Exit:
Exit Sub
End Sub
Sub BuildList(TemplatePassed As Template)
Dim lngIndex As Long
Dim oBB As BuildingBlock
Dim oRng As Range
Dim oShp As Shape
For lngIndex = 1 To TemplatePassed.BuildingBlockEntries.Count
Set oBB = TemplatePassed.BuildingBlockEntries(lngIndex)
Select Case True
Case oBB.Value = "*" Or oBB.Value Like "[*]*" Or Len(oBB.Value) > 254
If oTmpDoc Is Nothing Then Set oTmpDoc = Documents.Add(, , , False)
oBB.Insert oTmpDoc.Range
If InStr(1, oTmpDoc.Range.Text, strSearch, lngCompare) > 0 Then
If Not chkMWW Then
With lstFoundBBs
.AddItem
.List(.ListCount - 1, 0) = oBB.Name
.List(.ListCount - 1, 1) = oBB.Description
.List(.ListCount - 1, 2) = oBB.Type.Index
.List(.ListCount - 1, 3) = oBB.Category.Name
.List(.ListCount - 1, 4) = oBB.InsertOptions
.List(.ListCount - 1, 5) = TemplatePassed.FullName
End With
Else
Set oRng = oTmpDoc.Range
With oRng.Find
.Text = strSearch
.MatchCase = chkMatchCase
.MatchWholeWord = True
If .Execute Then
With lstFoundBBs
.AddItem
.List(.ListCount - 1, 0) = oBB.Name
.List(.ListCount - 1, 1) = oBB.Description
.List(.ListCount - 1, 2) = oBB.Type.Index
.List(.ListCount - 1, 3) = oBB.Category.Name
.List(.ListCount - 1, 4) = oBB.InsertOptions
.List(.ListCount - 1, 5) = TemplatePassed.FullName
End With
End If
End With
End If
Else
If chkShapeRanges Then
For Each oShp In oTmpDoc.Shapes
If fcnEvalShapeText(oShp) Then
With lstFoundBBs
.AddItem
.List(.ListCount - 1, 0) = oBB.Name
.List(.ListCount - 1, 1) = oBB.Description
.List(.ListCount - 1, 2) = oBB.Type.Index
.List(.ListCount - 1, 3) = oBB.Category.Name
.List(.ListCount - 1, 4) = oBB.InsertOptions
.List(.ListCount - 1, 5) = TemplatePassed.FullName
End With
Exit For
End If
Next
End If
End If
oTmpDoc.Range.Cut
Case Else
If InStr(1, oBB.Value, strSearch, lngCompare) > 0 Then
If Not chkMWW Then
With lstFoundBBs
.AddItem
.List(.ListCount - 1, 0) = oBB.Name
.List(.ListCount - 1, 1) = oBB.Description
.List(.ListCount - 1, 2) = oBB.Type.Index
.List(.ListCount - 1, 3) = oBB.Category.Name
.List(.ListCount - 1, 4) = oBB.InsertOptions
.List(.ListCount - 1, 5) = TemplatePassed.FullName
End With
Else
If oTmpDoc Is Nothing Then Set oTmpDoc = Documents.Add(, , , False)
oBB.Insert oTmpDoc.Range
Set oRng = oTmpDoc.Range
With oRng.Find
.Text = strSearch
.MatchCase = chkMatchCase
.MatchWholeWord = True
If .Execute Then
With lstFoundBBs
.AddItem
.List(.ListCount - 1, 0) = oBB.Name
.List(.ListCount - 1, 1) = oBB.Description
.List(.ListCount - 1, 2) = oBB.Type.Index
.List(.ListCount - 1, 3) = oBB.Category.Name
.List(.ListCount - 1, 4) = oBB.InsertOptions
.List(.ListCount - 1, 5) = TemplatePassed.FullName
End With
End If
End With
End If
End If
End Select
Next lngIndex
Set oBB = Nothing: Set TemplatePassed = Nothing
End Sub
Function fcnEvalShapeText(oShp As Shape) As Boolean
Dim oRng As Range
Dim oPar As Paragraph
fcnEvalShapeText = False
If Not chkMWW Then
On Error Resume Next
If InStr(1, oShp.TextFrame.TextRange.Text, strSearch, lngCompare) > 0 Then
If Err.Number = 0 Then
fcnEvalShapeText = True
Else
Err.Clear
If InStr(1, oShp.AlternativeText, strSearch, lngCompare) > 0 Then
If Err.Number = 0 Then
fcnEvalShapeText = True
End If
End If
End If
On Error GoTo 0
End If
Else
On Error Resume Next
If InStr(1, oShp.TextFrame.TextRange.Text, strSearch, lngCompare) > 0 Then
If Err.Number = 0 Then
Set oRng = oShp.TextFrame.TextRange
With oRng.Find
.Text = strSearch
.MatchCase = chkMatchCase
.MatchWholeWord = True
If .Execute Then fcnEvalShapeText = True
End With
Else
Err.Clear
If InStr(1, oShp.AlternativeText, strSearch, lngCompare) > 0 Then
If Err.Number = 0 Then
Set oRng = oShp.Parent.Range
oRng.Collapse wdCollapseEnd
oRng.InsertBefore vbCr
Set oPar = oRng.Paragraphs.Last.Previous
oPar.Range.Text = oShp.AlternativeText
With oPar.Range.Find
.Text = strSearch
.MatchCase = chkMatchCase
.MatchWholeWord = True
If .Execute Then fcnEvalShapeText = True
End With
oPar.Range.Delete
End If
End If
End If
On Error GoTo 0
End If
End If
lbl_Exit:
Exit Function
End Function