|
Команды AutoCAD
|
Public Function GetJig_gy(strVerb As String) As AcadEntity
' The following is a basic HACK (as in hair ball)
' It can be improved on in many ways, but not by me!
Dim objEnt As AcadEntity
Dim varPnt As Variant
Dim strPrmt As String
Dim strCommand As String
' Запрос у пользователя примитива
strPrmt = vbCr & "select entity to " & strVerb & ":"
ThisDrawing.Utility.GetEntity objEnt, varPnt, strPrmt
' Выполняем команду strCommand над примитивом objEnt
strCommand = strVerb & vbCr & "L"
ThisDrawing.SendCommand strCommand & vbCr & vbCr
Set GetJig_gy = objEnt
' Add error control!
' And watch out if you pass the Erase command or Explode!
' The return value will get you!!
End Function
Sub GetJig_gy_Test()
' Тест функции GetJig_gy
Dim AE As AcadEntity
Set AE = GetJig_gy("_copy")
End Sub
|
Определение
и отмена текущей команды.
Поместите пример в модуль ThisDrawing
Теперь, если пользователь использует команду ERASE и глобальная
переменная blnNoErase=False, то команда отменяется. Если же blnNoErase=True,
то команда выполняется.
Option Explicit
'//Limitations:
'//This will not stop the command if the object is picked first!
Dim blnNoErase As Boolean
Public Sub ToggleErase()
blnNoErase = Not blnNoErase
End Sub
Private Sub AcadDocument_BeginCommand(ByVal CommandName As String)
If CommandName = "ERASE" Then
If Not blnNoErase Then
SendKeys "{Esc}"
End If
End If
End Sub
|
Запуск процедуры VBA из командной
строки
Создвайте файл AutoLISP,
в который добавте следующее:
;; Test VBA COMMAND
(defun c:vbatest (/)
(princ)
)
|
Добавьте в стандартный
модуль проекта следующий код:
Public Sub VBATest()
MsgBox "What do you know, it works"
End Sub
|
Затем добавьте в
модуль ThisDrawing следующий код:
Private Sub AcadDocument_BeginLisp(ByVal FirstLine As String)
If FirstLine = "(C:VBATEST)" Then
Call VBATest
End If
End Sub
|
|
Команда
Array (Массив
копий)
Создание прямоугольного массива копий
группы объектов с заданным именем, количеством колонок и строк, отстоящих
друг от друга на заданное расстояние.
Создайте группу объектов с именем "TestGroupName" и запустите
процедуру TEST_ArrayGroup
Public Sub ArrayGroup(strName As String, lngColumns As Long, _
lngRows As Long, dblDist As Double)
Dim objGroup As AcadGroup
Dim objGen As AcadEntity
Set objGroup = ThisDrawing.Groups.Item(strName)
For Each objGen In objGroup
objGen.ArrayRectangular lngRows, lngColumns, 1, dblDist, _
dblDist, dblDist
Next objGen
End Sub
Sub TEST_ArrayGroup()
ArrayGroup "TestGroupName", 5, 3, 50
End Sub
|
|
Команда Break
(Разрыв объекта)
Кроме основной функции используется
вспомогательная функция NearestTo, которая возвращает точку, ближайшую
к заданной и лежащую на заданном отрезке
Public Sub TEST_ Break()
Call Break
End Sub
Public Function Break() As Variant
Dim objLine As AcadLine
Dim objOne As AcadLine
Dim objTwo As AcadLine
Dim objSpace As AcadBlock
Dim dblAng As Double
Dim varPnt As Variant
Dim varNear As Variant
Dim varFirst As Variant
Dim varSecond As Variant
Dim strPrmt As String
On Error GoTo Err_Control
If ThisDrawing.ActiveSpace = acModelSpace Then
Set objSpace = ThisDrawing.ModelSpace
Else
Set objSpace = ThisDrawing.PaperSpace
End If
strPrmt = vbCr & "Select Line to break: "
ThisDrawing.Utility.GetEntity objLine, varPnt, strPrmt
strPrmt = vbCr & "Select First Point: "
varPnt = ThisDrawing.Utility.GetPoint(Prompt:=strPrmt)
varFirst = NearestTo(objLine, varPnt)
strPrmt = vbCr & "Select Second Point: "
varPnt = ThisDrawing.Utility.GetPoint(Prompt:=strPrmt)
varSecond = NearestTo(objLine, varPnt)
dblAng = ThisDrawing.Utility.AngleFromXAxis(varFirst, varSecond)
If dblAng >= 3.14159265358979 Then
If objLine.Angle <= 3.14159265358979 Then
Set objOne = objSpace.AddLine(objLine.EndPoint, varFirst)
Set objTwo = objSpace.AddLine(varSecond, objLine.StartPoint)
Else
Set objOne = objSpace.AddLine(objLine.StartPoint, varFirst)
Set objTwo = objSpace.AddLine(varSecond, objLine.EndPoint)
End If
Else
If objLine.Angle >= 3.14159265358979 Then
Set objOne = objSpace.AddLine(objLine.EndPoint, varFirst)
Set objTwo = objSpace.AddLine(varSecond, objLine.StartPoint)
Else
Set objOne = objSpace.AddLine(objLine.StartPoint, varFirst)
Set objTwo = objSpace.AddLine(varSecond, objLine.EndPoint)
End If
End If
objLine.Delete
Break = Array(objOne, objTwo)
Exit_Here:
Exit Function
Err_Control:
MsgBox Err.Description
Resume Exit_Here
End Function
Public Function NearestTo(objLine As AcadLine, _
varPoint As Variant) As Variant
Dim objUtil As Object
Dim varTemp As Variant
Dim dblSlope As Double
Dim dblInvSlope As Double
Dim dblTemp(0 To 2) As Double
Dim dblAng As Double
Dim vStart As Variant
Dim vEnd As Variant
Dim x1 As Double
Dim y1 As Double
Dim x2 As Double
Dim y2 As Double
Dim x3 As Double
Dim y3 As Double
Dim Y1Intercept As Double
Dim Y2Intercept As Double
On Error GoTo Err_Control
vStart = objLine.StartPoint
vEnd = objLine.EndPoint
x1 = vStart(0)
y1 = vStart(1)
x2 = vEnd(0)
y2 = vEnd(1)
x3 = varPoint(0)
y3 = varPoint(1)
dblSlope = (y2 - y1) / (x2 - x1)
If dblSlope <> 0 Then
dblInvSlope = -1 / dblSlope
Else
dblInvSlope = 0
End If
Y1Intercept = y1 - (dblSlope * x1)
Y2Intercept = y3 - (dblInvSlope * x3)
If dblSlope <> 0 Then
dblTemp(0) = (Y1Intercept - Y2Intercept) / _
(dblInvSlope - dblSlope)
Else
dblTemp(0) = x3
End If
dblTemp(1) = (dblSlope * dblTemp(0)) + Y1Intercept
Set objUtil = ThisDrawing.Utility
objUtil.CreateTypedArray varTemp, vbDouble, _
dblTemp(0), dblTemp(1), dblTemp(2)
NearestTo = varTemp
Exit_Here:
Exit Function
Err_Control:
MsgBox Err.Description
Resume Exit_Here
End Function
|
|
Команды Copy (Копирование),
Move (Перемещение) и Rotate (Поворот)
Эта процедура предлагает выбрать
несколько примитивов чертежа рамкой. Затем все текстовые объекты полученного
набора подвергаются следующему:
1. Определяется содержимое текстового объекта.
2. Если содержимое текстового объекта является числом, то Z составляющая
точки вставки текста устанавливается раной этому числу.
Public Sub MoveTextObjects()
Dim Point1(0 To 2) As Double
Dim Point2(0 To 2) As Double
Dim varPnt As Variant
Dim objSelectionSet As AcadSelectionSet
' Unless we filter the selection set, we need the widest base
' of selectable entites so..
Dim textObj As AcadEntity '<---From AcadText
Dim ZValue As Double
' If you feel you MUST use this method of error control,
' Reset it as soon as you can by providing an Error handler
On Error Resume Next
ThisDrawing.SelectionSets("TempSSet").Delete
Set objSelectionSet = ThisDrawing.SelectionSets.Add("TempSSet")
If Err Then
Err.Clear '<--Keep a clean house
End If
On Error GoTo Err_Control
objSelectionSet.SelectOnScreen
For Each textObj In objSelectionSet
' We could filter the selection set, or we can just test
' items here...
If TypeOf textObj Is AcadText Then
' Whoa, need to make sure the string has a numeric value..
If IsNumeric(textObj.textString) Then
' You don't have to force the conversion, but..
ZValue = CDbl(textObj.textString)
varPnt = textObj.InsertionPoint
varPnt(2) = ZValue
textObj.InsertionPoint = varPnt
textObj.Update
End If
End If
Next
objSelectionSet.Delete
Exit_Here:
Exit Sub
Err_Control:
' Absolute minimum error handler
Debug.Print Err.Description & vbCr & Err.Number
Resume Exit_Here
End Sub
' Is that what you had in mind?
|
Коприрование
и поворот выбранных объектов
Public Sub CopyRotate()
Dim objEnt As AcadEntity
Dim objCopy As AcadEntity
Dim objUtil As AcadUtility
Dim objSelSet As AcadSelectionSet
Dim objSelCol As AcadSelectionSets
Dim dblRot As Double
Dim varPnt As Variant
Dim varBase As Variant
Dim varCancel As Variant
Dim strPrmt As String
Dim strKeys As String
' Запрос у пользователя нескольких объектов
On Error GoTo Err_Control
Set objUtil = ThisDrawing.Utility
Set objSelCol = ThisDrawing.SelectionSets
For Each objSelSet In objSelCol
If objSelSet.Name = "copyrotate" Then
objSelSet.Delete
Exit For
End If
Next
Set objSelSet = objSelCol.Add("copyrotate")
objSelSet.SelectOnScreen
' Окончание запроса нескольких объектов
strPrmt = vbCr & "Base point: "
varBase = objUtil.GetPoint(Prompt:=strPrmt)
strPrmt = vbCr & "Displacement point: "
objUtil.InitializeUserInput 33
varPnt = objUtil.GetPoint(varBase, strPrmt)
strPrmt = vbCr & "Rotation: "
objUtil.InitializeUserInput 33
dblRot = objUtil.GetAngle(varPnt, strPrmt)
For Each objEnt In objSelSet
Set objCopy = objEnt.Copy
objCopy.Move varBase, varPnt
objCopy.Rotate varPnt, dblRot
Next objEnt
objSelSet.Delete
Set objSelSet = Nothing
Set objUtil = Nothing
Set objCopy = Nothing
Exit_Here:
Exit Sub
Err_Control:
varCancel = ThisDrawing.GetVariable("LASTPROMPT")
If InStr(1, varCancel, "*Cancel*") <> 0 Then
Err.Clear
Resume Exit_Here
Else
MsgBox Err.Description
Resume Exit_Here
End If
End Sub
|
|
Команда Offset (Эквидистанта)
Эквидистантная копия объекта
на заданный слой
с примером диалогового окна для выбора слоев
Поместите следующий код в стандартный модуль:
Option Explicit
Public strLayer As String
Public Sub OffsetToLayer()
Dim objSelSet As AcadSelectionSet
Dim objSelCol As AcadSelectionSets
Dim objUtil As AcadUtility
Dim objEnt As AcadEntity
Dim varObjs As Variant
Dim blnFound As Boolean
Dim strKeys As String
Dim strOffset As String
Dim strPrmpt As String
Dim strReply As String
Dim dblDist As Double
Dim intCnt As Integer
Dim intErr As Integer
Dim intErrCnt As Integer
On Error GoTo Err_Control
strKeys = "Select List Name"
strOffset = "+ -"
Set objSelCol = ThisDrawing.SelectionSets
For Each objSelSet In objSelCol
If objSelSet.Name = "rotate" Then
objSelSet.Delete
Exit For
End If
Next
' Запрос у пользователя с использованием ключевых слов
Set objSelSet = ThisDrawing.SelectionSets.Add("rotate")
Set objUtil = ThisDrawing.Utility
strPrmpt = vbCrLf & _
"Layer to offset to [Select by objsect/List layers/<Name>]: "
Do Until blnFound
objUtil.InitializeUserInput 0, strKeys
strReply = objUtil.GetKeyword(strPrmpt)
If strReply = "List" Then
Call DisplayLayers
ElseIf strReply = "Select" Then
strLayer = SelectByEnt
ElseIf strReply = "Name" Or strReply = "" Then
strLayer = objUtil.GetString(False, vbCrLf & "Layer Name: ")
End If
strPrmpt = vbCrLf & "Layer " & strLayer & _
" not found. Layer name [Select by objsect/List layers/<Name>]: "
objUtil.InitializeUserInput 0, strKeys
blnFound = ValidateLayer(strLayer)
Loop
strPrmpt = vbCrLf & "Distance for offset: "
dblDist = objUtil.GetDistance(Prompt:=strPrmpt)
objSelSet.SelectOnScreen
strPrmpt = vbCrLf & "Offset to Greater or Lesser X,Y [+/-] <+>: "
For Each objEnt In objSelSet
objEnt.Highlight True
objEnt.Update
objUtil.InitializeUserInput 0, strOffset
strReply = objUtil.GetKeyword(strPrmpt)
If strReply = "+" Or strReply = "" Then
varObjs = objEnt.Offset(dblDist)
ElseIf strReply = "-" Then
varObjs = objEnt.Offset(-dblDist)
End If
objEnt.Highlight False
If IsArray(varObjs) Then
For intCnt = LBound(varObjs) To UBound(varObjs)
varObjs(intCnt).Layer = strLayer
Next intCnt
End If
Next objEnt
objSelSet.Delete
Exit_Here:
If intErrCnt > 0 Then
MsgBox intErrCnt & " Entities did not support VBA Offset"
End If
Exit Sub
Err_Control:
If Err.Description = _
"Object doesn't support this property or method" Then
Err.Clear
intErrCnt = intErrCnt + 1
Resume Next
ElseIf InStr(1, Err.Description, "failed", vbTextCompare) > 0 Then
intErr = CInt(ThisDrawing.GetVariable("ERRNO"))
If intErr = 52 Then
Err.Clear
Resume Exit_Here
ElseIf intErr = 7 Then
Err.Clear
Resume
End If
Else
MsgBox Err.Description
Debug.Print Err.Description
Resume Exit_Here
End If
End Sub
' Проверка наличия в чертеже слоя с заданным именем
Private Function ValidateLayer(strName As String) As Boolean
Dim objLayer As AcadLayer
Dim objLayers As AcadLayers
Set objLayers = ThisDrawing.Layers
For Each objLayer In objLayers
If objLayer.Name = strName Then
ValidateLayer = True
Exit For
End If
Next objLayer
End Function
Private Sub DisplayLayers()
On Error GoTo Err_Control
frmLayers.Show
Exit_Here:
Exit Sub
Err_Control:
MsgBox Err.Description
Err.Clear
End Sub
' Определение имени слоя по выбранному объекту
Private Function SelectByEnt() As String
On Error GoTo Err_Control
Dim objEnt As AcadEntity
Dim varPnt As Variant
Dim strPrmpt As String
Dim intErr As Integer
strPrmpt = vbCrLf & "Select entity on desired layer: "
ThisDrawing.Utility.GetEntity objEnt, varPnt, strPrmpt
SelectByEnt = objEnt.Layer
Exit_Here:
Exit Function
Err_Control:
If InStr(1, Err.Description, "failed", vbTextCompare) > 0 Then
intErr = CInt(ThisDrawing.GetVariable("ERRNO"))
If intErr = 52 Then
Err.Clear
Resume Exit_Here
ElseIf intErr = 7 Then
Err.Clear
Resume
End If
Else
MsgBox Err.Description
Debug.Print Err.Description
Resume Exit_Here
End If
End Function
|
Создайте диалоговое окно как на рисунке
И поместите в модуль форму следующий код:
Option Explicit
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias _
"SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Private Declare Function FindWindow Lib "user32" Alias _
"FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const HTBOTTOMRIGHT = 17
Dim layerInfo() As Variant
Private Sub UserForm_Initialize()
Dim objLayer As AcadLayer
Dim intCnt As Integer
ListBox1.ColumnHeads = True
ListBox1.ColumnCount = 4
' Создание массива с данными о слоях чертежа
ReDim layerInfo(ThisDrawing.Layers.Count - 1, 3)
For Each objLayer In ThisDrawing.Layers
layerInfo(intCnt, 0) = objLayer.Name
layerInfo(intCnt, 1) = objLayer.Color
If objLayer.Freeze = True Then
layerInfo(intCnt, 2) = "Fozen"
Else
layerInfo(intCnt, 2) = "Thawed"
End If
If objLayer.LayerOn Then
layerInfo(intCnt, 3) = "On"
Else
layerInfo(intCnt, 3) = "off"
End If
intCnt = intCnt + 1
Next objLayer
ListBox1.List = layerInfo
CommandButton1.Caption = "OK"
CommandButton2.Caption = "Cancel"
CommandButton1.Enabled = False
Me.PictureAlignment = fmPictureAlignmentBottomRight
' Replace the path with your own if you would like
' The form to have a "Grip"
' Me.Picture = LoadPicture("C:\mypath\frmdrag.bmp")
Me.Caption = "Layer Select & Info"
End Sub
Private Sub ListBox1_Click()
CommandButton1.Enabled = True
End Sub
Private Sub CommandButton1_Click()
strLayer = ListBox1.List(ListBox1.ListIndex, 0)
Unload Me
End Sub
Private Sub CommandButton2_Click()
Unload Me
End Sub
Private Sub UserForm_MouseDown(ByVal Button As Integer, _
ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim lngHwnd As Long
If X >= Me.Width - 10 Then
If Y >= Me.Height - 30 Then
lngHwnd = FindWindow(vbNullString, Me.Caption)
ReleaseCapture
SendMessage lngHwnd, WM_NCLBUTTONDOWN, HTBOTTOMRIGHT, ByVal 0&
End If
End If
End Sub
Private Sub UserForm_MouseMove(ByVal Button As Integer, _
ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Me.Width - 10 Then
If Y >= Me.Height - 30 Then
Me.MousePointer = fmMousePointerSizeNWSE
End If
Else
Me.MousePointer = fmMousePointerDefault
End If
End Sub
Private Sub UserForm_Resize()
ListBox1.Width = Me.Width - 20
ListBox1.Height = Me.Height - 70
CommandButton1.top = Me.Height - 50
CommandButton2.top = Me.Height - 50
End Sub
|
|
Команда Purge (Очистка базы
данных чертежа)
Удаление
из базы данных чертежа неиспользуемых блоков
'Begin PurgeBlocks
Public Sub PurgeBlocks()
Dim objSelSet As AcadSelectionSet
Dim objSelCol As AcadSelectionSets
Dim objBlkCol As AcadBlocks
Dim objBlk As AcadBlock
Dim objGen As AcadEntity
Dim intType(0) As Integer
Dim varData(0) As Variant
Dim strKeyWord As String
Dim blnVerify As Boolean
Dim strReply As String
On Error GoTo OH_NO
strKeyWord = "Yes No"
ThisDrawing.Utility.InitializeUserInput 0, strKeyWord
strReply = ThisDrawing.Utility.GetKeyword(vbCrLf _
& "Verify each name to be purged? [Yes/No] <Y>: ")
If strReply = "Yes" Then
blnVerify = True
ElseIf strReply = "" Then
blnVerify = True
Else
blnVerify = False
End If
Set objSelCol = ThisDrawing.SelectionSets
Set objBlkCol = ThisDrawing.Blocks
For Each objSelSet In objSelCol
If objSelSet.Name = "purgeblocks" Then
ThisDrawing.SelectionSets.Item("purgeblocks").Delete
Exit For
End If
Next
For Each objBlk In objBlkCol
If objBlk.IsLayout = False Then
Set objSelSet = ThisDrawing.SelectionSets.Add("purgeblocks")
intType(0) = 2
varData(0) = objBlk.Name
objSelSet.Select Mode:=acSelectionSetAll, filtertype:=intType, _
filterdata:=varData
If objSelSet.Count = 0 Then
If blnVerify Then
ThisDrawing.Utility.InitializeUserInput 0, strKeyWord
strReply = ThisDrawing.Utility.GetKeyword(vbCrLf & "Purge " _
& objBlk.Name & " [Yes/No] <Y>: ")
If strReply = "Yes" Then
For Each objGen In objBlk
objGen.Delete
Next
objBlk.Delete
ElseIf strReply = "" Then
For Each objGen In objBlk
objGen.Delete
Next
objBlk.Delete
End If
Else
For Each objGen In objBlk
objGen.Delete
Next
objBlk.Delete
End If
End If
ThisDrawing.SelectionSets.Item("purgeblocks").Delete
End If
Next
Exit_Here:
Exit Sub
OH_NO:
ThisDrawing.Utility.Prompt vbCrLf & Err.Description
Resume Exit_Here
End Sub
'End PurgeBlocks
|
Удаление
из базы данных чертежа неиспользуемых типов линий.
'Begin PurgeLTs
Public Sub PurgeLTs()
Dim objSelSet As AcadSelectionSet
Dim objSelCol As AcadSelectionSets
Dim objLTCol As AcadLineTypes
Dim objLT As AcadLineType
Dim objLayer As AcadLayer
Dim objLayers As AcadLayers
Dim intType(0) As Integer
Dim varData(0) As Variant
Dim strKeyWord As String
Dim blnVerify As Boolean
Dim blnRef As Boolean
Dim strReply As String
On Error GoTo OH_NO
strKeyWord = "Yes No"
ThisDrawing.Utility.InitializeUserInput 0, strKeyWord
strReply = ThisDrawing.Utility.GetKeyword(vbCrLf _
& "Verify each name to be purged? [Yes/No] <Y>: ")
If strReply = "Yes" Then
blnVerify = True
ElseIf strReply = "" Then
blnVerify = True
Else
blnVerify = False
End If
Set objSelCol = ThisDrawing.SelectionSets
Set objLTCol = ThisDrawing.Linetypes
Set objLayers = ThisDrawing.Layers
For Each objSelSet In objSelCol
If objSelSet.Name = "purgelts" Then
ThisDrawing.SelectionSets.Item("purgelts").Delete
Exit For
End If
Next
For Each objLT In objLTCol
If StrComp(objLT.Name, "BYLAYER", vbTextCompare) <> 0 And _
StrComp(objLT.Name, "BYBLOCK", vbTextCompare) <> 0 And _
StrComp(objLT.Name, "CONTINUOUS", vbTextCompare) <> 0 Then
Set objSelSet = ThisDrawing.SelectionSets.Add("purgelts")
intType(0) = 6
varData(0) = objLT.Name
objSelSet.Select Mode:=acSelectionSetAll, filtertype:=intType, _
filterdata:=varData
If objSelSet.Count = 0 Then
blnRef = False
For Each objLayer In objLayers
If objLayer.Linetype = objLT.Name Then
blnRef = True
Exit For
End If
Next
If Not blnRef Then
If blnVerify Then
ThisDrawing.Utility.InitializeUserInput 0, strKeyWord
strReply = ThisDrawing.Utility.GetKeyword(vbCrLf & "Purge " _
& objLT.Name & " [Yes/No] <Y>: ")
If strReply = "Yes" Then
objLT.Delete
ElseIf strReply = "" Then
objLT.Delete
End If
Else
objLT.Delete
End If
End If
End If
ThisDrawing.SelectionSets.Item("purgelts").Delete
End If
Next
Exit_Here:
Exit Sub
OH_NO:
ThisDrawing.Utility.Prompt vbCrLf & Err.Description
Resume Exit_Here
End Sub
'End PurgeLTs
|
Удаление
из базы данных чертежа неиспользуемых слоев.
'Begin PurgeLayers
Public Sub PurgeLayers()
Dim objSelSet As AcadSelectionSet
Dim objSelCol As AcadSelectionSets
Dim objLayrCol As AcadLayers
Dim objLayr As AcadLayer
Dim intType(0) As Integer
Dim varData(0) As Variant
Dim strKeyWord As String
Dim blnVerify As Boolean
Dim strReply As String
On Error GoTo OH_NO
strKeyWord = "Yes No"
ThisDrawing.Utility.InitializeUserInput 0, strKeyWord
strReply = ThisDrawing.Utility.GetKeyword(vbCrLf _
& "Verify each name to be purged? [Yes/No] <Y>: ")
If strReply = "Yes" Then
blnVerify = True
ElseIf strReply = "" Then
blnVerify = True
Else
blnVerify = False
End If
Set objSelCol = ThisDrawing.SelectionSets
Set objLayrCol = ThisDrawing.Layers
For Each objSelSet In objSelCol
If objSelSet.Name = "purgelayers" Then
ThisDrawing.SelectionSets.Item("purgelayers").Delete
Exit For
End If
Next
For Each objLayr In objLayrCol
If StrComp(objLayr.Name, ThisDrawing.ActiveLayer.Name) <> 0 Then
Set objSelSet = ThisDrawing.SelectionSets.Add("purgelayers")
intType(0) = 8
varData(0) = objLayr.Name
objSelSet.Select Mode:=acSelectionSetAll, filtertype:=intType, _
filterdata:=varData
If objSelSet.Count = 0 Then
If blnVerify Then
ThisDrawing.Utility.InitializeUserInput 0, strKeyWord
strReply = ThisDrawing.Utility.GetKeyword(vbCrLf & "Purge " _
& objLayr.Name & " [Yes/No] <Y>: ")
If strReply = "Yes" Then
objLayr.Delete
ElseIf strReply = "" Then
objLayr.Delete
End If
Else
objLayr.Delete
End If
End If
ThisDrawing.SelectionSets.Item("purgelayers").Delete
End If
Next
Exit_Here:
Exit Sub
OH_NO:
ThisDrawing.Utility.Prompt vbCrLf & Err.Description
Resume Exit_Here
End Sub
'End PurgeLayers
|
Удаление
из базы данных чертежа неиспользуемых блоков, слоев или типов линий по
выбору
Public Sub PurgeThis()
Dim strReply As String
Dim strKeys As String
Dim strPrompt As String
strKeys = "Blocks LAyers LTypes All"
strPrompt = vbCrLf & "Enter type of unused objects to purge" _
& vbCrLf & "Blocks/LAyers/LTypes/All: "
ThisDrawing.Utility.InitializeUserInput 1, strKeys
strReply = ThisDrawing.Utility.GetKeyword(strPrompt)
Select Case strReply
Case "Blocks"
Call PurgeBlocks
Case "LAyers"
Call PurgeLayers
Case "LTypes"
Call PurgeLTs
Case "All"
Call PurgeBlocks
Call PurgeLayers
Call PurgeLTs
Case Else
Debug.Print strReply
' I want to know what snuck in!
End Select
End Sub
|
Удаление
из базы данных чертежа неиспользуемых групп объектов
Public Sub GroupPurge()
Dim groupset As AcadGroups
Dim groupdead As AcadGroup
Dim test As Integer
Dim i As Long, h As Long
DoEvents
i = ThisDrawing.Groups.Count
If i > 2000 Then
test = MsgBox("This may take several minutes.", _
vbOKCancel, "Information")
End If
If test = 2 Then
End
End If
Set groupset = ThisDrawing.Groups
For h = i - 1 To 0 Step -1
DoEvents
Set groupdead = groupset.Item(h)
If groupdead.Count = 0 Then
groupdead.Delete
End If
Next h
End Sub
|
Очистка
базы данных чертежа от всех неиспользуемых элементов с помощью диалогового
окна.
В
пакет входит пример диалогового окна с запросом на удаление вышеперечисленных
элементов.
Поместите следующий код в стандартный модуль:
Option Explicit
Public Sub PurgeLineTypes()
Dim objLTs As AcadLineTypes
Dim objLT As AcadLineType
On Error GoTo Err_Control
Set objLTs = ThisDrawing.Linetypes
For Each objLT In objLTs
objLT.Delete
Next objLT
Exit_Here:
Exit Sub
Err_Control:
If Err.Number = -2145320931 Then
Resume Next
Else
MsgBox Err.Description
Resume Exit_Here
End If
End Sub
Public Sub PurgeLayers()
Dim objLyrs As AcadLayers
Dim objLyr As AcadLayer
On Error GoTo Err_Control
Set objLyrs = ThisDrawing.Layers
For Each objLyr In objLyrs
objLyr.Delete
Next objLyr
Exit_Here:
Exit Sub
Err_Control:
If Err.Number = -2145320931 Then
Resume Next
Else
MsgBox Err.Description
Resume Exit_Here
End If
End Sub
Public Sub PurgeTextStyles()
Dim objStyles As AcadTextStyles
Dim objStyle As AcadTextStyle
On Error GoTo Err_Control
Set objStyles = ThisDrawing.TextStyles
For Each objStyle In objStyles
objStyle.Delete
Next objStyle
Exit_Here:
Exit Sub
Err_Control:
If Err.Number = -2145320931 Then
Resume Next
Else
MsgBox Err.Description
Resume Exit_Here
End If
End Sub
Public Sub PurgeDimStyles()
Dim objStyles As AcadDimStyles
Dim objStyle As AcadDimStyle
On Error GoTo Err_Control
Set objStyles = ThisDrawing.DimStyles
For Each objStyle In objStyles
objStyle.Delete
Next objStyle
Exit_Here:
Exit Sub
Err_Control:
If Err.Number = -2145320931 Then
Resume Next
Else
MsgBox Err.Description
Resume Exit_Here
End If
End Sub
|
Для
тестирования процедур создайте диалоговое окно с двумя кнопками и четырьмя
чекбоксами. Поместите в модуль формы следующий код:
Private Sub UserForm_Initialize()
Frame1.Caption = "Items to Purge"
CheckBox1.Caption = "Dimension Styles"
CheckBox1.Tag = 3
CheckBox2.Caption = "Layers"
CheckBox2.Tag = 8
CheckBox3.Caption = "Line Types"
CheckBox3.Tag = 6
CheckBox4.Caption = "Text Styles"
CheckBox4.Tag = 7
CommandButton1.Caption = "Purge"
CommandButton2.Caption = "Exit"
Me.Caption = "Purge Drawing Options"
End Sub
Private Sub CommandButton1_Click()
Dim objControl As Control
For Each objControl In Me.Controls
If TypeOf objControl Is CheckBox Then
If objControl.Value = True Then
Purge objControl.Tag
End If
End If
Next objControl
End Sub
Private Sub CommandButton2_Click()
Unload Me
End Sub
Public Sub Purge(intFilter As Integer)
Select Case intFilter
Case 3
Call PurgeDimStyles
Case 6
Call PurgeLineTypes
Case 7
Call PurgeTextStyles
Case 8
Call PurgeLayers
Case Else
' Eh?
End Select
End Sub
|
Для
запуска формы добавьте в стандартный модуль следующий код:
Private Sub TEST_Purge()
UserForm1.Show
End Sub
|
|
Кроме основной процедуры здесь использована
вспомогательная функция GetLength, определяющая длину отрезка, соединяющего
две заданные точки
Public Sub HowToTrim()
Dim objEnt As AcadEntity
Dim objCut As AcadLine
Dim objTrim As AcadLine
Dim varPnt As Variant
Dim varSPnt As Variant
Dim varEPnt As Variant
Dim strPrmpt As String
Dim varTrimPnt As Variant
Dim dblTrimPnt(2) As Double
Dim varInterSectns As Variant
On Error GoTo Err_Control
strPrmpt = vbCrLf & "Select Cutting edge"
ThisDrawing.Utility.GetEntity objCut, varPnt, strPrmpt
objCut.Highlight True
Do
strPrmpt = vbCrLf & "Line to trim: "
ThisDrawing.Utility.GetEntity objEnt, varPnt, strPrmpt
If TypeOf objEnt Is AcadLine Then
Set objTrim = objEnt
varInterSectns = objTrim.IntersectWith(objCut, acExtendNone)
If IsArray(varInterSectns) Then
If UBound(varInterSectns) > 0 Then
varSPnt = objTrim.StartPoint
varEPnt = objTrim.EndPoint
dblTrimPnt(0) = varInterSectns(0)
dblTrimPnt(1) = varInterSectns(1)
dblTrimPnt(2) = varInterSectns(2)
varTrimPnt = Array(varInterSectns(0), _
varInterSectns(1), varInterSectns(2))
If GetLength(varSPnt, varPnt) > _
GetLength(varSPnt, varTrimPnt) Then
objTrim.EndPoint = dblTrimPnt
Else
objTrim.StartPoint = dblTrimPnt
End If
End If
End If
End If
Loop
Exit_here:
If Not objCut Is Nothing Then
objCut.Highlight False
End If
Exit Sub
Err_Control:
' If they select anything other than A line
If Err.Description = "Type mismatch" Then
Err.Clear
Resume
Else
' I leave it to you to choose your method of
' Error handling for the "GetEntity method failed"
' Error (see articles on Check key or the ERRNO
' Variable
Debug.Print Err.Description
Resume Exit_here
End If
End Sub
Public Function GetLength(varStart As Variant, varEnd As Variant) As Double
Dim dblLen As Double
On Error GoTo Err_Control
dblLen = Sqr((varStart(0) - varEnd(0)) ^ 2 + _
(varStart(1) - varEnd(1)) ^ 2 + _
(varStart(2) - varEnd(2)) ^ 2)
GetLength = dblLen
Exit_here:
Exit Function
Err_Control:
MsgBox Err.Description
End Function
|
|
'@~~~~~~~~~~~~~~~~ vbdBoundingBox ~~~~~~~~~~~~~~~~~~@
' From the Llama Library, this is used in the example
' To Zoom into the block!
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
Public Function vbdBoundingBox(objEntity As Object) As Variant
Dim varMin As Variant
Dim varMax As Variant
objEntity.GetBoundingBox varMin, varMax
vbdBoundingBox = Array(varMin, varMax)
End Function
Public Sub TEST_vbdBoundingBox()
Dim AE As AcadEntity
Dim varPT As Variant
Dim varZoomWindow As Variant
ThisDrawing.Utility.GetEntity AE, varPT, "Выберите объект: "
varZoomWindow = vbdBoundingBox(AE)
Application.ZoomWindow varZoomWindow(0), varZoomWindow(1)
End Sub
|
|