《2022年2022年块查找和块替换源码-CADVBA》由会员分享，可在线阅读，更多相关《2022年2022年块查找和块替换源码-CADVBA（12页珍藏版）》请在金锄头文库上搜索。
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_Z
2、SCALE = 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 F
3、or iCount = 0 To (ListObject.ListCount - 1) If StrComp(ListObject.List(iCount), SItem, vbTextCompare) = 1 Then ListObject.AddItem SItem, iCount GoTo FINISH End If Next 名师资料总结 - - -精品资料欢迎下载 - - - - - - - - - - - - - - - - - - 名师精心整理 - - - - - - - 第 1 页，共 12 页 - - - - - - - - - No item was higher in s
4、ort order - add to end ListObject.AddItem SItem FINISH: End Sub Private Sub btnCancel_Click() Me.Hide End Sub 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.
5、Selected(iCount) Then GoTo FOUNDSELECTION End If Next ElseIf optCurrentSelection.Value Then For Each ACADObject In ThisDrawing.ActiveSelectionSet Loop through the SelectionSet collection If ACADObject.ObjectName = AcDbBlockReference Then GoTo FOUNDSELECTION End If Next End If MsgBox You must first c
6、reate an active selection set containing block references, or select a group of block references to replace., vbExclamation Exit Sub FOUNDSELECTION: Make sure new vales are appropriate If Not (CheckPreserveValues) Then Exit Sub End If If optGroup.Value Then 名师资料总结 - - -精品资料欢迎下载 - - - - - - - - - - -
7、 - - - - - - - 名师精心整理 - - - - - - - 第 2 页，共 12 页 - - - - - - - - - ReplaceBlocks BLOCKS_GROUP, cboSource.Text Refresh Refresh lists of Blocks and Block References ElseIf optCurrentSelection.Value Then ReplaceBlocks BLOCKS_SELECTION, cboSource.Text Refresh Refresh lists of Blocks and Block References
8、 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 value must be numeric., vbExclamation txtRotation.SetFocus GoTo FAIL End If End If Make
9、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 Y scale value is a valid number If Not (chkYScale) Then If Not (IsNumeric(txtYScale) Then M
10、sgBox 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 MsgBox The new Z Scale value must be numeric., vbExclamation txtZScale.SetFocus 名师资料总结 - - -精品资料欢
11、迎下载 - - - - - - - - - - - - - - - - - - 名师精心整理 - - - - - - - 第 3 页，共 12 页 - - - - - - - - - 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 A
12、cadEntity Dim 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 WhichB
13、locks Case BLOCKS_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 modelspa
14、ce For Each ACADObject 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)
15、= BlockRefName Then Set Reference = New CBlockReference 名师资料总结 - - -精品资料欢迎下载 - - - - - - - - - - - - - - - - - - 名师精心整理 - - - - - - - 第 4 页，共 12 页 - - - - - - - - - StoreReferenceInfo Reference, ACADObject OldReferenceInformation.Add Reference Set Reference = Nothing Remove old object ACADObject.Del
16、ete End If Next End If Next Case BLOCKS_SELECTION Get information for block references in active selection set and save For Each ACADObject In ThisDrawing.ActiveSelectionSet Loop through the SelectionSet collection If ACADObject.ObjectName = AcDbBlockReference Then Set Reference = New CBlockReferenc
17、e StoreReferenceInfo Reference, ACADObject OldReferenceInformation.Add Reference Set Reference = Nothing Remove old object ACADObject.Delete End If Next End Select Add new block references and refresh drawing For Each Reference In OldReferenceInformation InsertionPoint(0) = Reference.InsertionPoint(
18、0) InsertionPoint(1) = Reference.InsertionPoint(1) InsertionPoint(2) = Reference.InsertionPoint(2) Set NewBlock = ThisDrawing.ModelSpace.InsertBlock(InsertionPoint, WithBlock, _ Reference.XScale, Reference.YScale, Reference.ZScale, Reference.Rotation) NewBlock.Visible = Reference.IsVisible Next This
19、Drawing.Regen acAllViewports Exit Sub 名师资料总结 - - -精品资料欢迎下载 - - - - - - - - - - - - - - - - - - 名师精心整理 - - - - - - - 第 5 页，共 12 页 - - - - - - - - - REPLACE_ERROR: MsgBox The following error has occurred trying to replace a block: & Err.Description End Sub Private Sub btnRefresh_Click() Refresh Refres
20、h 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 = GetBlockReferences() Set BlockList = GetBlocks() Are there any blocks references to replace?
21、 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 RefreshList lstDestination, BlockReferencesList Select first entry in blocklist If cb
22、oSource.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 名师资料总结 - - -精品资料欢迎下载 - - - - - - - - - - - - - - - - - - 名师精心整理 - - - - - - - 第 6 页，共 12 页 - - - - - - - - - End Sub Private Sub
23、 RefreshList(ByRef ListObject 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
24、= 0 To (ListObject.ListCount - 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 lis
25、t to this control ListObject.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 Restor
26、e selections If SelectedItems.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) 名师资料总结 - - -精品资料欢迎下载 - - - - - - - - - - - - - - - - -
27、 - 名师精心整理 - - - - - - - 第 7 页，共 12 页 - - - - - - - - - On Error GoTo 0 If we found the text for this row in our collection then reselect If StoredSelection Then If TypeName(ListObject) = ListBox Then Restore for ListBoxes ListObject.Selected(iCount) = True ElseIf TypeName(ListObject) = ComboBox Then
28、 Restore for ComboBoxes ListObject.Text = StoredSelection End If End If Next End If End Sub Private Sub SetControls(ByVal TurnedOn As Boolean) Turn all controls on or off Main buttons btnOK.Enabled = TurnedOn Replace group fraReplace.Enabled = TurnedOn lblSource.Enabled = TurnedOn lblDestination.Ena
29、bled = TurnedOn lstDestination.Enabled = TurnedOn cboSource.Enabled = TurnedOn optGroup.Enabled = TurnedOn optCurrentSelection.Enabled = TurnedOn Preserve group fraAttributes.Enabled = TurnedOn lblPreserve.Enabled = TurnedOn lblValue.Enabled = TurnedOn lblUnderline.Enabled = TurnedOn optVisibilityOn
30、.Enabled = TurnedOn optVisibilityOff.Enabled = TurnedOn txtRotation.Enabled = TurnedOn txtXScale.Enabled = TurnedOn txtYScale.Enabled = TurnedOn txtZScale.Enabled = TurnedOn chkRotation.Enabled = TurnedOn chkXScale.Enabled = TurnedOn chkYScale.Enabled = TurnedOn 名师资料总结 - - -精品资料欢迎下载 - - - - - - - -
31、- - - - - - - - - - 名师精心整理 - - - - - - - 第 8 页，共 12 页 - - - - - - - - - chkZScale.Enabled = TurnedOn chkVisibility.Enabled = TurnedOn Option group - This compensates for the fact that it doesnt look enabled/disabled If TurnedOn Then SetControlGroupBox (optGroup.Value = True) Else SetControlGroupBox
32、False End If End Sub Private Function GetBlocks() As Collection Dim BlockList As New Collection Dim iCount As Long Dim ACADObject As AcadBlock Get list of available blocks For Each ACADObject In ThisDrawing.Blocks If ACADObject.IsLayout = False Then BlockList.Add ACADObject.Name, ACADObject.Name End
33、 If Next Return list of blocks in this drawing If BlockList.Count 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 availabl
34、e block references For Each ACADObject In 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 名师资料总结 - - -精品资料欢迎下载 - - - - - - - - - - - -
35、 - - - - - - 名师精心整理 - - - - - - - 第 9 页，共 12 页 - - - - - - - - - Return list of block references in this drawing If BlockList.Count 0 Then Set GetBlockReferences = BlockList Else Set GetBlockReferences = Nothing End If End Function Private Sub Label1_Click() End Sub Private Sub btnUndo_Click() ThisD
36、rawing.ModelSpace.undo End Sub Private Sub chkRotation_Change() txtRotation.Enabled = Not (chkRotation) End Sub Private Sub chkVisibility_Change() optVisibilityOn.Enabled = Not (chkVisibility) optVisibilityOff.Enabled = Not (chkVisibility) End Sub Private Sub chkXScale_Change() txtXScale.Enabled = N
37、ot (chkXScale) End Sub Private Sub chkYScale_Change() txtYScale.Enabled = Not (chkYScale) End Sub Private Sub chkZScale_Change() txtZScale.Enabled = Not (chkZScale) End Sub Private Sub optCurrentSelection_Click() SetControlGroupBox False End Sub 名师资料总结 - - -精品资料欢迎下载 - - - - - - - - - - - - - - - - -
38、 - 名师精心整理 - - - - - - - 第 10 页，共 12 页 - - - - - - - - - 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 automatically If IsOn Then lstDestination.ForeCol
39、or = 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_ROTATION optVisibilityOn.Value = DEFAULT_ATT
40、R_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 = ACADObject.InsertionPoint Save rotation?
41、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 名师资料总结 - - -精品资料欢迎下载 - - - - - - - - - - - - - - - - - - 名师精心整理 - - -
42、- - - - 第 11 页，共 12 页 - - - - - - - - - End If Save X scale If chkXScale 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 chkZS
43、cale 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 名师资料总结 - - -精品资料欢迎下载 - - - - - - - - - - - - - - - - - - 名师精心整理 - - - - - - - 第 12 页，共 12 页 - - - - - - - - -
