1、块查找和块替换源码-CAD VBA 主窗体设计 主窗体内代码 Option Explicit Private Const BLOCKS_SELECTION = 1 Private Const BLOCKS_GROUP = 2 Private Const DEFAULT_ATTR_ROTATION = 0 Private Const DEFAULT_ATTR_VISIBILITY = True Private Const DEFAULT_ATTR_XSCALE = 1 Private Const DEFAULT_ATTR_YSCALE = 1 Private Const DEFAULT_ATTR
2、_ZSCALE = 1 Private Sub AddSorted(ListObject As Object, SItem As String) Add items to a ComboBox or Listbox and sort Dim iCount As Long If ListObject.ListCount = 0 Then If no items, just add ListObject.AddItem SItem GoTo FINISH End If When we find an item that is higher in sort order, replace before
3、 For iCount = 0 To (ListObject.ListCount - 1) If StrComp(ListObject.List(iCount), SItem, vbTextCompare) = 1 Then ListObject.AddItem SItem, iCount GoTo FINISH End If Next No item was higher in sort order - add to end ListObject.AddItem SItem FINISH: End Sub Private Sub btnCancel_Click() Me.Hide End S
4、ub Private Sub btnOK_Click() Dim iCount Dim ACADObject As AcadEntity Make sure user has selected an item If optGroup.Value Then For iCount = 0 To lstDestination.ListCount - 1 If lstDestination.Selected(iCount) Then GoTo FOUNDSELECTION End If Next ElseIf optCurrentSelection.Value Then For Each ACADOb
5、ject In ThisDrawing.ActiveSelectionSet Loop through the SelectionSet collection If ACADObject.ObjectName = “AcDbBlockReference“ Then GoTo FOUNDSELECTION End If Next End If MsgBox “You must first create an active selection set containing block references, or select a group of block references to repl
6、ace.“, vbExclamation Exit Sub FOUNDSELECTION: Make sure new vales are appropriate If Not (CheckPreserveValues) Then Exit Sub End If If optGroup.Value Then ReplaceBlocks BLOCKS_GROUP, cboSource.Text Refresh Refresh lists of Blocks and Block References ElseIf optCurrentSelection.Value Then ReplaceBloc
7、ks BLOCKS_SELECTION, cboSource.Text Refresh Refresh lists of Blocks and Block References End If End Sub Private Function CheckPreserveValues() CheckPreserveValues = False Make sure rotation value is a valid number If Not (chkRotation) Then If Not (IsNumeric(txtRotation) Then MsgBox “The new rotation
8、 value must be numeric.“, vbExclamation txtRotation.SetFocus GoTo FAIL End If End If Make sure X scale value is a valid number If Not (chkXScale) Then If Not (IsNumeric(txtXScale) Then MsgBox “The new X Scale value must be numeric.“, vbExclamation txtXScale.SetFocus GoTo FAIL End If End If Make sure
9、 Y scale value is a valid number If Not (chkYScale) Then If Not (IsNumeric(txtYScale) Then MsgBox “The new Y Scale value must be numeric.“, vbExclamation txtYScale.SetFocus GoTo FAIL End If End If Make sure Z scale value is a valid number If Not (chkZScale) Then If Not (IsNumeric(txtZScale) Then Msg
10、Box “The new Z Scale value must be numeric.“, vbExclamation txtZScale.SetFocus GoTo FAIL End If End If CheckPreserveValues = True FAIL: Exit Function End Function Private Sub ReplaceBlocks(ByVal WhichBlocks As Integer, ByVal WithBlock As String) Dim iCount As Integer Dim ACADObject As AcadEntity Dim
11、 OldReferenceInformation As New Collection Dim Reference As CBlockReference Dim GroupsSelected As New Collection Dim BlockRefName As String Dim BlockGroupName As String Dim InsertionPoint(0 To 2) As Double Dim NewBlock As AcadBlockReference On Error GoTo REPLACE_ERROR Select Case WhichBlocks Case BL
12、OCKS_GROUP First get list of block reference groups to replace For iCount = 0 To lstDestination.ListCount - 1 If lstDestination.Selected(iCount) Then BlockGroupName = lstDestination.List(iCount) GroupsSelected.Add BlockGroupName End If Next Now find matching block references in modelspace For Each A
13、CADObject In ThisDrawing.ModelSpace Loop through the SelectionSet collection If ACADObject.ObjectName = “AcDbBlockReference“ Then BlockRefName = ACADObject.Name Store information about the references we are about to replace For iCount = 1 To GroupsSelected.Count If GroupsSelected(iCount) = BlockRefN
14、ame Then Set Reference = New CBlockReference StoreReferenceInfo Reference, ACADObject OldReferenceInformation.Add Reference Set Reference = Nothing Remove old object ACADObject.Delete End If Next End If Next Case BLOCKS_SELECTION Get information for block references in active selection set and save
15、For Each ACADObject In ThisDrawing.ActiveSelectionSet Loop through the SelectionSet collection If ACADObject.ObjectName = “AcDbBlockReference“ Then Set Reference = New CBlockReference StoreReferenceInfo Reference, ACADObject OldReferenceInformation.Add Reference Set Reference = Nothing Remove old ob
16、ject ACADObject.Delete End If Next End Select Add new block references and refresh drawing For Each Reference In OldReferenceInformation InsertionPoint(0) = Reference.InsertionPoint(0) InsertionPoint(1) = Reference.InsertionPoint(1) InsertionPoint(2) = Reference.InsertionPoint(2) Set NewBlock = This
17、Drawing.ModelSpace.InsertBlock(InsertionPoint, WithBlock, _ Reference.XScale, Reference.YScale, Reference.ZScale, Reference.Rotation) NewBlock.Visible = Reference.IsVisible Next ThisDrawing.Regen acAllViewports Exit Sub REPLACE_ERROR: MsgBox “The following error has occurred trying to replace a bloc
18、k: “ & Err.Description End Sub Private Sub btnRefresh_Click() Refresh Refresh lists of blocks and block references End Sub Private Sub Refresh() Dim BlockList As Collection Dim BlockReferencesList As Collection On Error GoTo GENERAL_ERROR Get list of blocks Set BlockReferencesList = GetBlockReferenc
19、es() Set BlockList = GetBlocks() Are there any blocks references to replace? If BlockList Is Nothing Then MsgBox “No Block References Were Found In The Current Drawing.“, vbExclamation SetControls False Exit Sub Else SetControls True End If Refresh both lists RefreshList cboSource, BlockList Refresh
20、List lstDestination, BlockReferencesList Select first entry in blocklist If cboSource.ListIndex = -1 Then cboSource.ListIndex = 0 End If Exit Sub GENERAL_ERROR: MsgBox “The following error has occurred trying to replace a block: “ & Err.Description End End Sub Private Sub RefreshList(ByRef ListObjec
21、t As Object, ByRef BlockList As Collection) Dim SelectedItems As New Collection Dim iCount As Long Dim RowText As String Dim StoredSelection As String First, save selected items before we overwrite list If TypeName(ListObject) = “ListBox“ Then Save for Listboxes For iCount = 0 To (ListObject.ListCou
22、nt - 1) If ListObject.Selected(iCount) Then RowText = ListObject.List(iCount) SelectedItems.Add RowText, RowText End If Next ElseIf TypeName(ListObject) = “ComboBox“ Then Save for ComboBoxes RowText = ListObject.Text SelectedItems.Add RowText, RowText End If Add new block list to this control ListOb
23、ject.Clear First clear For iCount = 1 To BlockList.Count AddSorted ListObject, BlockList(iCount) Next End Sub Private Sub SetSelections(ByRef ListObject As Object, ByVal SelectedItems As Collection) Dim iCount As Long Dim RowText As String Dim StoredSelection As String Restore selections If Selected
24、Items.Count 0 Then For iCount = 0 To (ListObject.ListCount - 1) RowText = ListObject.List(iCount) This is a quick way to query the collection On Error Resume Next StoredSelection = “ StoredSelection = SelectedItems(RowText) On Error GoTo 0 If we found the text for this row in our collection then res
25、elect If StoredSelection 0 Then Set GetBlocks = BlockList Else Set GetBlocks = Nothing End If End Function Private Function GetBlockReferences() As Collection Dim BlockList As New Collection Dim iCount As Long Dim ACADObject As AcadEntity Get list of available block references For Each ACADObject In
26、 ThisDrawing.ModelSpace If ACADObject.ObjectName = “AcDbBlockReference“ Then On Error Resume Next Simple way to avoid duplcates in collection BlockList.Add ACADObject.Name, ACADObject.Name On Error GoTo 0 End If Next Return list of block references in this drawing If BlockList.Count 0 Then Set GetBl
27、ockReferences = BlockList Else Set GetBlockReferences = Nothing End If End Function Private Sub Label1_Click() End Sub Private Sub btnUndo_Click() ThisDrawing.ModelSpace.undo End Sub Private Sub chkRotation_Change() txtRotation.Enabled = Not (chkRotation) End Sub Private Sub chkVisibility_Change() o
28、ptVisibilityOn.Enabled = Not (chkVisibility) optVisibilityOff.Enabled = Not (chkVisibility) End Sub Private Sub chkXScale_Change() txtXScale.Enabled = Not (chkXScale) End Sub Private Sub chkYScale_Change() txtYScale.Enabled = Not (chkYScale) End Sub Private Sub chkZScale_Change() txtZScale.Enabled =
29、 Not (chkZScale) End Sub Private Sub optCurrentSelection_Click() SetControlGroupBox False End Sub Private Sub optGroup_Click() SetControlGroupBox True End Sub Private Sub SetControlGroupBox(IsOn As Boolean) lstDestination.Enabled = IsOn Make the control look enabled/disabled, since it doesnt automat
30、ically If IsOn Then lstDestination.ForeColor = RGB(0, 0, 0) Else lstDestination.ForeColor = RGB(150, 150, 150) End If End Sub Private Sub UserForm_Initialize() FillDefaultValues Refresh Refresh lists of blocks and block references End Sub Private Sub FillDefaultValues() txtRotation = DEFAULT_ATTR_RO
31、TATION optVisibilityOn.Value = DEFAULT_ATTR_VISIBILITY txtXScale = DEFAULT_ATTR_XSCALE txtYScale = DEFAULT_ATTR_YSCALE txtZScale = DEFAULT_ATTR_ZSCALE End Sub Private Sub StoreReferenceInfo(Reference As CBlockReference, ACADObject As AcadEntity) Always save insertion point Reference.InsertionPoint =
32、 ACADObject.InsertionPoint Save rotation? If chkRotation Then Reference.Rotation = ACADObject.Rotation Else: Reference.Rotation = txtRotation End If Save visibility If chkVisibility Then Reference.IsVisible = ACADObject.Visible Else: Reference.IsVisible = optVisibilityOn End If Save X scale If chkXS
33、cale Then Reference.XScale = ACADObject.XScaleFactor Else: Reference.XScale = txtXScale End If Save Y scale If chkYScale Then Reference.YScale = ACADObject.YScaleFactor Else: Reference.YScale = txtYScale End If Save Y scale If chkZScale Then Reference.ZScale = ACADObject.ZScaleFactor Else: Reference.ZScale = txtZScale End If End Sub 模块名及窗体名 CBlockReference类内的代码 Option Explicit Public XScale As Double Public YScale As Double Public ZScale As Double Public Rotation As Double Public IsVisible As Boolean Public InsertionPoint As Variant
