01.09.2026

74

Как открыть диалог insert block vba autocad

Как открыть диалог insert block vba autocad

Can anyone tell me why this code inserts the block twice and explodes only once?
All the code should do is insert a one block, explode the block and zoom Extents.
I can insert and explode this block manually and it works like it should.

‘This code inserts the Title/Border block «DMR-OFRAME».
Public Sub InsertOframe()

Dim BlockReference As AcadBlockReference ‘Declares a variable named «BlockReference».
Dim ExplodedObjects As Variant ‘Declares a variable named «ExplodedObjects».

‘Declares an array for insert point coordinates for title block.
Dim InputPoint(0 To 2) As Double ‘Declares a variable named «InputPoint»
InputPoint(0) = 0 ‘X
InputPoint(1) = 0 ‘Y
InputPoint(2) = 0 ‘Z

‘The [NAME] of the block should include the path with the «.dwg» extension on the end.
Set BlockReference = ThisDrawing.ModelSpace.InsertBlock(InputPoint, «C:\DRAWINGS\Designer DMR-UPU\Rev 6\DMR-OFRAME.dwg», 1#, 1#, 1#, 0#)

‘Calls the «Update» method of the «BlockReference» to ensure that the block was drawn in Model Space.
BlockReference.Update

‘Explodes the title block —
ExplodedObjects = BlockReference.Explode

‘Zooms to extents of drawing
ZoomExtents

2004-06-19 17:05:02 UTC

i haven’t used the explode method before, but perhaps it doesn’t delete
the block reference, just creates the new exploded entities, and leaves
it to the programmer to delete the original block reference.

Post by MarkW
Can anyone tell me why this code inserts the block twice and explodes only once?
All the code should do is insert a one block, explode the block and zoom Extents.
I can insert and explode this block manually and it works like it should.
CODE —————
Option Explicit
‘This code inserts the Title/Border block «DMR-OFRAME».
Public Sub InsertOframe()
Dim BlockReference As AcadBlockReference ‘Declares a variable named «BlockReference».
Dim ExplodedObjects As Variant ‘Declares a variable named «ExplodedObjects».
‘Declares an array for insert point coordinates for title block.
Dim InputPoint(0 To 2) As Double ‘Declares a variable named «InputPoint»
InputPoint(0) = 0 ‘X
InputPoint(1) = 0 ‘Y
InputPoint(2) = 0 ‘Z
‘The [NAME] of the block should include the path with the «.dwg» extension on the end.
Set BlockReference = ThisDrawing.ModelSpace.InsertBlock(InputPoint, «C:\DRAWINGS\Designer DMR-UPU\Rev 6\DMR-OFRAME.dwg», 1#, 1#, 1#, 0#)
‘Calls the «Update» method of the «BlockReference» to ensure that the block was drawn in Model Space.
BlockReference.Update
‘Explodes the title block —
ExplodedObjects = BlockReference.Explode
‘Zooms to extents of drawing
ZoomExtents
End Sub

Как открыть диалог insert block vba autocad

Здесь вы можете скачать документацию и программы для САПР AutoCAD, PCAD, 3DS, Inventor, Pro/E, Solidworks и других CAD CAM CAE EDA GIS

Объекты AutoCAD

Меню и панели инструментов

Пример процедуры, добавляющей к AutoCAD новое меню

Эта процедура добавляет к основным меню AutoCAD выпадающее меню «VBA Tools», в котором четыре пункта: «VBA Editor», «Macros List», «VBA Manager» и «Aec VBA».

Option Explicit Public Sub AddVBAMenu() Dim objMenuGroup As AcadMenuGroup Dim objVBAMenu As AcadPopupMenu Dim objVBAIDE As AcadPopupMenuItem Dim objVBARUN As AcadPopupMenuItem Dim objVBAMAN As AcadPopupMenuItem Dim objAECVBA As AcadPopupMenuItem Dim strMacro As String 'Bind to the first group of menus Set objMenuGroup = Application.MenuGroups.Item(0) 'Bind our menu as a new popup in that group. The 'Item will be captioned with 'VBA' - so if you would 'Rather it had a different name, this is the place 'To change it. Set objVBAMenu = objMenuGroup.Menus.Add("VBA Tools") 'Assign the macro Esc Esc _VBAIDE 'We will be re-using strMacro for each item strMacro = Chr(3) & Chr(3) & Chr(95) & "VBAIDE" & Chr(32) Set objVBAIDE = objVBAMenu.AddMenuItem(objVBAMenu.Count + 1, _ "VBA Editor", strMacro) 'Now for the Macro dialog strMacro = Chr(3) & Chr(3) & Chr(95) & "VBARUN" & Chr(32) Set objVBARUN = objVBAMenu.AddMenuItem(objVBAMenu.Count + 1, _ "Macros List", strMacro) 'Now the VBA Manager dialog strMacro = Chr(3) & Chr(3) & Chr(95) & "VBAMAN" & Chr(32) Set objVBAMAN = objVBAMenu.AddMenuItem(objVBAMenu.Count + 1, _ "VBA Manager", strMacro) 'Now for our special project command. Skip this one if you don't 'Want to have an item to add the AEC references to all open VBA 'Projects strMacro = Chr(3) & Chr(3) & Chr(95) & _ "-VBARUN AecProject.dvb!modRunOnce.AddRefs" & Chr(32) _ & "_VBAUNLOAD AecProject.dvb" & Chr(32) Set objAECVBA = objVBAMenu.AddMenuItem(objVBAMenu.Count + 1, _ "Aec VBA", strMacro) 'Insert it second to last objVBAMenu.InsertInMenuBar (ThisDrawing.Application.MenuBar.Count) 'IMPORTANT -IF YOU ARE JUST EXPERIMENTING 'And you do not want to apply these changes to the menu beyond the 'Current session of AutoCAD, Comment out the next line so that the 'Changes are NOT saved to file. objMenuGroup.Save (acMenuFileCompiled) End Sub
Отображение экранного меню

Процедура не только отображает меню, если оно не видно, но и скрывает его, если оно отображено.

Option Explicit Public Sub WaxOnWaxOff() Dim blnScreen As Boolean Dim objPref As AcadPreferences Set objPref = Application.Preferences blnScreen = objPref.Display.DisplayScreenMenu objPref.Display.DisplayScreenMenu = Not blnScreen End Sub
Загрузка меню из файла mnc с помощью VBA
Option Explicit Public Sub SetUpDP() Dim objBar As AcadMenuBar Dim objItem As AcadPopupMenuItem Dim strMacro As String Dim strPath As String Dim intItemCnt As Integer Set objBar = Application.MenuBar intItemCnt = objBar.Item(2).Count strMacro = Chr(3) & Chr(3) & Chr(95) & "MENULOAD DP.mnc" & Chr(32) Set objItem = objBar.Item(2).AddSeparator(intItemCnt) Set objItem = objBar.Item(2).AddMenuItem(intItemCnt + 1, "DP", strMacro) strPath = Application.Preferences.Files.SupportPath If Len(strPath) > 0 Then If InStr(1, strPath, "O:\Lib\Acad\Survey\DP\", vbTextCompare) = 0 Then strPath = strPath & ";" & "O:\Lib\Acad\Survey\DP\" End If Else strPath = "O:\Lib\Acad\Survey\DP\" End If Application.Preferences.Files.SupportPath = strPath End Sub
Создание кнопки панели инструментов с закрепленной процедурой VBA

После запуска процедуры CreateIfMissing к последней загруженной группе меню будет дабавлена панель инструментов «Sample» с одной кнопкой, при нажатии на которую будет запускаться макрос SampleStuff

Option Explicit Public Sub CreateIfMissing() Dim objMenuGrp As AcadMenuGroup Dim objTbarCol As AcadToolbars Dim objTbar As AcadToolbar Dim objItem As AcadToolbarItem Dim blnExist As Boolean Dim strMacro As String strMacro = "_-vbarun SampleStuff " Set objMenuGrp = ThisDrawing.Application.MenuGroups(0) Set objTbarCol = objMenuGrp.Toolbars For Each objTbar In objTbarCol If objTbar.Name = "Sample" Then blnExist = True End If Next objTbar If Not blnExist Then Set objTbar = objTbarCol.Add("Sample") Set objItem = objTbar.AddToolbarButton("", "Sample", _ "MsgBox", strMacro) objTbar.Visible = True 'view it! objTbar.Dock acToolbarDockTop 'Dock it! End If End Sub Public Sub SampleStuff() MsgBox "This procedure was initiated from a toolbar." End Sub
Создание панели инструментов для заморозки слоя по объекту и для разморозки всех слоев

Для работы этого примера Вам понадобятся два значька кнопок

Option Explicit Private oLayers As Collection Public Sub CreateIfMissing() Dim objMenuGrp As AcadMenuGroup Dim objTbarCol As AcadToolbars Dim objTbar As AcadToolbar Dim objItem As AcadToolbarItem Dim blnExist As Boolean Dim strMacro As String On Error GoTo Err_Control strMacro = "_-vbarun Winter " Set objMenuGrp = ThisDrawing.Application.MenuGroups(0) Set objTbarCol = objMenuGrp.Toolbars For Each objTbar In objTbarCol If objTbar.Name = "Winter_Summer" Then blnExist = True End If Next objTbar If Not blnExist Then Set objTbar = objTbarCol.Add("Winter_Summer") Set objItem = objTbar.AddToolbarButton("", "Winter", _ "Pick Freeze", strMacro) objItem.SetBitmaps "LAYFRZ16.bmp", "LAYFRZ24.bmp" 'Next Button, you get to pick the icon! strMacro = "_-vbarun Summer " Set objItem = objTbar.AddToolbarButton("", "Summer", _ "Thaw Picks", strMacro) 'See it and dock it objTbar.Visible = True objTbar.Dock acToolbarDockTop End If Exit_Here: Exit Sub Err_Control: MsgBox Err.Description Resume Exit_Here End Sub ' Зазморозка слоя по выбранному примитиву Public Sub Winter() Dim objEnt As AcadEntity Dim objLayer As AcadLayer Dim varPnt As Variant Dim strPrmt As String Dim intCnt As Integer On Error GoTo Err_Control strPrmt = vbCrLf & "Select entity: " ThisDrawing.Utility.GetEntity objEnt, varPnt, strPrmt If oLayers Is Nothing Then Set oLayers = New Collection End If If Not objEnt.Layer = ThisDrawing.ActiveLayer.Name Then Set objLayer = ThisDrawing.Layers(objEnt.Layer) objLayer.Freeze = True oLayers.Add objLayer, objLayer.Handle Else strPrmt = "Can not freeze layer " & objEnt.Layer ThisDrawing.Utility.Prompt strPrmt End If Exit_Here: Exit Sub Err_Control: MsgBox Err.Description Resume Exit_Here End Sub ' Разморозка всех слоев Public Sub Summer() Dim objLayer As AcadLayer Dim intCnt As Integer On Error GoTo Err_Control For Each objLayer In oLayers objLayer.Freeze = Not objLayer.Freeze oLayers.Remove objLayer.Handle Next objLayer ThisDrawing.Regen acAllViewports Set oLayers = Nothing Exit_Here: Exit Sub Err_Control: MsgBox Err.Description Resume Exit_Here End Sub
Скрытие и отображение всех панелей инструментов
Option Explicit Public TbarCol As Collection Public Sub HideTbars() ' Скрытие всех видимых панелей инструментов Dim objMenuGrp As AcadMenuGroup Dim objAllMenus As AcadMenuGroups Dim objTbarCol As AcadToolbars Dim objTbar As AcadToolbar Dim strMacro As String On Error GoTo Err_Control Set TbarCol = New Collection Set objAllMenus = ThisDrawing.Application.MenuGroups For Each objMenuGrp In objAllMenus Set objTbarCol = objMenuGrp.Toolbars For Each objTbar In objTbarCol If objTbar.Visible = True Then TbarCol.Add objTbar, objTbar.Name objTbar.Visible = False End If Next objTbar Next objMenuGrp Exit_Here: Exit Sub Err_Control: MsgBox Err.Description Resume Exit_Here End Sub Public Sub RestoreAll() ' Отображение всех панелей инструментов Dim objTbar As AcadToolbar For Each objTbar In TbarCol objTbar.Visible = True Next objTbar End Sub

Слои

Сохранение и восстановление состояния слоев (информация о слоях сохраняется в текстовом файлее

Приведенный ниже пример позволяет сохранить информацию о состоянии всех слоев текущего чертежа в текстовом файле с расширенимем *.lay (процедура SaveSnapShot), и, при необходимости, восстановить состояние слоев открыв этот файл (процедура RestoreSnapShot).

Для начала обеспечим отображение окон сохранения и открытия файлов с помощью Windows API функций. Поместите следующий код в стандартный модуль:

Option Explicit Public Declare Function GetSaveFileName Lib _ "comdlg32.dll" Alias "GetSaveFileNameA" _ (pOpenfilename As OPENFILENAME) As Long Public Declare Function GetOpenFileName Lib _ "comdlg32.dll" Alias "GetOpenFileNameA" _ (pOpenfilename As OPENFILENAME) As Long Public Const OFN_HIDEREADONLY = &H4 Public Type OPENFILENAME lStructSize As Long hwndOwner As Long hInstance As Long lpstrFilter As String lpstrCustomFilter As String nMaxCustFilter As Long nFilterIndex As Long lpstrFile As String nMaxFile As Long lpstrFileTitle As String nMaxFileTitle As Long lpstrInitialDir As String lpstrTitle As String flags As Long nFileOffset As Integer nFileExtension As Integer lpstrDefExt As String lCustData As Long lpfnHook As Long lpTemplateName As String End Type '@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@ ' Display and use the File open dialog '@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@ Public Function ShowOpen() As String Dim strTemp As String Dim VertName As OPENFILENAME VertName.lStructSize = Len(VertName) VertName.hwndOwner = ThisDrawing.HWND VertName.lpstrFilter = "Layer Files (*.lay)" + _ Chr$(0) + "*.lay" + Chr$(0) VertName.lpstrFile = Space$(254) VertName.nMaxFile = 255 VertName.lpstrFileTitle = Space$(254) VertName.nMaxFileTitle = 255 VertName.lpstrInitialDir = CurDir VertName.lpstrTitle = "Llamas Are Supreme" VertName.flags = 0 If GetOpenFileName(VertName) Then strTemp = (Trim(VertName.lpstrFile)) ShowOpen = Mid(strTemp, 1, Len(strTemp) - 1) End If End Function '@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@ ' Display and use the File Save dialog '@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@ Public Function ShowSave() As String Dim strTemp As String Dim VertName As OPENFILENAME VertName.lStructSize = Len(VertName) VertName.hwndOwner = ThisDrawing.HWND VertName.lpstrFilter = "Layer Files (*.lay)" + _ Chr$(0) + "*.lay" + Chr$(0) VertName.lpstrFile = Space$(254) VertName.nMaxFile = 255 VertName.lpstrFileTitle = Space$(254) VertName.nMaxFileTitle = 255 VertName.lpstrInitialDir = CurDir VertName.lpstrTitle = "Llamas Are Supreme" VertName.lpstrDefExt = ".lay" VertName.flags = OFN_HIDEREADONLY If GetSaveFileName(VertName) Then strTemp = (Trim(VertName.lpstrFile)) ShowSave = Mid(strTemp, 1, Len(strTemp) - 1) End If End Function

Теперь получение информации о слоях, ее сохранение и восстановление. Создайте еще один стандартный модуль и поместите в него следующий код:

Option Explicit Public Sub SaveSnapShot() Dim objLayers As AcadLayers Dim objLayer As AcadLayer Dim strFile As String Dim intFile As Integer strFile = ShowSave ' Отображение окна диалога "Сохранить файл" ' Открытие файла и запись в него информации о состоянии слоев If Len(strFile) > 0 Then intFile = FreeFile Set objLayers = ThisDrawing.Layers Open strFile For Output As intFile For Each objLayer In objLayers Print #intFile, objLayer.Name & ","; objLayer.Color _ & ","; objLayer.Freeze & ","; objLayer.Lock & ","; _ objLayer.LayerOn & ","; objLayer.Linetype Next objLayer End If Close intFile End Sub Public Sub RestoreSnapShot() Dim objLayers As AcadLayers Dim objLayer As AcadLayer Dim strLayerName As String Dim strFile As String Dim strActive As String Dim strTemp As String Dim strVal As String Dim intFile As Integer On Error GoTo Err_Control strFile = ShowOpen ' Отображение окна диалога "Открыть файл" If Len(strFile) > 0 Then intFile = FreeFile Set objLayers = ThisDrawing.Layers 'Find the active layer and save its name 'Then create a temp layer and set it active strActive = ThisDrawing.ActiveLayer.Name Set objLayer = objLayers.Add("snaphold") ThisDrawing.ActiveLayer = objLayer ' Открытие файла и чтение из него информации о состоянии слоев Open strFile For Input As intFile Do Until EOF(intFile) Line Input #intFile, strVal strLayerName = ParseLayer(strVal) Set objLayer = objLayers(strLayerName) objLayer.Color = CInt(ParseLayer(strTemp)) strTemp = "" objLayer.Freeze = CBool(ParseLayer(strTemp)) strTemp = "" objLayer.Lock = CBool(ParseLayer(strTemp)) strTemp = "" objLayer.LayerOn = CBool(ParseLayer(strTemp)) strTemp = "" objLayer.Linetype = ParseLayer(strTemp) strTemp = "" Loop 'Now restore the original active layer 'And delete the temp layer. Set objLayer = objLayers(strActive) ThisDrawing.ActiveLayer = objLayer objLayers("snaphold").Delete Set objLayers = Nothing Set objLayer = Nothing Close intFile End If Set objLayers = Nothing ThisDrawing.Regen acActiveViewport Exit_Here: Exit Sub Err_Control: MsgBox Err.Description Resume Exit_Here End Sub '@~~~~~~~~~~~~~ Parse Layer Info ~~~~~~~~~~~~~~~~~~~~@ ' This is a simple function the parses the delimited ' String. The first time you call it for a string, ' Pass it the complete string, for each pass after that ' Pass it an empty string. '@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@ Public Function ParseLayer(ByVal strLayerInfo As String) As String Static strInitialVal As String Dim intPos As Integer If Len(strLayerInfo) > 0 Then strInitialVal = strLayerInfo intPos = InStr(strInitialVal, ",") If intPos = 0 Then ParseLayer = strInitialVal strInitialVal = "" Else ParseLayer = Left$(strInitialVal, intPos - 1) strInitialVal = Mid$(strInitialVal, intPos + 1) End If End Function
Создание базы данных с информацией о слоях

Эта процедура создает базу данных mdb в папке текущего файла и с именем текущего файла. Созданная база данных состоит из одной таблицы, в которой содержится информация обо всех слоях текущего чертежа.

Вставте процедуру CreateLayerDB в стандартный модуль и не забудьте сделать ссылку на библиотеку Microsoft DAO 3.51 Object Library

Option Explicit Sub CreateLayerDB() Dim objDB As DAO.Database Dim objTbl As DAO.TableDef Dim objFld As DAO.Field Dim objRecSet As DAO.recordset Dim objLayer As AcadLayer Dim objLayers As AcadLayers Dim strDBName As String 'This is a fast path builder for the database, you can just hard 'code it or 'Use a dialog to get the path and name. Set objLayers = ThisDrawing.Layers strDBName = Mid(ThisDrawing.FullName, 1, _ Len(ThisDrawing.FullName) - 3) & "mdb" Set objDB = DBEngine(0).CreateDatabase(strDBName, dbLangGeneral) 'Now we add the table and fields With objDB Set objTbl = .CreateTableDef("Layers") With objTbl Set objFld = .CreateField("LName", dbText) .Fields.Append objFld Set objFld = .CreateField("LColor", dbText) .Fields.Append objFld Set objFld = .CreateField("LType", dbText) .Fields.Append objFld End With .TableDefs.Append objTbl 'Open the table Set objRecSet = .OpenRecordset("Layers") With objRecSet 'Add the layer info For Each objLayer In objLayers .AddNew !LName = objLayer.Name !LColor = objLayer.Color !LType = objLayer.Linetype .Update Next objLayer End With 'Close shop objRecSet.Close End With End Sub
Изменение имени слоев чертежа

Функция, заменяющая заданный префикс имени всех слоев чертежа на другой. Префикс должен быть отделен от основного имени знаком “-”
Создайте в чертеже несколько слоев, имя которых начинается с ADR-, например, ADR-LName (вместо LName можно использовать любое имя), и запустите процедуру TEST_ChangeLayerPrefix. При этом в имени всех слоев перфикс ADR будет заменен на HRV

Public Sub Test_ChangeLayerPrefix () ChangeLayerPrefix "ADR", "HRV" End Sub Function ChangeLayerPrefix(OldPrefix As String, NewPrefix As String) Dim oLayer As AcadLayer For Each oLayer In ThisDrawing.Layers If UCase(Left(oLayer.Name, Len(OldPrefix))) = UCase(OldPrefix) Then oLayer.Name = NewPrefix & ParseString(oLayer.Name, 1, "-") End If Next End Function Private Function ParseString(strIn As String, intLoc As Integer,_ strDelimiter As String) As String Dim intPos As Integer Dim intStrt As Integer Dim intStop As Integer Dim intCnt As Integer intCnt = intLoc Do While intCnt > 0 intStop = intPos intStrt = InStr(intPos + 1, strIn, Left$(strDelimiter, 1)) If intStrt > 0 Then intPos = intStrt intCnt = intCnt - 1 Else intPos = Len(strIn) + 1 Exit Do End If Loop ParseString = Mid$(strIn, intStrt) End Function
Удаление всех объектов с заданного слоя
Option Explicit Public Sub DelAllOnLayer() Dim obj As AcadEntity Dim currentlay As AcadLayer Dim objlayer As AcadLayer Dim strlayername As String Dim objAllSets As AcadSelectionSets Dim objSelSet As AcadSelectionSet Dim intType(0) As Integer Dim varData(0) As Variant strlayername = "bub-tx" For Each objlayer In ThisDrawing.Layers If 0 = StrComp(objlayer.Name, strlayername, vbTextCompare) Then Set objAllSets = ThisDrawing.SelectionSets For Each objSelSet In objAllSets If objSelSet.Name = "laydel" Then objSelSet.Delete Exit For End If Next objSelSet Set objSelSet = objAllSets.Add("laydel") strlayername = "bub-tx" intType(0) = 8 varData(0) = strlayername objSelSet.Select acSelectionSetAll, _ filtertype:=intType, filterdata:=varData objSelSet.Erase Exit For End If Next objlayer Set objlayer = ThisDrawing.Layers.Add(strlayername) ThisDrawing.ActiveLayer = objlayer End Sub
Сортировка примитивов чертежа по типам линий на разные слои

После запуска TEST_LayersFromLineTypes будут просмотрена информация о типе линии всех примитивов текущего чертежа. Будут созданы слои, с именами, совпадающими с именами используемых типов линий. Все примитивы чертежа будут перемещены на соответствующие их типу линии слои.

'BEGIN CODE BLOCK Option Explicit Option Compare Text 'The above line means that 'Case is ignored ("A" = "a") 'The procedure that runs the show Public Sub TEST_LayersFromLineTypes() If LayersFromLineTypes(ThisDrawing) Then MsgBox SetObjLayers & " Entities adjusted" End If End Sub '@~~~~~ Create the new layers ~~~~~~~~~~@ ' Use all of the loaded line types to ' Create new layers using the Line type's ' Name property '@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@ Public Function LayersFromLineTypes(objDwg As AcadDocument) As Boolean Dim objLayer As AcadLayer Dim objLayers As AcadLayers Dim objLineType As AcadLineType Dim objLineTypes As AcadLineTypes Dim strLineType As String Dim blnExists As Boolean On Error GoTo Err_Control Set objLineTypes = objDwg.Linetypes Set objLayers = objDwg.Layers For Each objLineType In objLineTypes strLineType = objLineType.Name For Each objLayer In objLayers If objLayer.Name = strLineType Then blnExists = True Exit For End If Next objLayer If Not blnExists Then 'Not sure what you wanted to do with 'Bylayer and ByBlock, so I left them 'In - this means that any entity with 'The line type bylayer or byblock will be 'moved to these new layers (bylayer & byblock) Set objLayer = objLayers.Add(strLineType) objLayer.Linetype = strLineType Select Case objLayer.Name Case "Hidden" objLayer.Color = acRed Case "Continuous" objLayer.Color = acBlue Case "Center" objLayer.Color = acCyan Case "Phantom" objLayer.Color = acYellow 'Add the rest of your color settings here 'Using the same format End Select Set objLayer = Nothing Else blnExists = False End If Next objLineType LayersFromLineTypes = True Exit_Here: Exit Function Err_Control: MsgBox Err.Description Resume Exit_Here End Function '@~~~~~~~~~~ move the objects ~~~~~~~~~~~@ ' Check the entities line type and move it ' To the correct layer '@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@ Public Function SetObjLayers() As Integer Dim objEnt As AcadEntity Dim objSelSet As AcadSelectionSet Dim objSelCol As AcadSelectionSets Dim intCnt As Integer On Error GoTo Err_Control 'Set up a new selection set of all entities Set objSelCol = ThisDrawing.SelectionSets For Each objSelSet In objSelCol If objSelSet.Name = "objectlayers" Then objSelSet.Delete Exit For End If Next Set objSelSet = ThisDrawing.SelectionSets.Add("objectlayers") objSelSet.Select acSelectionSetAll 'Now find everything on layer "0" and move it! For Each objEnt In objSelSet If objEnt.Layer = "0" Then objEnt.Layer = objEnt.Linetype 'count how many intCnt = intCnt + 1 End If Next objEnt 'return count SetObjLayers = intCnt Exit_Here: Exit Function Err_Control: MsgBox Err.Description Resume Exit_Here End Function 'END CODE BLOCK
Управление активностью слоя

После запуска TEST_CanBeActive у пользователя запрашивается имя слоя. Если такой слой в чертеже есть, и, если он может стать активным (если он не заморожен и не отключен), то функция CanBeActive делает этот слой текущим

'BEGIN CODE BLOCK Option Explicit Function CanBeActive(strLayer As String) As Boolean Dim oLayers As AcadLayers Dim oLayer As AcadLayer On Error GoTo Err_Control ' Проверяем состояние слоя с заданным именем Set oLayers = ThisDrawing.Layers Set oLayer = oLayers.Item(strLayer) If oLayer.Freeze = True Or oLayer.Lock = True _ Or oLayer.LayerOn = False Then CanBeActive = False Else CanBeActive = True End If Exit_Here: Exit Function Err_Control: Debug.Print Err.Description Resume Exit_Here End Function Public Sub TEST_CanBeActive() Dim sLayer As String sLayer = InputBox("Layer name") If CanBeActive(sLayer) Then ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item(sLayer) End If End Sub 'END CODE BLOCK
Пример диалогового окна с информацией о слоях

Создайте диалоговое окно, в которое поместите 3 КомбоБокса и 1 метку как на рисунке:

Читать:
Как достать чип из ключа ваз гранта

И поместите в модуль формы следующий код:

'BEGIN CODE BLOCK Option Explicit Private varLayerInfo() As Variant Private Sub UserForm_Initialize() Dim intCnt As Integer Dim oLayers As AcadLayers Set oLayers = ThisDrawing.Layers ReDim varLayerInfo(oLayers.Count - 1, 3) For intCnt = 0 To oLayers.Count - 1 varLayerInfo(intCnt, 0) = oLayers(intCnt).Name varLayerInfo(intCnt, 1) = oLayers(intCnt).Color varLayerInfo(intCnt, 2) = oLayers(intCnt).Linetype varLayerInfo(intCnt, 3) = oLayers(intCnt).Freeze Next intCnt ComboBox1.BoundColumn = 2 ComboBox2.BoundColumn = 3 ComboBox3.BoundColumn = 4 ComboBox1.List = varLayerInfo ComboBox2.List = varLayerInfo ComboBox3.List = varLayerInfo Label1.Caption = "Pick-A-Box" End Sub Private Sub ComboBox1_Change() If ComboBox1.ListIndex > -1 Then Label1.Caption = "Color #000080"> End If End Sub Private Sub ComboBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) Label1.Caption = "" ComboBox1.ListIndex = -1 End Sub Private Sub ComboBox2_Change() If ComboBox2.ListIndex > -1 Then Label1.Caption = "Line type #000080"> End If End Sub Private Sub ComboBox2_Exit(ByVal Cancel As MSForms.ReturnBoolean) Label1.Caption = "" ComboBox2.ListIndex = -1 End Sub Private Sub ComboBox3_Change() If ComboBox3.ListIndex > -1 Then If ComboBox3.Value = True Then Label1.Caption = "Layer is Frozen" Else Label1.Caption = "Layer is Thawed" End If End If End Sub Private Sub ComboBox3_Exit(ByVal Cancel As MSForms.ReturnBoolean) Label1.Caption = "" ComboBox3.ListIndex = -1 End Sub 'END CODE BLOCK

Теперь поместите в стандартный код следующую ниже процедуру. После запуска процедуры TEST_LayNfoForm будет отображено диалоговое окно, в котором при выборе имени слоя в одном из комбобоксов в нижней строке формы будет отображена соответствующая информация.

'BEGIN CODE BLOCK Sub TEST_LayNfoForm() UserForm1.Show End Sub 'END CODE BLOCK
Процедура для заполнения списка наименованиями слоев
 'BEGIN CODE BLOCK Public Sub NumericLayers(objList As ListBox) Dim intVal As Integer Dim objLayer As AcadLayer Dim objAllLayers As AcadLayers Set objAllLayers = ThisDrawing.Layers For Each objLayer In objAllLayers intVal = Val(objLayer.Name) If intVal > 0 Then objList.AddItem objLayer.Name End If Next objLayer End Sub 'END CODE BLOCK
Заморозка всех слоев чертежа кроме последнего

Пороцедура делает все слои чертежа, кроме того, который был добавлен последним, замороженными. Последний добавленный в чертеж слой становится текущим

'BEGIN CODE BLOCK Public Sub FreezeCycle() Dim objLayer As AcadLayer Dim objActiveLayer As AcadLayer Dim objAll As AcadLayers Set objAll = ThisDrawing.Layers For Each objLayer In objAll Set objActiveLayer = ThisDrawing.ActiveLayer If Not objLayer.Name = objActiveLayer.Name Then If objLayer.Freeze Then objLayer.Freeze = False End If ThisDrawing.ActiveLayer = objLayer objActiveLayer.Freeze = True End If Next objLayer End Sub 'END CODE BLOCK
Защита от изменений всех слоев всех вставленных в чертеж внешних ссылок
'BEGIN CODE BLOCK Public Sub LockXrefLayers() Dim objlayer As AcadLayer Dim objLayers As AcadLayers Dim objXref As AcadExternalReference Dim objBlk As AcadBlock On Error GoTo Err_Control For Each objBlk In ThisDrawing.Blocks If objBlk.IsXRef Then Set objLayers = objBlk.XRefDatabase.Layers For Each objlayer In objLayers objlayer.Lock = True Next objlayer End If Next objBlk Exit_Here: Exit Sub Err_Control: MsgBox Err.Description Resume Exit_Here End Sub 'END CODE BLOCK

Типы линий

Примеры из других разделов:

Стили текста

Создание текстового стиля на основании текстового файла

Для использования этой процедуры необходимо добавить класс FileDialog со страницы http://vbdesign.hypermart.net/cadpages/filedialog.htm

'BEGIN CODE BLOCK Option Explicit '@----------------------------------------------------@ '@ Создание текстового стиля на основании @ '@ информации, сохраненной в текстовом файле @ '@----------------------------------------------------@ Public Sub CreateTxtStyles() Dim objDialog As New FileDialog Dim objStyles As AcadTextStyles Dim objStyle As AcadTextStyle Dim strStyleName As String Dim strFile As String Dim strFlag(1) As String Dim strVal As String Dim intFile As Integer Dim dblOblique As Double On Error GoTo Err_Control objDialog.Title = "AutoCAD Style Files" objDialog.Filter = "Text Style (*.ats)|*.ats" strFile = objDialog.ShowOpen If Len(strFile) > 0 Then intFile = FreeFile Set objStyles = ThisDrawing.TextStyles Open strFile For Input As intFile Do Until EOF(intFile) Line Input #intFile, strVal strStyleName = GetWord(strVal, 1) Set objStyle = objStyles.Add(strStyleName) objStyle.fontFile = GetWord(strVal, 2) objStyle.Height = CDbl(GetWord(strVal, 3)) objStyle.Width = CDbl(GetWord(strVal, 4)) 'Convert degrees to radians.. dblOblique = CDbl(GetWord(strVal, 5)) dblOblique = dblOblique / 180 * (Atn(1) * 4) objStyle.ObliqueAngle = dblOblique strFlag(0) = GetWord(strVal, 6) strFlag(1) = GetWord(strVal, 7) 'If you change "n" to 0 and "y" to 1 'The structure could be like this 'If CBool(strFlag(0)) Then If strFlag(0) = "n" Then If strFlag(1) = "y" Then objStyle.TextGenerationFlag = 2 End If Else If strFlag(1) = "y" Then objStyle.TextGenerationFlag = 6 Else objStyle.TextGenerationFlag = 4 End If End If 'Notice No Vertical. Loop Set objStyles = Nothing Set objStyle = Nothing Set objDialog = Nothing Close intFile End If Exit_Here: Exit Sub Err_Control: MsgBox Err.Description Resume Exit_Here End Sub '@~~~~~~~~~~~~~~ GetWord ~~~~~~~~~~~~~~~~~@ ' Return a Whole word from a string using ' It location in the string based on a Count ' Of spaces in the string (companion to Count ' Words) '@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@ Function GetWord(strText, intLoc As Integer) As String Dim intCnt As Integer Dim intWordCnt As Integer Dim Count As Integer Dim intStrtPos As Integer Dim intEndPos As Integer Dim blnSpace As Integer Count = 0 blnSpace = True For intCnt = 1 To Len(strText) If Mid(strText, intCnt, 1) = " " Then blnSpace = True Else If blnSpace Then blnSpace = False Count = Count + 1 If Count = intLoc Then intStrtPos = intCnt Exit For End If End If End If Next intCnt intEndPos = InStr(intStrtPos, strText, " ") - 1 If intEndPos Then intEndPos = Len(strText) GetWord = Mid(strText, intStrtPos, _ intEndPos - intStrtPos + 1) End Function 'END CODE BLOCK

Системные переменные

Определение значения системной переменной
'BEGIN CODE BLOCK '@----------------------------------------------------@ '@ Определение значения системной переменной LTSCALE @ '@----------------------------------------------------@ Public Function GetLTScale() As Double GetLTScale = CDbl(ThisDrawing.GetVariable("LTSCALE")) End Function 'END CODE BLOCK
Задание значения системной переменной
'BEGIN CODE BLOCK '@----------------------------------------------------@ '@ Задание значения системной переменной LTSCALE @ '@----------------------------------------------------@ Public Function SetLTScale(dblNew As Double) As Boolean On Error Resume Next ThisDrawing.SetVariable "LTSCALE", dblNew SetLTScale = (Err.Number = 0) End Function 'END CODE BLOCK

Точки

Копирование координат точки в буфер обмена
'BEGIN CODE BLOCK '@----------------------------------------------------@ '@ Копирование координат точки в буфер обмена @ '@----------------------------------------------------@ Public Sub PointOnClipboard() Dim objClip As New DataObject Dim objUtil As AcadUtility Dim varPnt As Variant Dim strPrmt As String Dim strPnt As String Set objUtil = ThisDrawing.Utility strPrmt = "Point to place on clipboard: " varPnt = objUtil.GetPoint(Prompt:=strPrmt) strPnt = varPnt(0) & "," & varPnt(1) 'Don't want the Z? Comment next line out strPnt = strPnt & "," & varPnt(2) objClip.SetText strPnt objClip.PutInClipboard End Sub ' Еще один пример с "Работой над ошибками" Public Sub PointOnClipboard() Dim objClip As New DataObject Dim objUtil As AcadUtility Dim varPnt As Variant Dim strPrmt As String Dim strPnt As String Dim varErr As Variant On Error GoTo Err_Control Set objUtil = ThisDrawing.Utility strPrmt = "Point to place on clipboard: " varPnt = objUtil.GetPoint(Prompt:=strPrmt) strPnt = Format(varPnt(0), "0.00") & "," _ & Format(varPnt(1), "0.00") 'Don't want the Z? Comment next line out strPnt = strPnt & "," & Format(varPnt(2), "0.00") objClip.SetText strPnt objClip.PutInClipboard Exit_Here: Exit Sub Err_Control: varErr = ThisDrawing.GetVariable("LASTPROMPT") If InStr(1, varErr, "*Cancel*") <> 0 Then Err.Clear Resume Exit_Here Else MsgBox Err.Description Resume Exit_Here End If End Sub 'END CODE BLOCK

Системы координат

Перевод координат из WCS в UCS
'BEGIN CODE BLOCK '@----------------------------------------------------@ '@ Перевод координат из WCS в UCS @ '@----------------------------------------------------@ Public Sub CS_Trans() '///NEW Dim varStartPntTranslated As Variant Dim varEndPntTranslated As Variant '///End Dim Ent As AcadEntity Dim myent As Variant Dim Start_Point As Variant Dim End_Point As Variant Dim XStartPoint As Double Dim XEndPoint As Double Dim YStartPoint As Double Dim YEndPoint As Double Dim Xcheck As Double Dim Ycheck As Double Dim doc As Object Dim mycount As Integer Dim objss As Object Dim objSelCol As Object mycount = 0 Set objSelCol = ThisDrawing.SelectionSets For Each objss In objSelCol If objss.Name = "Mysel" Then objss.Delete Exit For End If Next Set objss = objSelCol.Add("Mysel") objss.SelectOnScreen mycount = 0 If objss.Count > 0 Then For Each Ent In objss If Ent.EntityName = "AcDbLine" Then Start_Point = Ent.StartPoint End_Point = Ent.EndPoint '///Translations Begin varStartPntTranslated = _ ThisDrawing.Utility.TranslateCoordinates(Start_Point, _ acWorld, acUCS, False) varEndPntTranslated = _ ThisDrawing.Utility.TranslateCoordinates(End_Point, _ acWorld, acUCS, False) '///Translation Ends XStartPoint = Start_Point(0) Debug.Print "Old: " & XStartPoint '///Now switch XStartPoint = varStartPntTranslated(0) Debug.Print "New: " & XStartPoint YStartPoint = Start_Point(1) Debug.Print "Old: " & YStartPoint '///Now switch YStartPoint = varStartPntTranslated(1) Debug.Print "New: " & YStartPoint XEndPoint = End_Point(0) Debug.Print "Old: " & XEndPoint '///Now switch XEndPoint = varEndPntTranslated(0) Debug.Print "New: " & XEndPoint YEndPoint = End_Point(1) Debug.Print "Old: " & YEndPoint '///Now switch YEndPoint = varEndPntTranslated(1) Debug.Print "New: " & XEndPoint End If Next Ent End If End Sub 'END CODE BLOCK

Пространства Модели и Листа

Примеры из других разделов:

Создание копии пространства листа (Layouts)
'BEGIN CODE BLOCK '@----------------------------------------------------@ '@ Создание копии пространства листа (Layouts) @ '@----------------------------------------------------@ Public Sub LayOutsample(strFrom As String, strTo As String) Dim objLayOut As AcadLayout 'Make sure you use AcadObject 'So we get the VP! Dim objEnt As AcadObject Dim objNewLayOut As AcadLayout Dim colLayOuts As AcadLayouts Dim objEntArray() As Object Dim intCnt As Integer Dim blnExists As Boolean Set colLayOuts = ThisDrawing.Layouts For Each objLayOut In colLayOuts If objLayOut.Name = "VBD LayOut" Then blnExists = True Exit For End If Next objLayOut If Not blnExists Then Set objNewLayOut = colLayOuts.Add(strTo) Set objLayOut = colLayOuts.Item(strFrom) 'The Block property is the block object 'Associated with the layout, so get it's 'Item count and redim the object array. ReDim objEntArray(objLayOut.Block.Count - 1) For Each objEnt In objLayOut.Block Set objEntArray(intCnt) = objEnt intCnt = intCnt + 1 Next ThisDrawing.CopyObjects objEntArray, objNewLayOut.Block objNewLayOut.CopyFrom objLayOut End If End Sub Public Sub Test_LayOutsample() LayOutsample "Layout1", "VBA Test" End Sub 'END CODE BLOCK

Inserting Blocks with VBA.

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

More sharing options.

  • Replies 21
  • Created 15 yr
  • Last Reply 11 yr
Top Posters In This Topic

  • frostrap 7 posts
  • SEANT 5 posts
  • Raggi_Thor 3 posts
  • LCE 3 posts
Popular Days
  • May 21 2008 6 posts
  • May 20 2008 5 posts
  • May 29 2008 2 posts
  • May 24 2008 1 post

Conceived, created and cared for by David Watson © 1996–2023 Powered by Invision Community

  • Existing user? Sign In
  • Sign Up

Проектирование в CAD за минуту. Команды на букву B.

легкие цены

В предыдущей статье мы познакомились с CAD-командами, начинающимися на букву A, теперь рассмотрим команды на букву B.

Благодаря универсальности используемых в ZWCAD команд, вы сможете использовать их и при работе в других распространенных системах CAD.

BLOCK (БЛОК)

Как понятно из названия, эта команда служит для создания блоков. Блок это объект, объединяющий нескольких независимых объектов, облегчающий создание и обработку различных комбинаций объектов.

  1. Создайте геометрический объекты, которые будут добавлены в блок.
  2. Выберите все объекты, которые нужно добавить в блок.
  3. Введите команду [BLOK (БЛОК)] и нажмите ENTER.
  4. Задайте имя блока
  5. Укажите базовую точку, она будет точкой вставки блока.
  6. Определите параметры Поведения блока (чаще всего можно просто оставить заданный параметр «Allow exploding» («Разрешить расчленение»)).

После создания блока и сохранения чертежа блок можно открыть через Центр управления или добавить в Палитры инструментов для последующего использования и предоставления к нему доступа.

  1. Не пропускайте шаг 3, иначе вам обеспечены проблемы с последующей вставкой блока.
  2. Правила именования блоков определяются системной переменной EXTNAMES. Если ее значение равно 1, имя блока может содержать 255 символов, среди которых могут быть буквы, цифры и пробелы.
  3. Имена блоков в одном чертеже должны быть уникальными. Если блок назван именем другого блока, его атрибуты будут такими же, как и того блока, который был создан ранее.

3D-моделирование и визуализация, поддержка внешних приложений, интерфейсов .Net/VBA/ZRX и все возможности стандартной версии

3D-моделирование и визуализация, поддержка внешних приложений, интерфейсов .Net/VBA/ZRX и все возможности стандартной версии. Срок действия лицензии — 1год.

3D-моделирование и визуализация, поддержка внешних приложений, интерфейсов .Net/VBA/ZRX и все возможности стандартной версии

Базовый САПР. Поддержка форматов DWG, DGN

BATTMAN

После ввода этой команды на экране появится Диспетчер атрибутов блоков, и вы сможете редактировать атрибуты блоков, их текст и свойства.

При редактировании блока без атрибутов вы получите предупреждение, что в текущем чертеже нет блоков с атрибутами, как показано ниже.

no BATTMAN

BEDIT (БЛОКРЕД)

Иногда вам нужно изменить уже созданный блок. Команда BEDIT (БЛОКРЕД) помогает отредактировать блок в Редакторе блока.

  1. Введите [BEDIT (БЛОКРЕД] и нажмите Enter
  2. Появится диалоговое окно Редактор определения блока.
  3. Выберите имя блока из списка.

После этого выбранный блок можно редактировать в Редакторе блоков. Например, определить его атрибуты.

  1. Диалоговое окно Редактирование определения блока можно вызвать также двойным киком по любому блоку в чертеже.
  2. В окне редактирования блока можно также указать новое имя блока и создать его в Редакторе блока. Этот вновь созданный блок будет сохранен после нажатия Да в момент закрытия Редактора блока.

по программам для проектирования
БАЗА ЗНАНИЙ
по программе ZWCAD

BMPOUT (ЭКСПОРТБМП)

Если вы хотите распечатать некоторые объекты вашего чертежа, попробуйте сохранить их в в виде изображения в формате Bitmap (BMP). Этот формат удобен тем, что этот он сохраняет цвет каждого пикселя изображения без сжатия.

  1. Введите [BMPOUT (ЭКСПОРТБМП)] и нажмите Enter
  2. Выберите объект(ы) для сохранения в .bmp формате.
  3. Введите имя файла.
  4. Задайте путь и нажмите Сохранить.

В результате будет создан BMP файл, содержащий выбранные объекты, с более высоким разрешением, чем JPG.

BREAK (РАЗОРВАТЬ)

Эта команда просто необходима для рисования U-образных лестниц на плане! Также она удобна при создании принципиальных схем.

Для более быстрого создания разрыва мы предлагаем предварительно кое-что настроить. Кликните правой кнопкой мыли на Объектной привязке в строке состояния, выберите пункт меню Параметры. В открывшемся окне Режимы рисования на вкладке Объектная привязка отметьте все опции, кроме Объектная привязка Вкл (Object Snap On на картинке ниже).

5 объектов

  1. Введите [BREAK (РАЗОРВАТЬ)] и нажмите Enter
  2. Кликните на элементе, который нужно разорвать (где бы вы ни кликнули это будет по умолчанию первая точка разрыва).
  3. Если нужно, можно переопределить первую точку, для этого нужно ввести «first» («первая») или просто «f» («п») и указать первую точку заново.
  4. Задайте вторую точку разрыва.

Часть объекта между этими точками будет вырезана.

  1. Если одна из точек разрыва находится не на выбранном объекте, то на объекте автоматически будет найдена точка, ближайшая к выбранной, и она будет взята в качестве точки разрыва.
  2. Если в качестве двух точек разрыва указана одна и та же точка, то объект будет разорван без вырезания какой-либо части. Для того, чтобы этого добиться специально, вместо того, чтобы указывать вторую точку, просто введите «@» и нажмите Enter.
  3. Однако, данный способ не работает с Кругом. Для того, чтобы разорвать круг, нужно указать две разные точки.

На этом мы закончим наш обзор CAD-команд, начинающихся на букву B. Скачайте пробную версию ZWCAD и продолжайте изучение самостоятельно, чтобы повысить эффективность своей работы.

Следующий раз рассмотрим CAD-команды, начинающиеся на букву «C».

О программе ZWCAD

ZWCAD — мощная система для 2D/3D проектирования и создания чертежей с полной поддержкой формата DWG. Программа имеет привычный интерфейс пользователя и уникальные функции, дающие значительное удобство в работе: умный выбор объектов по заданным критериям, сравнение чертежей, жесты мышью, голосовые метки, умная печать и многие другие. Являясь результатом постоянного совершенствования в течение 20 лет, ZWCAD представляет собой надежное и эффективное решение САПР, выводит процесс проектирования на высочайший уровень.

Политика лицензирования продуктов ZWCAD предусматривает возможность выбрать подходящий вариант для задач любой формы сложности, не переплачивая за избыточные функции. Тем самым, у покупателей возникают перспективы снижения издержек и проблема выбора подходящего программного обеспечения существенно облегчается.

Похожие записи

Как увеличить шрифт в sql developer

admin

Как сделать разрыв строки в ворде

admin

Как сделать регистрацию на сайте php mysql

admin