There is not a whole lot to it, so I figured I'd
just post the code. You should be able to paste all this into a module and run
it, the program does expect there to be a layer named "B" - you should be able
to find and edit it. Fair warning this was an early attempt at acad vba, so it
could use some optimizing I'm sure. With that said, here ya go, and watch out
for word wrap...
Option Explicit
Dim oSS As AcadSelectionSet
Dim oEnt As
AcadEntity
Dim RemObj() As AcadEntity
Dim oLayer As AcadLayer
Dim
bLayers() As Boolean
Dim sFind As String
Dim i As Integer, j As
Integer
Dim fType(0) As Integer, fData(0) As Variant, Pt() As
Variant
Public Sub Run_FindBOM()
On Error Resume
Next
'Isolate layer B
IsolateLayers
ActiveDocument.Layers("B").LayerOn = True
'Create the
selection set
MakeSelSet
'Get the letter to
find
sFind = ActiveDocument.Utility.GetString(False, "Enter the mark
to find: ")
'Remove all non-matches
i = oSS.Count
j = 0
For i = 0 To oSS.Count - 1
If
oSS.Item(i).TextString <> sFind Then
ReDim Preserve RemObj(j)
Set RemObj(j) =
oSS.Item(i)
j = j + 1
End If
Next
'Get rid of all the items that don't
match
oSS.RemoveItems RemObj
'Report matches
found and zoom to each
If oSS.Count Then
If
MsgBox(oSS.Count & " matches found. Do you want to see them?", vbYesNo) =
vbYes Then
'Restore the previous layer
states
For i = 0 To
ActiveDocument.Layers.Count - 1
ActiveDocument.Layers(i).LayerOn = bLayers(i)
Next
'Create the array of text insertion points
ReDim Pt(oSS.Count)
j =
0
For Each oEnt In
oSS
Pt(j) =
oEnt.InsertionPoint
j = j +
1
Next
Application.ZoomCenter Pt(LBound(Pt)), (5 *
ActiveDocument.GetVariable("DIMSCALE"))
For i = LBound(Pt) + 1 To UBound(Pt) -
1
If
UCase(ActiveDocument.Utility.GetString(False, "View next (Y/N)? ")) <> "Y"
Then Exit For
Application.ZoomCenter Pt(i), (5 *
ActiveDocument.GetVariable("DIMSCALE"))
Next
End If
Else
'No
matches were found
MsgBox "No balloons matching """ &
sFind & """ were located."
End If
CleanUp
Exit Sub
ERRTRAP:
ActiveDocument.SelectionSets("SSFIND").Delete
For i = 0 To
ActiveDocument.Layers.Count - 1
ActiveDocument.Layers(i).LayerOn = bLayers(i)
Next
CleanUp
End
Sub
Private Sub IsolateLayers()
'Store the
current layer state of each layer in the drawing
For i = 0 To
ActiveDocument.Layers.Count - 1
ReDim Preserve
bLayers(i)
bLayers(i) =
ActiveDocument.Layers(i).LayerOn
ActiveDocument.Layers(i).LayerOn = False
Next
End Sub
Private Sub MakeSelSet()
On Error Resume
Next
ActiveDocument.SelectionSets("SSFIND").Delete
ActiveDocument.Utility.Prompt "Select all balloons: "
Set oSS =
ActiveDocument.SelectionSets.Add("SSFIND")
fType(0) = 0: fData(0) =
"TEXT"
oSS.SelectOnScreen fType, fData
End Sub
Sub CleanUp()
Set oSS = Nothing
Set oEnt = Nothing
Set oLayer = Nothing
Erase
bLayers
Erase fType
Erase fData
Erase fType
End
Sub
style="PADDING-RIGHT: 0px; PADDING-LEFT: 5px; MARGIN-LEFT: 5px; BORDER-LEFT: #000000 2px solid; MARGIN-RIGHT: 0px">
That
would be great Jacob. Thanks..................
