Перейти на метку Stop2

GoTo Stop2

Метка

Stop1:

Сообщение, что не загружен AutoCAD и выход из процедуры

D=MsgBox("Не загружен AutoCAD. Нажми кнопку AutoCAD R14", vbExclamation, "Attention!")

Stop2:

End Sub

Процедура по нажатию кнопки «AutoCAD R14» запускает на выполнение программу AutoCAD

Private Sub CommandButton2_Click()

Dim RetVal

Dim CadFileName

Метка

Label1:

Задание в переменную пути к программе AutoCAD

CadFileName = "c:\Program Files\AutoCAD R14\acad.EXE"

On Error Resume Next ' Отложенный перехват ошибок.

Запуск программы AutoCAD в режиме кнопки на панели задач без передачи фокуса

RetVal = Shell(CadFileName, 6)

Анализ ситуации, если запуск программы AutoCAD не произошел

If Err.Number = 53 Then

Err.Clear

Сообщение с приглашением ввести правильный путь к программе

CadFileName = InputBox("Неверный путь к программе AutoCAD R14. Введите верный путь", "Открытие AutoCAD R14", CadFileName)

Повторная проба запуска программы AutoCAD

RetVal = Shell(CadFileName, 6)

В случае ошибки возврат на метку Label1

If Err.Number = 53 Then GoTo Label1

End If

End Sub

Процедура по нажатию кнопки «Формат» вычерчивает форматную рамку, штамп и надписи на поле рамки и штампа

Private Sub CommandButton3_Click()

Вызов процедуры с передачей в нее значения номера формата

Call Format(TextFormat)

End Sub

Процедура по нажатию кнопки «Выход» скрывает форму Menu

Private Sub CommandButton4_Click()

Menu.Hide

End Sub

Процедура при выходе из поля «Спецификация изделия» записывает в переменную TextH содержимое поля

Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)

TextH = TextBox1.Text

End Sub

Процедура при выходе из поля «Материал» записывает в переменную TextMaterial содержимое поля

Private Sub TextBox3_Exit(ByVal Cancel As MSForms.ReturnBoolean)

TextMaterial = TextBox3.Text

End Sub

Процедура при выходе из поля «Наименование изделия» записывает в переменную TextName содержимое поля

Private Sub TextBox2_Exit(ByVal Cancel As MSForms.ReturnBoolean)

TextName = TextBox2.Text

End Sub

Процедура при выходе из поля со списком «Масштаб» записывает в переменную TextMasshtab содержимое поля

Private Sub ComboBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)

TextMasshtab = ComboBox1.Text

End Sub

Процедура при выходе из поля «Разработал» записывает в переменную TextAutor содержимое поля

Private Sub TextBox4_Exit(ByVal Cancel As MSForms.ReturnBoolean)

TextAutor = TextBox4.Text

End Sub

Процедура при выходе из поля со списком «Формат» записывает в переменную TextFormat содержимое поля

Private Sub ComboBox2_Exit(ByVal Cancel As MSForms.ReturnBoolean)

TextFormat = ComboBox2.Text

End Sub

5-й этап – создание процедур, вычерчивающих линии рамки и штампа, надписи на поле рамки и штампа:

- в редакторе Visual Basic с помощью команды «ВставкаМодуль» создаем новый модуль VBA-проекта, а затем командой «ВставкаПроцедура» создаем процедуры:

Описание общих для проекта переменных

Public ACad As Object

Public ADoc As Object

Public MSpace As Object

Public TStyle As Object

Public F As Integer

Public L As Single

Public H As Single

Описание общих для проекта констант

Public Const L0 As Single = 841#

Public Const H0 As Single = 594#

Public Const Color As Integer = 4

Процедура вычерчивания линий и текста (получает в переменной TextFormat номер формата

Public Sub Format(TextFormat)

Dim A As Variant

On Error Resume Next ' Отложенный перехват ошибок.

Set ACad = GetObject(, "AutoCAD.Application")

If Err.Number = 429 Then GoTo Stop1

Set ADoc = ACad.ActiveDocument

Set MSpace = ADoc.ModelSpace

F = Val(TextFormat)

If F = 1 Or F = 2 Or F = 3 Or F = 4 Then

If F = 1 Or F = 4 Then L = L0 / F

If F = 3 Then L = L0 / 2

If F = 2 Then L = H0

If F = 1 Then H = H0

If F = 2 Then H = L0 / 2

If F = 3 Or F = 4 Then H = H0 / 2

Else

Выход из программы, если неверно задан формат (возврат в форму Menu с возможностью задать формат верно и повторить попытку построения)

D=MsgBox("Неверно задан формат листа", vbExclamation, "Attention!")

Exit Sub

End If

Вызов процедуры вычерчивания линий рамки (передает в процедуру размеры высоты и ширины формата)

Call Ramka(L, H)

Вызов процедуры вычерчивания линий штампа (передает в процедуру размеры высоты и ширины формата)

Call Shtamp(L, H)

Вызов процедуры вычерчивания текста (передает в процедуру размеры высоты и ширины формата, номера формата)

Call Text(L, H, F)

GoTo Stop2

Переход на метку, если не загружен AutoCAD и выход из программы (возврат в меню с возможностью запустить AutoCAD и повторить попытку построения)

Stop1:

D = MsgBox("Не загружен AutoCAD. Нажми кнопку AutoCAD R14", vbExclamation, "Attention!")

Stop2:

End Sub

Процедура вычерчивания линий рамки (получает размеры высоты и ширины формата)

Sub Ramka(L, H)

Dim Point1(0 To 2) As Double

Dim Point2(0 To 2) As Double

Dim aObj As Object

For i = 0 To 3 'Граница формата

Select Case i

Case 0

Point1(0) = 0: Point1(1) = 0: Point1(2) = 0

Point2(0) = L: Point2(1) = 0: Point2(2) = 0

Case 1

Point1(0) = L: Point1(1) = 0: Point1(2) = 0

Point2(0) = L: Point2(1) = H: Point2(2) = 0

Case 2

Point1(0) = L: Point1(1) = H: Point1(2) = 0

Point2(0) = 0: Point2(1) = H: Point2(2) = 0

Case 3

Point1(0) = 0: Point1(1) = H: Point1(2) = 0

Point2(0) = 0: Point2(1) = 0: Point2(2) = 0

End Select

With MSpace.AddLine(Point1, Point2)

.Color = Color

End With

Next i

For i = 0 To 3 'Рамка формата

Select Case i

Case 0

Point1(0) = 20: Point1(1) = 5: Point1(2) = 0

Point2(0) = L - 5: Point2(1) = 5: Point2(2) = 0

Case 1

Point1(0) = L - 5: Point1(1) = 5: Point1(2) = 0

Point2(0) = L - 5: Point2(1) = H - 5: Point2(2) = 0

Case 2

Point1(0) = L - 5: Point1(1) = H - 5: Point1(2) = 0

Point2(0) = 20: Point2(1) = H - 5: Point2(2) = 0

Case 3

Point1(0) = 20: Point1(1) = H - 5: Point1(2) = 0

Point2(0) = 20: Point2(1) = 5: Point2(2) = 0

End Select

With MSpace.AddLine(Point1, Point2)

.Color = Color

End With

Next i

For i = 0 To 1 'Рамка малая

Select Case i

Case 0

Point1(0) = 20: Point1(1) = H - 19: Point1(2) = 0

Point2(0) = 90: Point2(1) = H - 19: Point2(2) = 0

Case 1

Point1(0) = 90: Point1(1) = H - 19: Point1(2) = 0

Point2(0) = 90: Point2(1) = H - 5: Point2(2) = 0

End Select

With MSpace.AddLine(Point1, Point2)

.Color = Color

End With

Next i