Здесь будут размещены примеры кода на VBA, найденные во всемирной паутине и присланные Вами

--- 1 ---

'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'В данном примере используются фильтры выбора.
'При запросе на выделение будут выбраны только блоки
'Выдается их количество...
'Хорошо бы было, чтобы и имя блока выдавалось.
Public Function SelectOnlyOnScreen() As AcadSelectionSet
Dim objSelSet As AcadSelectionSet
Dim objSelCol As AcadSelectionSets
Dim intType(0) As Integer
Dim varData(0) As Variant
Set objSelCol = ThisDrawing.SelectionSets
For Each objSelSet In objSelCol
If objSelSet.Name = "Only" Then
objSelSet.Delete
Exit For
End If
Next
Set objSelSet = ThisDrawing.SelectionSets.Add("Only")
intType(0) = 0 'Фильтры выбора
varData(0) = "INSERT" '"INSERT" для выбора блока
objSelSet.SelectOnScreen intType, varData
Set SelectOnlyOnScreen = objSelSet
End Function
Public Sub BlockCount()
Dim acSelSet As AcadSelectionSet
Set acSelSet = SelectOnlyOnScreen
MsgBox "Найдено блоков: " & CStr(acSelSet.Count) & " шт."
End Sub
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'Загрузка макроса из файла
'Этот пример из Helpa AutoCAD VBA
Sub LoadMacro()
Dim FileName As String
'Путь к файлу
FileName = "c:\program files\AutoCAD 2002\sample\vba\drawline.dvb"
'Загрузка макроса
LoadDVB FileName
'Включение макроса
RunMacro "Module1.Drawline"
'Выгрузка макроса
UnloadDVB FileName
End Sub
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'Построение прямоугольника(ромба,
'параллелограмма) с указанием 3-х точек
Sub Rhombus()
Dim PLineObj As AcadLWPolyline
Dim lineObj As AcadLine
Dim D(1) As Double
Dim P(7) As Double
A = ThisDrawing.Utility.GetPoint(, "Укажите 1-ю точку:")
B = ThisDrawing.Utility.GetPoint(A, "Укажите 2-ю точку:")
Set lineObj = ThisDrawing.ModelSpace.AddLine(A, B)
C = ThisDrawing.Utility.GetPoint(B, "Укажите 3-ю точку:")
D(0) = A(0) + C(0) - B(0)
D(1) = A(1) + C(1) - B(1)
P(0) = A(0)
P(1) = A(1)
P(2) = B(0)
P(3) = B(1)
P(4) = C(0)
P(5) = C(1)
P(6) = D(0)
P(7) = D(1)
lineObj.Delete
Set PLineObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(P)
PLineObj.Closed = True
End Sub
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'Определение площади объекта
Public Function SelectOnlyOnScreen() As AcadSelectionSet
Dim objSelSet As AcadSelectionSet
Dim objSelCol As AcadSelectionSets
Set objSelCol = ThisDrawing.SelectionSets
For Each objSelSet In objSelCol
If objSelSet.Name = "Only" Then
objSelSet.Delete
Exit For
End If
Next
Set objSelSet = ThisDrawing.SelectionSets.Add("Only")
objSelSet.SelectOnScreen
Set SelectOnlyOnScreen = objSelSet
End Function
Sub AreaTest()
Dim acSelSet As AcadSelectionSet
Dim a As Double
Set acSelSet = SelectOnlyOnScreen
a = 0
For Each element In acSelSet
a = a + element.Area
Next element
MsgBox "Площадь объекта: " & Str(a) + " кв.мм "
acSelSet.Delete
End Sub
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'Отправка имени любой команды Акада
'в командную строку и ее выполнение
Sub SendCommand()
'Рисуем окружность:
'(команда-Enter-точка центра-Enter-радиус-Enter)
ThisDrawing.SendCommand "_Circle" & vbCr & "2,2,0" & vbCr & "4" & vbCr
'Рисуем линию:
ThisDrawing.SendCommand "_Line" & vbCr & "2,2,0" & vbCr & "4,4,0" & vbCr & vbCr
'Регенерация
ThisDrawing.Regen acAllViewports
End Sub

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

'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'Маркировка центра окружностей
'Этот пример интересен тем, что с увеличением
'Радиуса окружности масштабируется и тип
'Линии перекрестия
Sub CircleMark()
Dim OBJ As AcadObject
Dim X(0 To 2) As Double
Dim Y(0 To 2) As Double
Dim lineObj As AcadLine
Dim Objset As AcadSelectionSet
Dim entry As AcadLineType
Dim TipCen As Boolean
'Проверка, если в чертеже тип линии "Center"
'Если нет-загружаем
TipCen = False
For Each entry In ThisDrawing.Linetypes
If StrComp(entry.Name, "Center", 1) = 0 Then
TipCen = True
Exit For
End If
Next
If TipCen = False Then ThisDrawing.Linetypes.Load "Center", "acad.lin"
Begin:
Set Objset = ThisDrawing.SelectionSets.Add(Timer)
Objset.SelectOnScreen
A = Abs(50) 'Задаем масштаб типа линии
B = Abs(120)
CircLength = Abs(B / 100)
For Each OBJ In Objset
If LCase(OBJ.EntityName) = "acdbcircle" Then
C = OBJ.Center
R = OBJ.Radius
A = (R / 2) 'Здесь можно задать соотношение
'Радиус/масштаб типа линии(кому не нравиться)
X(0) = C(0) - R * CircLength
Y(0) = C(0) + R * CircLength
X(1) = C(1)
Y(1) = C(1)
Set lineObj = ThisDrawing.ModelSpace.AddLine(X, Y)
lineObj.Linetype = "Center"
lineObj.LinetypeScale = A
X(1) = C(1) - R * CircLength
Y(1) = C(1) + R * CircLength
X(0) = C(0)
Y(0) = C(0)
Set lineObj = ThisDrawing.ModelSpace.AddLine(X, Y)
lineObj.Linetype = "Center"
lineObj.LinetypeScale = A
'До тех пор пока не выбрана окружность
'Выскакивает это сообщение:
Else: MsgBox "Укажите окружность!"
On Error Resume Next
If Error Then GoTo Begin 'Если ошибка начинаем с начала
End If
Next
Objset.Delete
End Sub

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

'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'Определение координаты точки
Public Sub CoorPoint()
Dim XPnt As Variant
XPnt = ThisDrawing.Utility.GetPoint(, "Укажите точку: ")
MsgBox "Координата точки: " & XPnt(0) & _
", " & XPnt(1) & ", " & XPnt(2), , ""
End Sub
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'Вставка блока с атрибутом
'Пример вставки в чертеж высотной отметки
Sub InsertBlockAtr()
Dim attributeObj As AcadAttribute
Dim height As Double
Dim mode As Long
Dim tag As String
Dim value As String
Dim prompt As String
Dim insPoint(0 To 2) As Double
'Создание блока
Dim blockObj As AcadBlock
Dim insertionPnt(0 To 2) As Double
insertionPnt(0) = 55#: insertionPnt(1) = -11.5: insertionPnt(2) = 0#
Set blockObj = ThisDrawing.Blocks.Add(insertionPnt, "Otmetka")
'Создание Атрибута в блоке
height = 7.5
mode = acAttributeModeVerify
prompt = "Отметка"
insPoint(0) = -50#: insPoint(1) = 17#: insPoint(2) = 0
tag = "0.000"
value = "0.000"
Set attributeObj = blockObj.AddAttribute(height, mode, prompt, insPoint, tag, value)
'Создание Полилинии в блоке
Dim plineObj As AcadLWPolyline
Dim points(0 To 13) As Double
points(0) = 4: points(1) = -5.5
points(2) = 0.5: points(3) = -5.5
points(4) = 4: points(5) = -11.5
points(6) = 7.5: points(7) = -5.5
points(8) = 4: points(9) = -5.5
points(10) = 4: points(11) = 3.5
points(12) = 40: points(13) = 3.5
Set plineObj = blockObj.AddLightWeightPolyline(points)
'Создание линии в блоке
Dim lineObj As AcadLine
Dim startPoint(0 To 2) As Double
Dim endPoint(0 To 2) As Double
startPoint(0) = 0.5: startPoint(1) = -11.5: startPoint(2) = 0#
endPoint(0) = 55#: endPoint(1) = -11.5: endPoint(2) = 0#
Set lineObj = blockObj.AddLine(startPoint, endPoint)
'Вставка блока в чертеж
Dim blockRefObj As AcadBlockReference
Dim InsertPnt As Variant
InsertPnt = ThisDrawing.Utility.GetPoint _
(, vbCrLf & "Укажите точку вставки:")
Set blockRefObj = ThisDrawing.ModelSpace.InsertBlock _
(InsertPnt, "Otmetka", 1#, 1#, 1#, 0)
attributeObj.Delete
End Sub
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'Создание нового документа Excel
'Здесь радует, что не нужно добавлять
'В VBA/Tools/References... ссылку
'На Excel Object type Library.
Private Sub NewExcel()
Dim Excel As Object
On Error Resume Next
'Вызов приложения
Set Excel = GetObject(, "Excel.Application")
If Err <> 0 Then
Err.Clear
Set Excel = CreateObject("Excel.Application")
If Err <> 0 Then
MsgBox "Нельзя загрузить Excel.", vbExclamation
End
End If
End If
On Error GoTo 0
Excel.Visible = True
Excel.Workbooks.Add
'Создаем новый лист и присваиваем
'Имя "VBA AutoCAD"
Set ExW = Excel.Worksheets.Add
ExW.Name = "VBA AutoCAD"
'Добавляем в ячейку "А2" "Visual Basic for Applications"
Excel.ActiveWorkbook.Sheets.Application. _
Range("A2") = "Visual Basic for Applications"
'Сохраняем документ Excel как "NewExcel" на диске С:
Excel.ActiveWorkbook.SaveAs "C:/NewExcel"
'Закрываем приложение
Excel.Quit
Set Excel = Nothing
MsgBox "Файл " & "NewExcel" & " создан", vbInformation, Tit
End Sub
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

--- 1 ---

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