Отправляет email-рассылки с помощью сервиса Sendsay

Создание САПР на базе продуктов Autodesk

Подписаться Бесплатная новостная рассылка Временно не выходит ,возобновит выход в начале сентября Подписчиков 175 RSS
←   Апрель 2004   →
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30


За последние 60 дней ни разу не выходила


Сайт рассылки: http://caddev.narod.ru
Открыта: 23-02-2004

Автор
С.С. Калугин

Статистика

175 подписчиков
0 за неделю
←   Все выпуски   →

Создание САПР на базе продуктов Autodesk


Информационный Канал Subscribe.Ru

Информационная рассылка сайта [CadDev.Narod.Ru]

(с) 2004, Калугин Сергей Сергеевич h1>Информационная рассылка сайта [CadDev.Narod.Ru] (с) 2004, Калугин Сергей Сергеевич

Вниманию студентов! На сайте размещены задания для выполнения Л.Р.4 и Л.Р.5

В сегодняшней рассылке рассмотрим создание команд AutoCAD с использованием VBA

Команды AutoCAD и VBA

Пример функции, выполняющей над заданным объектом любую команду 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

Команды 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

 

http://subscribe.ru/
E-mail: ask@subscribe.ru 		Отписаться
Убрать рекламу

В избранное