|
Программа для привязки растраСтр 1 из 52Следующая ⇒ В 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
Конфликты в семейной жизни. Как это изменить? Редкий брак и взаимоотношения существуют без конфликтов и напряженности. Через это проходят все... Что вызывает тренды на фондовых и товарных рынках Объяснение теории грузового поезда Первые 17 лет моих рыночных исследований сводились к попыткам вычислить, когда этот... ЧТО И КАК ПИСАЛИ О МОДЕ В ЖУРНАЛАХ НАЧАЛА XX ВЕКА Первый номер журнала «Аполлон» за 1909 г. начинался, по сути, с программного заявления редакции журнала... Что делать, если нет взаимности? А теперь спустимся с небес на землю. Приземлились? Продолжаем разговор... Не нашли то, что искали? Воспользуйтесь поиском гугл на сайте:
|