VBA AutoCAD

--- 2 ---

'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'Рисуем таблицу по заданным значениям
Sub TABLE()
Dim lineObj As AcadLine
Dim X(0 To 2) As Double
Dim Y(0 To 2) As Double
Dim D1, D2 As Double
On Error Resume Next
Nstr = ThisDrawing.Utility.GetInteger("Введите количество строк <1>: ")
If Err Then Nstr = 1: Err.Clear 'Если нажимаем Enter,то количество строк=1
'Если ввести "0"- Выход
If Nstr = 0 Then Exit Sub
Hstr = ThisDrawing.Utility.GetInteger("Введите высоту строк <1>: ")
If Err Then Hstr = 1: Err.Clear
If Hstr = 0 Then Exit Sub
Ns = ThisDrawing.Utility.GetInteger("Введите количество столбцов <1>: ")
If Err Then Ns = 1: Err.Clear
If Ns = 0 Then Exit Sub
Ws = ThisDrawing.Utility.GetInteger("Введите ширину столбцов <1>: ")
If Err Then Ws = 1: Err.Clear
If Ws = 0 Then Exit Sub
Nstr = Abs(Nstr): Hstr = Abs(Hstr): Ns = Abs(Ns): Ws = Abs(Ws)
'Возвращает абсол.значение(MyNumber = Abs(-50.3)-Возвращает 50.3)
D1 = Ws * Ns 'D- дистанция
angle1 = 0 'angle- угол
PN = ThisDrawing.Utility.GetPoint(, "Укажите точку вставки таблицы:")
'Используем метод PolarPoint
'RetVal = PolarPoint(Point, Angle, Distance)
B = ThisDrawing.Utility.PolarPoint(PN, angle1, D1)
D2 = Hstr * Nstr
'Преобразуем угол, заданный в радианах, в градусы
'(Degrees = Radians / PI * 180)(Radians = Degrees / 180 * PI)
angle2 = -90 / 180 * 3.141592653
A = ThisDrawing.Utility.PolarPoint(PN, angle2, D2)
N1 = (B(0) - A(0)) / Ns
N2 = (B(1) - A(1)) / Nstr
'Рисуем линии с использованием счётчика цикла
X(1) = A(1): X(2) = A(2): Y(1) = B(1): Y(2) = B(2)
For I = 0 To Ns
X(0) = A(0) + I * N1: Y(0) = X(0)
Set lineObj = ThisDrawing.ModelSpace.AddLine(X, Y)
Next I
X(0) = A(0): X(2) = A(2): Y(0) = B(0): Y(2) = B(2)
For I = 0 To Nstr
X(1) = A(1) + I * N2: Y(1) = X(1)
Set lineObj = ThisDrawing.ModelSpace.AddLine(X, Y)
Next I
End Sub
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'Определение расстояния
'Между двумя точками
Sub Distance()
Dim A, B As Variant
Dim x, y, z, D As Double
A = ThisDrawing.Utility.GetPoint(, "Укажите 1-ю точку: ")
B = ThisDrawing.Utility.GetPoint(A, "Укажите 2-ю точку: ")
x = A(0) - B(0)
y = A(1) - B(1)
z = A(2) - B(2)
D = Sqr((Sqr((x ^ 2) + (y ^ 2)) ^ 2) + (z ^ 2))
MsgBox Str(D)
End Sub
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
Следующие примеры нам прислал kpblc, e-mail : kpblc2000@yandex.ru

'получение переменных активного пространства, пространства модели и
'пространства листа.
'Как правило, вставляется в отдельный модуль и потом по мере
'необходимости обращение идет уже к переменным
Global ACAD_ModelSpace As AcadModelSpace
Global ACAD_PaperSpace As AcadPaperSpace
Global ACAD_ActiveSpace As AcActiveSpace

Public Sub Init()
Set ACAD_ModelSpace = ThisDrawing.ModelSpace
Set ACAD_PaperSpace = ThisDrawing.PaperSpace
End Sub

Public Sub pGetActiveSpace()
Set ACAD_ActiveSpace = ThisDrawing.ActiveSpace
End Sub

'--------

'Получение атрибутов (редактируемых) блока и вывод их в MsgBox
Sub GetBlockAttr()
Dim objBlock As AcadBlock, objBlockRef As AcadBlockReference
Dim objAttr As AcadAttribute
Dim SelSet As AcadSelectionSet
Dim SelBlock As AcadBlockReference
Dim sSelSetName As String, sBlockAttr As String
Dim filterType(0) As Integer
Dim filterData(0) As Variant
Dim blcAttr As Variant
Dim blcAttrCounter As Long, lCounter As Long
filterType(0) = 0
filterData(0) = "INSERT"
sSelSetName = "SelectionForGetBlockAttr"
For lCounter = 0 To ThisDrawing.SelectionSets.Count
If ThisDrawing.SelectionSets.Item(lCounter).Name = sSelSetName Then
ThisDrawing.SelectionSets.Item(lCounter).Clear
ThisDrawing.SelectionSets.Item(lCounter).Delete
Exit For
End If
Next 'lCounter
Set SelSet = ThisDrawing.SelectionSets.Add(sSelSetName)
SelSet.SelectOnScreen
sBlockAttr = ""
For lCounter = 1 To SelSet.Count
Set SelBlock = SelSet.Item(lCounter - 1)
blcAttr = SelBlock.GetAttributes
For blcAttrCounter = LBound(blcAttr) To UBound(blcAttr)
sBlockAttr = sBlockAttr + "; Tag: " +
blcAttr(blcAttrCounter).TagString + _
"; Value: " + blcAttr(blcAttrCounter).TextString
Next 'blcAttrCounter
sBlockAttr = sBlockAttr + vbCr
Next 'lCounter
'Удаление SelSet
SelSet.Clear
SelSet.Delete
MsgBox sBlockAttr
End Sub

'Операции со слоями. Каждый слой закидывается в отдельный файл и
вставляется как xref в исходный.
Sub Layer2Xref()
Dim LayerCounter, SelCounter
Dim objSelSet As AcadSelectionSet
Dim gpCode(0) As Integer, groupCode As Variant
Dim datValue(0) As Variant, dataCode As Variant
Dim sLayerName As String
Dim XREF As AcadExternalReference
Dim XREF_Point(0 To 2) As Double
Dim vbAnswer As Integer
XREF_Point(0) = 0
XREF_Point(1) = 0
XREF_Point(2) = 0
For Each SelCounter In ThisDrawing.SelectionSets
If SelCounter.Name = "temp_Select" Then
SelCounter.Delete
Exit For
End If
Next 'SelCounter
gpCode(0) = 8
groupCode = gpCode
For Each LayerCounter In ThisDrawing.Layers
Set objSelSet = ThisDrawing.SelectionSets.Add("temp_Select")
datValue(0) = LayerCounter.Name
dataCode = datValue
objSelSet.Select acSelectionSetAll, , , groupCode, dataCode
vbAnswer = MsgBox("Количество объектов на слое " + LayerCounter.Name +
" : " + _
CStr(objSelSet.Application.ActiveDocument.Blocks.Count) + _
". Выполнять вставку?", vbYesNo + vbQuestion + vbApplicationModal)
If vbAnswer = vbYes Then
ThisDrawing.Wblock "c:\_kpblc\" + LayerCounter.Name + ".dwg",
objSelSet
ThisDrawing.SetVariable "CLAYER", "0"
If objSelSet.Application.ActiveDocument.Blocks.Count > 0 Then
On Error Resume Next
objSelSet.Erase
ThisDrawing.PurgeAll
Set XREF =
ThisDrawing.ModelSpace.AttachExternalReference(CStr(LayerCounter.Name) +
".dwg", CStr(LayerCounter.Name), XREF_Point, 1, 1, 1, 0, False)
ThisDrawing.Save
End If
End If
objSelSet.Delete
Next 'LayerCounter
End Sub

'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'Скоро будут еще исходники...
'Присылайте свои примеры !
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

--- 2 ---

Пишите - vbamaker@yandex.ru