Сдам Сам

ПОЛЕЗНОЕ


КАТЕГОРИИ







Программа для привязки растра





В AutoCAD нет встроенной программы для привязки растра. Необходимо либо приобретать программы – дополнение к AutoCAD, либо попытаться создать такую программу самостоятельно.

 

Пример 1.

1: Option Explicit

2: Const MinArray As Byte = 2

3: Option Base 1

4: Declare Function GetOpenFileName Lib “comdlg32.dll”_

5: Alias “GetOpenFileNameA” (pOpenfilename As OPENFILENAME) As Long

6: Type OPENFILENAME

7: IStructSize As Long

8: hwndOwner As Long

9: hInstance As Long

10: IpstrFilter As String

11: IpstrCustomFilter As String

12: nMaxCustFilter As Long

13: nFilterIndex As Long

14: IpstrFile As String

15: nMaxFile As Long

16: IpstrFileTitle As String

17: nMaxFileTitle As Long

18: IpstrIntialDir As String

19: IpstrTitle As String

20: flags As Long

21: nFileOffset As Integer

22: nFileExtension As Integer

23: IpstrDefExt As String

24: ICustData As Long

25: IpfnHook As Long

26: IpTemplateName As String

27: End Type

28: Function ShowOpen() As String

29: Dim strTemp As String

30: Dim VertName As OPENFILENAME

31: VertName.IStructSize = Len(VertName)

32: VertName.IpstrFilter = “Text Files (*.txt)” + Chr$(0)+_

33: “*.txt” + Chr$(0) + “Excel Files(*.xls)” + _

34: Chr$(0) + “*.xls + Chr$(0)

35: VertName.IpstrFile = Space$(254)

36: VertName.nMaxFile = 255

37: VertName.IpstrFileTitle = Space$(254)

38: VertName.nMaxFileTitle = 255

39: VertName.IpstrInitialDir = CurDir

40: VertName.IpstrTitle = «Файл результатов»

41: VertName.flags = 0

42: If GetOpenFileName(VertName) Then

43: strTemp = (Trim(VertName.IpstrFile))

44: ShowOpen = Mid(strTemp, 1, Len(strTemp) – 1)

45: End If

46: End Function

47: Sub Rastr()

48: Dim intFile As Integer

49: Dim strFileName As String

50: Dim NumArray_x() As Double ‘массив значений х растра

51: Dim NumArray_y() As Double ‘массив значений y растра

52: Dim NumArrayX() As Double ‘массив значений X плана

53: Dim NumArrayY() As Double ‘массив значений Y плана

54: Dim Array_Size As Long ‘размер массива

55: Dim X, Y, P, Z As Variant

56: Dim F, N, J, m, S As Integer

57: Z = ThisDrawing.Utility.GetPoint(, vbCrLf & «Укажите левый_

58: нижний угол растра:»)

59: Y= ThisDrawing.Utility.GetDistance(, vbCrLf & «Укажите текущий_

60: масштаб растра:»)

61:S= ThisDrawing.Utility.GetDistance(, vbCrLf & «Введите число_62: точек для привязки растра:»)

63: Array_Size = S

64: If Array_Size < MinArray Then

65: MsgBox «Введите больше точек:»

66: Exit Sub

67: Else

68: ReDim NumArray_x(Array_Size) ‘ объявление динамических массивов



69: ReDim NumArray_y(Array_Size)

70: ReDim NumArrayX(Array_Size)

71: ReDim NumArrayY(Array_Size)

72: End If

73: For N = 1 To Array_Size

74: X = ThisDrawing.Utility.GetPoint(, vbCrLf & «Укажите точку(“_

75: & N & “)на растре:»)

76: NumArray_x(N) = (X(1) – Z(1)) / Y

77: NumArray_y(N) = (X(0) – Z(0)) / Y

78: Next N

79: For N = 1 To Array_Size

80: X = ThisDrawing.Utility.GetPoint(, vbCrLf & «Укажите точку(“_

81: & N & “)на плане:»)

82: NumArrayX(N) = X(1)

83: NumArrayY(N) = X(0)

84: Next N

85: Dim Count As Long

86: Dim mm As Double

87: Dim d_x, d_y, DX, DY As Double

88: Dim m1, a1, a2, a3, a, C1, C2, C3, C4, Cx, Cy As Double

89: mm = 0 ‘переменная для суммирования масштабов

90: a = 0 ‘переменная для суммирования углов

91: Cx = 0 ‘2 переменные для суммирования свободных членов

92: Cy = 0

93: Count = 0

94: For N = 1 To Array_Size – 1

95: For J = N + 1 To Array_size

96 Count = Count + 1 ‘вычисляем приращения координат на растре и на плане

97: d_x = Round(NumArray_x(N) – NumArray_x(J), 3)

98: d_y = Round(NumArray_y(N) – NumArray_y(J), 3)

99: DX = Round(NumArrayX(N) – NumArrayX(J), 3)

100: DY = Round(NumArrayY(N) – NumArrayY(J), 3) ‘вычисляем масштабный фактор

101: m1 = Round((Sqr(DX ^ 2 + DY ^ 2)) / (Sqr(d_x ^ 2 + d_y ^ 2)), 3) ‘вычисляем угол между двумя точками на плане и растре

102: a1 = Round(Atn(d_y / d_x), 6)

103: a2 = Round(Atn(DY / DX), 6) ‘разность углов на плане и растре

104: a3 = a2 – a1 ‘свободные члены

105: C1 = Round(NumArrayX(N) – m1 * (NumArray_x(N) * Cos(a3) +_

106: NumArray_y(N) * Sin(a3)), 3)

107: C1 = Round(NumArrayY(N) – m1 * (NumArray_y(N) * Cos(a3) -_

108: NumArray_x(N) * Sin(a3)), 3)

109: C1 = Round(NumArrayX(J) – m1 * (NumArray_x(J) * Cos(a3) +_

110: NumArray_y(J) * Sin(a3)), 3)

111: C1 = Round(NumArrayY(J) – m1 * (NumArray_y(J) * Cos(a3) +_

112: NumArray_x(J) * Sin(a3)), 3) ‘суммируем масштабный фактор

113: mm = mm + m1 ‘суммируем разности углов

114: a = a + a3 ‘суммируем свободные члены

115: Cx = Cx + C1 + C3

116: Cy = Cy + C2 + C4

117: Next J

118: Next N ‘Начинаем записывать результаты в файл

119: F = FreeFile

120: strFileName = ShowOpen

121: If Not Right(strFileName, 4) = “.txt” Then

122: strFileName = strFileName & “.txt”

123: End If

124: Open strFileName For Append As F

125: Print #F, «Осредненные значения:»

126: Print #F, «Масштаб:», Round(((mm / Count)), 3)

127: Print #F, «Угол поворота:», Round((a / Count), 3)

128: Print #F, «Свободный членX0:», Round((Cx / Count * 2)), 3)

129: Print #F, «Свободный членY0:», Round((Cy / Count * 2)), 3)

130: Print #F, «Ошибки в положении пунктов при пересчета:»

131: For N = 1 To Array_Size

132: Print #F, “Mx(“& N &”):”, Round(((Cx / Count * 2))) +_

133: (mm / Count) * (NumArray_x(N) * Cos(a / Count) + NumArray_y(N) *_

134: Sin(a / Count)) – NumArrayX(N), 3)

135: Print #F, “My(“& N &”):”, Round(((Cy / Count * 2))) +_

136: (mm / Count) * (NumArray_y(N) * Cos(a / Count) + NumArray_x(N) *_

137: Sin(a / Count)) – NumArrayY(N), 3)

138: Next N

139: Print #F, «Указанные точки на плане:»

140: For N = 1 To Array_Size

141: Print #F, “X(“ & N & “):”, Round(NumArrayX(N), 3)

142: Print #F, “Y(“ & N & “):”, Round(NumArrayY(N), 3)

143: Next N

144: Print #F, «Указанные точки на растре:»

145: For N = 1 To Array_Size

146: Print #F, “x(“ & N & “):”, Round(NumArray_x(N), 3)

147: Print #F, “y(“ & N & “):”, Round(NumArray_y(N), 3)

148: Next N

149: Close F

150: End Sub

 

В строке 1 директива Option Explicit запрещает неявное объявление переменных. То есть все переменные должны быть описаны.

В строке 2 определена константа MinArray = 2, которая затем будет использована для задания минимального размера массива.

В строке 3 директива Option Base 1 указывает на то, что индексы массивов должны начинаться с единицы.

В строках 4 – 5 вызывается функция, которая открывает диалоговое окно Open File. В AutoCAD такое окно не встроено. Однако с самой Windows поставляется с определенным количеством файлов DLL, которые обеспечивают разработчиков сотнями специализированных и очень надежных функций. Перед тем как использовать ту или иную функцию Windows нужно сообщить VBA, где ее искать. Для этого необходимо ввести инструкцию Declare на уровне модуля. Общий синтаксис таков:

Declare Function Name Lib “Libname” [AliasName] (Arguments) [AsType]

Declare Sub Name Lib ““Libname” [AliasName] (Arguments) [AsType]

Где Name – это имя процедуры, а LibName – имя DLL файла. Arguments – представляет собой список необходимых аргументов. Всего данной функции требуется 19 аргументов. Их не все требуется определять, но обязательно нужно передать в функцию. Для передачи такого большого количества переменных удобно использовать типы данных определенные пользователем (строки 6 – 27).Ниже приводится краткая характеристика данных.

Attribute VB_Name = "GetOpenFileName"

Option Explicit ' запрет на неявное объявление переменных

Declare Function GetOpenFileName Lib "comdlg32.dll" _

Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long ' объявление функции Windows

Type OPENFILENAME ' объявляем пользовательский тип дананных

lngStructSize As Long 'Размер структуры

hwndOwner As Long 'Дескриптор окна владельца

hInstance As Long 'Дескриптор приложения

strFilter As String 'Строка фильтра

strCustomFilter As String 'Строка с выбранным фильтром

intMaxCustFilter As Long 'Длина буфера для строки выбранного фильтра

'Всегда должна быть равна Len(strCustomFilter)

intFilterIndex As Long 'Индекс строки фильтра

strFile As String 'Полное имя выбранного файла (путь и файл)

intMaxFile As Long 'Длина буфера для полного имени файла

'Всегда должна быть равна Len(strFile)

strFileTitle As String 'Имя выбранного файла

intMaxFileTitle As Long 'Длина буфера для имени выбранного файла

'Всегда должна быть равна Len(strFileTitle)

strInitialDir As String 'Имя начального каталога (при открытии окна)

strTitle As String 'Заголовок диалогового окна

lngFlags As Long 'Флаги диалогового окна

intFileOffset As Integer 'Смещение имени файла

intFileException As Integer 'Смещение расширения файла

strDefExt As String 'Расширение файла по умолчанию

lngCustData As Long 'Данные для обработки

lngfnHook As Long 'Указатель функции обработки

strTemplateName As String 'Имя шаблона диалогового окна

End Type

В строках 28 – 46 определена функция ShowOpen, в которой определены некоторые начальные значения диалогового окна Open File, а также эта функция отображает это самое диалоговое окно. Комментарий к функции приводится ниже.

Function ShowOpen() As String ' функция для открытия диалогового окна OpenFile

Dim strTemp As String

Dim VertName As OPENFILENAME

With VertName

.lngStructSize = Len(VertName) 'Передаем размер созданной структуры

.strFilter = "Text Files (*.txt)" + Chr$(0) + _

"*.txt" + Chr$(0) + "Excel Files(*.xls)" + _

Chr$(0) + "*.xls" + Chr$(0) ' задаем типы расширений для выбираемых файлов

'.strCustomFilter = Space$(254) ' задаем строку фильтра. Максимальное количество символов

'254. Оператор space$ - резервирует строку 254 символа

.intMaxCustFilter = 254 ' задаем максимальное значение символов в строке фильтра

.intMaxFile = 255 'задаем масимальное количество символов в строке с полным именем

'выбираемого файла

.intMaxFileTitle = 254 ' длина буфера для имени файла

.strFile = Space$(254) ' резервируем строку для имени файла

.strInitialDir = "C:\Program Files" ' каталог по умолчанию

.strTitle = "Выбор файла" 'заголовок диалогового окна

.lngFlags = 0 ' 1 - тотько для чтения

End With

 

If GetOpenFileName(VertName) Then

strTemp = (Trim(VertName.strFile))

ShowOpen = strTemp

End If

 

'В строке strTemp присваиваем содержимое строки VertName.strFile без всяких пробелов

'до и после имени файла. Для этого вызываем встроенную в Visual Basic функцию Trim.

'После этого функции присваиваем значение strTemp

End Function

Sub DialogBox()

Dim strFileName As String

strFileName = ShowOpen 'вызываем на исполнение функцию ShowOpen

If Not Right(strFileName, 4) = ".txt" Then

strFileName = strFileName & ".txt"

End If

'Если в выбранном имени файла пользователь забыл ввести расширение то автоматически

'добавляем его

Shell PathName:="C:\Windows\notepad.exe " & strFileName

'функция Shell вызывает требуемое приложение и файл

 

End Sub

 

Сама функция Open File вызывается в строке 120 головной программы.

В строке 119 переменной F присваиваемый следующий свободный номер файла. В строке 124 открываем файл для добавления записей (Append).

Оператором Print# записываем информацию в файл.

Для построения диалогового окна работы с принтером предлагается следующая программа.

Attribute VB_Name = "Module3"

Public Const LBSELCHSTRING = "commdlg_LBSelChangedNotify"

Public Const SHAREVISTRING = "commdlg_ShareViolation"

Public Const FILEOKSTRING = "commdlg_FileNameOK"

Public Const COLOROKSTRING = "commdlg_ColorOK"

Public Const SETRGBSTRING = "commdlg_SetRGBColor"

Public Const HELPMSGSTRING = "commdlg_help"

Public Const FINDMSGSTRING = "commdlg_FindReplace"

 

Type PrintDlg

lStructSize As Long

hwndOwner As Long

hDevMode As Long

hDevNames As Long

hdc As Long

flags As Long

nFromPage As Integer

nToPage As Integer

nMinPage As Integer

nMaxPage As Integer

nCopies As Integer

hInstance As Long

lCustData As Long

lpfnPrintHook As Long

lpfnSetupHook As Long

lpPrintTemplateName As String

lpSetupTemplateName As String

hPrintTemplate As Long

hSetupTemplate As Long

End Type

Declare Function PrintDlg Lib "comdlg32.dll" Alias "PrintDlgA" (pPrintdlg As PrintDlg) As Long

 

Function ShowPrintDlg()

Dim sd As PrintDlg

Dim strTemp As Long

With sd

.lStructSize = Len(sd)

.nCopies = 6

.hdc = 10

.flags = 200

.nFromPage = 1

.nToPage = 2

.nMaxPage = 4

.nMinPage = 1

.hPrintTemplate = 3

.hSetupTemplate = 2

.hInstance = 2

.lpfnPrintHook = 11434324

.lpPrintTemplateName = COLOROKSTRING

.lpSetupTemplateName = LBSELCHSTRING

.lCustData = 12333

End With

 

strTemp = PrintDlg(sd)

End Function

 

Sub print_a()

Dim d As Long

d = ShowPrintDlg

End Sub

Ее предлагается изучить самостоятельно.

Вычерчивание точек

Ниже представлена простейшая программа для вставки точки в чертеж. Пользователь щелчком мыши указывает место на чертеже, где должна быть точка.

Пример 2.

Sub point1()

Dim pointM As ACAD_POINT

Dim Coord(2) As Double

Do

On Error GoTo Err

X = ThisDrawing.Utility.GetPoint(, «Укажите точку:»)

Set pointM = ThisDrawing.ModelSpace.AddPoint(X)

Loop

Err:

MsgBox «Ввод данных прерван!»

End Sub

Данный цикл продолжается бесконечно, пока пользователь не нажмет клавишу Enter, Esc ли недопустимое значение (строку). В этом случае генерируется ошибка ввода данных и цикл прекращается.

В AutoCAD ось X располагается горизонтально, а ось Y вертикально, что создает некоторые неудобства при вводе данных. Следующая программа исправляет этот недостаток. Правда вводить данные можно только с клавиатуры.

Пример 3.

Sub point2()

Dim pointM As ACAD_POINT

Dim Coord(2) As Double

Do

On Error GoTo Err

X = ThisDrawing.Utility.GetDistanse(, «Введите координату X:»)

Y = ThisDrawing.Utility.GetDistanse(, «Введите координату Y:»)

Coord(0) = Y ‘координата X

Coord(1) = X ‘координата Y

Coord(2) = 0 ‘координата Z

Set pointM = ThisDrawing.ModelSpace.AddPoint(Coord)

Loop

Err:

MsgBox «Ввод данных прерван!»

End Sub

 

Данная программа просто меняет местами данные в массиве.

 

Помимо простой точки можно вставлять и целые блоки. Например, необходимо нанести на чертеж точки теодолитного хода. Условный знак для них следующий:

 

Для этого открываем новый чертеж. Рисуем этот

условный знак. Знак должен быть небольшого размера

(диаметр круга в данном случае 10 см). Далее

в командной строке набираем wblock, нажимаем

Enter.

Появится диалоговое окно Write Block

(записать блок). Щелчком мыши нажимаем на кнопке

Select Object (Выбрать объекты) и

выбираем те объекты, которые необходимы для

составления блока. Нажимаем на кнопку Pick Point

и указываем на чертеже базовую точку вставки.

Обычно это центр знака. Если для составления блока нужны абсолютно все элементы, то можно поставить опцию Entire Drawing. В поле File Name and pach укажем имя блока и папку где они будут хранится. Нажимаем ОК.

Вот текст макроса, рисующего данный блок.

 

Пример 4.

Sub point3()

Dim pointM As ACAD_POINT

Dim blk As AcadBlock

Dim Coord(2) As Double

Do

On Error GoTo Err

X = ThisDrawing.Utility.GetDistanse(, «Введите координату X:»)

Y = ThisDrawing.Utility.GetDistanse(, «Введите координату Y:»)

Coord(0) = Y

Coord(1) = X

Coord(2) = 0

InsertPoint = Coord

strBlkName = “E:\Uznak\TP.dwg”

XScale = 1’масштаб по оси X

YScale = 1’масштаб по оси Y

ZScale = 1’масштаб по оси Z

Angle = 0 ‘угол поворота блока

Set pointM = ThisDrawing.ModelSpace.AddPoint(Coord)

ThisDrawing.ModelSpace.InsertBlock InsertPoint, strBlkName, XScale,YScale,ZScale, Angle

Loop

Err:

MsgBox «Ввод данных прерван!»

End Sub

 

Можно определить любое количество блоков, сохранить их в данном каталоге. Таким образом можно создавать свои библиотеки условных знаков.

 

Вычерчивание линий

Ниже представлена простейшая программа для вычерчивания линии.

 

Пример 5.

Sub Line1()

Dim Lin As AcadLine

Dim Coord As Variant

Dim Coord2 As Variant

Coord = ThisDrawing.Utility.GetPoint(, «Введите первую точку:»)

Coord2 = ThisDrawing.Utility.GetPoint(, «Введите вторую точку:»)

Set Lin = ThisDrawing.ModeSpace.AddLine(Coord,Coord2)

ThisDrawing.Application.Update

End Sub

 

Чтобы вычертить ломаную линию необходимо несколько видоизменить код программы.

 

Пример 6.

 

Sub Line2()

Dim Lin As AcadLine

Dim Coord As Variant

Dim Coord2 As Variant

Dim count As Integer

Count = 0

Do

On Error GoTo Line

If count = 0 Then

Coord = ThisDrawing.Utility.GetPoint(, «Введите первую точку:»)

Coord2 = ThisDrawing.Utility.GetPoint(, «Введите вторую точку:»)

Set Lin = ThisDrawing.ModeSpace.AddLine(Coord,Coord2)

Count = count + 1

Else

Coord = coord2

Coord2 = ThisDrawing.Utility.GetPoint(, «Введите следующую точку:»)

Set Lin = ThisDrawing.ModeSpace.AddLine(Coord,Coord2)

ThisDrawing.Application.Update

End If

Loop

Line:

End Sub

 

Вот пример кода, рисующего мультилинию, то есть двойную линию.

Пример 7.

Sub Line3()

Dim Lin As AcadMLine

Dim Coord As Variant

Dim Coord2 As Variant

Dim count As Integer

Dim vertList(0 To 5) As Double

Count = 0

Do

On Error GoTo Line

If count = 0 Then

Coord = ThisDrawing.Utility.GetPoint(, «Введите первую точку:»)

Coord2 = ThisDrawing.Utility.GetPoint(, «Введите вторую точку:»)

vertList(0) = Coord(0)

vertList(1) = Coord(1)

vertList(2) = Coord(2)

vertList(3) = Coord2(0)

vertList(4) = Coord2(1)

vertList(5) = Coord2(2)

Set Lin = ThisDrawing.ModeSpace.AddMLine(vertList)

Count = count + 1

Else

Coord = coord2

vertList(0) = Coord(0)

vertList(1) = Coord(1)

vertList(2) = Coord(2)

Coord2 = ThisDrawing.Utility.GetPoint(, «Введите следующую точку:»)

vertList(3) = Coord2(0)

vertList(4) = Coord2(1)

vertList(5) = Coord2(2)

Set Lin = ThisDrawing.ModeSpace.AddMLine(vertList)

ThisDrawing.Application.Update

End If

Loop

Line:

End Sub

 

Вычерчивание дуги

Вот пример программы, рисующей дугу.

 

Пример 8.

 

Option Explicit

 

Sub TheePointArc()

Dim pt1 As Variant, pt2 As Variant, pt3 As Variant

Dim arcobj As AcadArc

On Error GoTo ErrTrap:

Pt1 = ThisDrawing.Utility.GetPoint(, «Начало кривой:»)

pt2 = ThisDrawing.Utility.GetPoint(, «Конец кривой:»)

pt3 = ThisDrawing.Utility.GetPoint(, «Середина кривой:»)

On Error GoTo 0

Set arcobj = TheePointArc(pt1, pt2, pt3)

ErrTrap:

End Sub

 

Function TheePointArc(startpt As Variant), Endpt As_

Variant, Bulgept (As Variant) As AcadArc

On Error GoTo ErrTrap:

Dim util As AcadUtility

Set util = ThisDrawing.Utility

 

Dim xa, xb, xc, ya, yb, yc

xa = endpt(0): ya = endpt(1)

xb = bulgept(0): yb = bulgept(1)

xc = startpt(0): yc = startpt(1)

 

Dim A As Double, B As Double, C As Double, D As Double

Dim E As Double, F As Double, G As Double, H As Double

Dim I As Double, J As Double, X As Double, Y As Double

 

A = (yc – ya) / 2

B = (xc – xb) / (yc – yb)

C = (xb + xc) / 2

D = (xb – xa) / (ya – yb)

E = (xa + xb) / 2

F = (xb – xa) / (ya – yb)

G = (xc – xb) / (yc – yb)

H = (ya +yb) / 2

I = A + B * C + D * E

J = F + G

X = I / J

Y = x * D + H – F * E

 

Dim center(0 To 2) As Double

Center(0) = x: center(1) = y: center(2) = 0

 

Dim starangle As Double, endangle As Double, radius As Double

Radius = Sqr((center(0) – startpt(0)) ^ 2 + (center(1) – starrpt(1)) ^ 2)

Startangle = util.AnfleFromXAxis(center, startpt)

Endangle = util.AngleFromXAxis(center, startpt)

 

Set TheePointArc = ThisDrawing.ModelSpaсe.AddArc(center,_

Radius, startangle, endangle)

On Error GoTo 0

Exit Function

 

ErrTrap:

MsgBox «Ошибка! Операция завершена.»

End Function

 

Добавление текста

Для вставки текста в чертеж можно использовать следующую программу.

Пользователя просят ввести сам текст, точку вставки и угол разворота.

 

Пример 9.

Sub Text()

Dim objText As AcadText

Dim Text As String

Dim Angl As ACAD_ANGLE

Dim Coord As Variant

Do

On Error GoTo Line:

Text = ThisDrawing.Utility.GetString(True, «Введите однострочный текст:»)

Coord = ThisDrawing.Utility.GetPoint(, «Введите точку вставки:»)

Angl = ThisDrawing.Utility.GetAngle(, «Введите угол:»)

Set objText = ThisDrawing.ModelSpace.AddText(Text, Coord, 40)

`величина 40 это высота текста

objText.Rotate Coord, Ahgl

Loop

Line:

End Sub

 









Не нашли то, что искали? Воспользуйтесь поиском гугл на сайте:


©2015- 2019 zdamsam.ru Размещенные материалы защищены законодательством РФ.