Основы программирования на Visual Basic for AutoCAD

[Добрушанка]

- возможно ли прописать процедуру измерения длины сплайна? ...

Предлагаю две функции для вычисления длины сплайна.
Первая работает не всегда (я уже не помню, при каких условиях она не срабатывала), она выдает точную длину сплайна.

Function GetCurveLength(oEnt As AcadEntity) As DoubleDim sVarsVar = 0Dim strCom As StringWith ThisDrawing.SetVariable "USERR1", sVar.SendCommand "(vl-load-com)" & vbCrstrCom = "(setvar " & Chr(34) & "USERR1" & Chr(34) & Chr(32) & "(vlax-curve-getdistatparam (vlax-ename->vla-object (handent " & Chr(34) & oEnt.Handle & Chr(34) & ")) (vlax-curve-getendparam (vlax-ename->vla-object (handent " & Chr(34) & oEnt.Handle & Chr(34) & ")))))" & vbCr.SendCommand strCom.Regen TrueGetCurveLength = .GetVariable("USERR1")End WithEnd Function

Вторая вычисляет длину сплайна приближенно, но работает без проблем.

Function GetCurveLength2(oEnt As AcadEntity) As DoubleDim sVarDim CP As VariantoEnt.ElevateOrder (26)oEnt.UpdateCP = oEnt.ControlPointsN = UBound(CP)sVar = 0For i = 3 To N Step 3sVar = sVar + Sqr((CP(i) - CP(i - 3)) ^ 2 + (CP(i + 1) - CP(i - 2)) ^ 2 + (CP(i + 2) - CP(i - 1)) ^ 2)Next iGetCurveLength2 = sVarEnd Function

Вызываются они соответственно так

L = GetCurveLength(SplineObj1)L = GetCurveLength2(SplineObj1)

Здесь SplineObj1 - это сплайн, длину которого нужно вычислить.

- как отмерить опять же на сплайне необходимую длину?(это я уже с контрольными мерками воевала...) а поделить его, к примеру, поплам?

Как вычислить координаты точки на сплайне, я пока не знаю. Меня тоже волнует этот вопрос.

[sune4ka]

Rochery? вот вам примерчик для подпрограммы... вообще на мой взгляд названия "основная программа и "подпрограмма" - чисто условные...
для примера я взяла построение юбки. на определенном этапе мне нужно было найти точки пересечения окружности с отрезком ( в данном случае отрезок - это моя линия талии, а окружность раствор вытачки)
если отрезок лежит параллельно оси координат то нет проблем, но вот если он по наклонной, тут нужен расчет, и на помощь приходят все те же теоремы треугольников:)
вот что у нас есть:

дочертим треугольники:

чтобы узнать координаты точки (х,у) нам нужно вычислить значение переменных "а" и "h", (потому что точка (х,у) отклоняется от точки (х0,у0) по оси абцисс на величину "а" и по оси ординат на величину "h")
рассмотрим треугольник (cdf) и треугольник (ahR).. что мы о них знаем?
-во-первых это прямоугольные треугольники
- во-вторых, они подобны
нам известна сторона R, и мы можем вычислить стороны "с", "d" и "f"
итак:
1. c = y0 - y1
d = x0 - x1
вспоминаем теорему пифагора в вычисляем
f = Sqr(c ^ 2 + d ^ 2)
2. из подобия треугольников следует что h/c=R/f (h относится к с так же как и R относится к f - отношение меньшего к большему)
отсюда

 

h = (R * c) / f
a = (R * d) / f

 

3. и последнее
x = x0 - a
y = y0 - h
аналогично вычисляются координаты второй точки пересечения:

 

x = x0 + a
y = y0 + h
и конечном счете все это будет иметь вот такой вид:

 

Sub Peres(x0, y0, R, x1, y1, x2, y2, x, y, flag As Double)
If R = 0 Then
x = x0: y = y0
Else
c = y0 - y1
d = x0 - x1
f = Sqr(c ^ 2 + d ^ 2)
h = (R * c) / f
a = (R * d) / f
If flag = 0 Then
x = x0 - a
y = y0 - h
Else
x = x0 + a
y = y0 + h
End If
End If

 

End Sub

Изменено 6 февраля, 2009 пользователем sune4ka

[sune4ka]

теперь по поводу самой "подпрограммки" что происходит при ее вызове..

 

в "основной2 программе ubka я вызываю ее:
Call Peres(Tzc(0), Tzc(1), RZZ, tbz(0), tbz(1), tz(0), tz(1), x, y, 0)
Tz1(0) = x: Tz1(1) = y: Tz1(2) = 0

 

подставляя под каждую переменную значение, координаты центра окружности- x0, y0, ее радиус - R - раствор моей вытачки, и координаты точек концов отрезка - линни талии - x1, y1, x2, y2, затем указываю x, y искомой точки пересечения, так же указываю какая именно из точек мне нужна с помощью "flag"-а, я могу указать 0 или 1

 

итак мы вызвали программу Peres, наши переменные подставляются в формулы и идет вычисление
вначале проверяется условие R = 0, если оно верно, то значит точек персечения нет и искмые координаты будут равны исходным
в обратном случае производятся вычисления, находятся стороны наших треугольничков, затем проверяется еще одно условие, если вы поставили значение флага - 0, координаты точки будут вычисляться по одной формуле, если вы поставили флаг - любое другое число отличное от нуля, то формула другая..

 

можно было бы ограничить значение флага описав в условии:
If (flag = 0) Then
x = x0 - a
y = y0 - h
ElseIF (flag = 1) Then
x = x0 + a
y = y0 + h
End If
End If

 

затем подпрограмма возвращает вам полученные значения...

 

подробнее про операторы If и ElseIF можете почитать на тех сайтах что я вам дала

[Rochery]

sune4ka, я даже не знаю как вас отблагодарить :*.
Большое вам спасибо за такое хорошое обьяснение. Все почти понятно, только застряла на том, что мне нужо вернуться обратно в школу :D . На днях поеду покупать учебник по геометрии, а то ничего не помню.

[sune4ka]

не нужно учебник, все есть в интернете:)) погуглите;)

[Цветы]

[sune4ka]

я недавно открыла для себя одну очень полезную функцию в редакторе VBA.. называется "debug" встаете в начало программы и жмете F8, ваша строчка выделится желтым, и каждый раз нажимая на F8 вы будете предвигаться поэтапно по всей вашей программе. если есть где-то ошибка, то он встанет в этом месте и сообщит об ошибке. Попробуйте - очень удобно:))

[Добрушанка]

Sune4ka, большое спасибо за то, что Вы находите время отвечать на вопросы.

В автокаде можно начертить дугу по двум точкам и радиусу, можно ли здесь это использовать?

Вот функция для построения дуги по двум точкам и радиусу.
По двум точкам и радиусу можно построить 4 различных варианта дуги, поэтому я ввела дополнительную переменную flag (0 или 1). Еще два варианта дуги получаются, если поменять местами первую и вторую точку.

Sub Test()x1 = 3: y1 = 5x2 = 8: y2 = 7R = 3Set arc1 = AddArcPPR(x1, y1, x2, y2, R, 0) ' на рисунке красного цветаSet arc1 = AddArcPPR(x1, y1, x2, y2, R, 1) ' синегоSet arc1 = AddArcPPR(x2, y2, x1, y1, R, 0) ' зеленогоSet arc1 = AddArcPPR(x2, y2, x1, y1, R, 1) ' желтогоZoomAllEnd SubFunction AddArcPPR(x1, y1, x2, y2, R, flag) As AcadArcD = (-(x1 - x2) ^ 2 * (x1 ^ 2 - 2 * x1 * x2 + x2 ^ 2 + (y1 - y2) ^ 2) * (-4 * R ^ 2 + x1 ^ 2 - 2 * x1 * x2 + x2 ^ 2 + y1 ^ 2 - 2 * y1 * y2 + y2 ^ 2))If D < 0 Then MsgBox "Error: No Arc" AddArcPPR = EmptyElseD = Sqr(D)If flag <> 0 Then If x1 <> x2 Then  xc = (x1 ^ 4 - 2 * x1 ^ 3 * x2 + 2 * x1 * x2 ^ 3 - x2 ^ 4 + x1 ^ 2 * y1 ^ 2 - x2 ^ 2 * y1 ^ 2 - 2 * x1 ^ 2 * y1 * y2 + 2 * x2 ^ 2 * y1 * y2 + x1 ^ 2 * y2 ^ 2 - x2 ^ 2 * y2 ^ 2 + y1 * D - y2 * D) / (2 * (x1 - x2) * (x1 ^ 2 - 2 * x1 * x2 + x2 ^ 2 + (y1 - y2) ^ 2))  yc = (x1 ^ 2 * y1 - 2 * x1 * x2 * y1 + x2 ^ 2 * y1 + y1 ^ 3 + x1 ^ 2 * y2 - 2 * x1 * x2 * y2 + x2 ^ 2 * y2 - y1 ^ 2 * y2 - y1 * y2 ^ 2 + y2 ^ 3 - D) / (2 * (x1 ^ 2 - 2 * x1 * x2 + x2 ^ 2 + (y1 - y2) ^ 2)) Else  xc = x1 + Sqr(4 * R ^ 2 - (y1 - y2) ^ 2) / 2  yc = (y1 + y2) / 2 End IfElse If x1 <> x2 Then  xc = (x1 ^ 4 - 2 * x1 ^ 3 * x2 + 2 * x1 * x2 ^ 3 - x2 ^ 4 + x1 ^ 2 * y1 ^ 2 - x2 ^ 2 * y1 ^ 2 - 2 * x1 ^ 2 * y1 * y2 + 2 * x2 ^ 2 * y1 * y2 + x1 ^ 2 * y2 ^ 2 - x2 ^ 2 * y2 ^ 2 - y1 * D + y2 * D) / (2 * (x1 - x2) * (x1 ^ 2 - 2 * x1 * x2 + x2 ^ 2 + (y1 - y2) ^ 2))  yc = (x1 ^ 2 * y1 - 2 * x1 * x2 * y1 + x2 ^ 2 * y1 + y1 ^ 3 + x1 ^ 2 * y2 - 2 * x1 * x2 * y2 + x2 ^ 2 * y2 - y1 ^ 2 * y2 - y1 * y2 ^ 2 + y2 ^ 3 + D) / (2 * (x1 ^ 2 - 2 * x1 * x2 + x2 ^ 2 + (y1 - y2) ^ 2)) Else  xc = x1 - Sqr(4 * R ^ 2 - (y1 - y2) ^ 2) / 2  yc = (y1 + y2) / 2 End IfEnd IfPi = 3.14159265358979If x1 = xc Then  If y1 > yc Then	Angle1 = Pi / 2  Else	Angle1 = -Pi / 2  End IfElse  Angle1 = Atn((y1 - yc) / (x1 - xc))  If x1 < xc Then Angle1 = Angle1 + PiEnd IfIf x2 = xc Then  If y2 > yc Then	Angle2 = Pi / 2  Else	Angle2 = -Pi / 2  End IfElse  Angle2 = Atn((y2 - yc) / (x2 - xc))  If x2 < xc Then Angle2 = Angle2 + PiEnd IfIf Angle1 > Angle2 Then Angle2 = Angle2 + 2 * PiDim centerPoint(0 To 2) As DoublecenterPoint(0) = xc: centerPoint(1) = yc: centerPoint(2) = 0Set AddArcPPR = ThisDrawing.ModelSpace.AddArc(centerPoint, R, Angle1, Angle2)End IfEnd Function

[Добрушанка]

я недавно открыла для себя одну очень полезную функцию в редакторе VBA.. называется "debug" встаете в начало программы и жмете F8, ваша строчка выделится желтым, и каждый раз нажимая на F8 вы будете предвигаться поэтапно по всей вашей программе. если есть где-то ошибка, то он встанет в этом месте и сообщит об ошибке.

А еще можно делать точки останова. Тогда программа, когда дойдет до этой точки, остановится. И дальше можно проверять пошагово (F8). Это нужно для того, чтобы пропустить большой кусок кода, в котором вы уверены. Чтобы поставить точку останова, нужно установить курсор на нужную строку и нажать F9 или щелкнуть мышкой на поле возле нужной строки. Точка останова будет выделена красным цветом.

[sune4ka]

Sune4ka, большое спасибо за то, что Вы находите время отвечать на вопросы.

 

в последнее время моим девизом стала фраза "с VBA я спать ложусь с VBA я просыпаюсь":))))))))
вот и щас сижу воюю со своей программой построения лифа, сделала форму, но где-то у меня не подхватываются переменные...кажется...ищу:)

[sune4ka]

вот что получилось:
Lif_s_rukavom2.zip
вроде все работает, до дуг пока не дошла, оставила как есть, изменила сплайн..
одно но.. при нажатии кнопки построить, мы вызываем подпрограмму сохранения мерок... но куда они сохраняются - не пойму...видимо это будет в последующих ваших уроках:))

[Добрушанка]

Классная у Вас программа. Очень хорошо оформлена форма.
По поводу сохранения: мерки у нас сохраняются на слое Data в том документе, где выполняется построение. На этом слое создается полилиния, в координатах которой сохраняются мерки.
Я у себя обнаружила ошибку в процедуре CreatePline(). Оттуда нужно удалить строку layerObj.Lock = True.

[Добрушанка]

Оставшаяся часть по форме.
В главном меню создается дополнительный пункт "Одежда". Чтобы запустить всю программу, нужно запустить макрос Init().

Sub Init()	Const MENUITEM As String = "Одежда"	Dim proverka As Boolean	Dim currMenuGroup As AcadMenuGroup	Set currMenuGroup = ThisDrawing.Application.MenuGroups.Item(0)	Dim newMenu As AcadPopupMenu	Dim menuCollection As AcadPopupMenus	Dim menu As AcadPopupMenu	Set menuCollection = ThisDrawing.Application.MenuGroups.Item(0).Menus	proverka = False	For Each menu In menuCollection	 If menu.Name = MENUITEM Then proverka = True	Next menu	If Not proverka Then	 Set newMenu = currMenuGroup.Menus.Add(MENUITEM)	 Dim newMenuItem As AcadPopupMenuItem	 Set newMenuItem = newMenu.AddMenuItem(newMenu.Count + 1, "Мерки", "_-vbarun aaaaa ") '	newMenu.InsertInMenuBar (ThisDrawing.Application.MenuBar.Count + 1)	 Set newMenuItem = newMenu.AddMenuItem(newMenu.Count + 1, "Построение юбки Злачевской", "_-vbarun bbbbb ")  newMenu.InsertInMenuBar (ThisDrawing.Application.MenuBar.Count + 1)	End IfEnd SubSub aaaaa()Call RestoreDataUserForm1.ShowEnd SubSub bbbbb()Call RestoreDataCall InitVariblesCall UbkaEnd Sub

[Rochery]

sune4ka, а где вы ищите всякие формулы, или вы их знаите на изусть?
Я на литовском языке ничего хорошого не нахожу, а на русском языке не знаю где искать.
Но вот нашла несколько интерсных ссылок, может кому пригодяться::
http://neive.by.ru/geometriia/teoriia.html
http://school30.udm.ru/IMAGES/2005/flashst...etria/index.htm

 

А можно построить дугу "центр, начало, длина"?

Изменено 8 февраля, 2009 пользователем Rochery

[sune4ka]

sune4ka, а где вы ищите всякие формулы, или вы их знаите на изусть?
Я на литовском языке ничего хорошого не нахожу, а на русском языке не знаю где искать.

 

а ок каких формулах идет речь?:)) у меня в школе с геометрией было неплохо:)) решала всему классу задачки:)))))))))
у меня в профиле есть номер аськи, если что пишите туда, подскажу по мере возможности;) Изменено 10 февраля, 2009 пользователем sune4ka

[Цветы]

Оставшаяся часть по форме.

 

Добрушанка так и не могу понять, почему не хочет строиться повтор 2х окружностей (их пересечение) точка ОО8 так и не встает на место. Может я неправильно опять что-то записала pigac.zip

Изменено 9 февраля, 2009 пользователем Цветы

[sune4ka]

ошибку какую-нибудь выдает редактор?
у меня было такое...что не находилась точка пресечения из-за того что окружности лежали отдельно, не пересекались...в подпрограмме это условие отсутствует...

[sune4ka]

Цветы, я не нашла у вас координаты точки К5... и точку ОО8 тоже.. где вы вызываете подпрограмму circle2?

 

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

[Цветы]

Цветы, я не нашла у вас координаты точки К5... и точку ОО8 тоже.. где вы вызываете подпрограмму circle2?..

 

Я проверю отправленный чертеж,может я нечайно и отправила посмотреть не тот чертеж. Когда строю и спотыкаюсь то сохраняю их несколько, чтобы не потерять и можно было вернуться.
Буду рада помощи. Добрушанке наверное пока некогда. И так я и не поняла какой код нужно вписать вместо значения (pp) Это из построения форму Уроки выше Объясните пожалуйста.Так моя форма и не выполняет команду Построить и почему-то указывает на название формы "Детская рубашка"

[Цветы]

Точка К5 находится внизу чертежа Я с нее начинала построение, а в построении плеча от точки ОО7 я задавала точку ОО8

Изменено 10 февраля, 2009 пользователем Цветы

[sune4ka]

Да, на чертеже она есть, но нет координат в программе... я заметила что для VBA важна последовательность операций, то есть если точка К5 начальная, то и описывать ее координаты следует вначале, странно что редактор ошибки не выдал....

 

жду вашу программку где нужно найти точки пересечения окружностей:)

Изменено 10 февраля, 2009 пользователем sune4ka

[Цветы]

Да, на чертеже она есть, но нет координат в программе... я заметила что для VBA важна последовательность операций, то есть если точка К5 начальная, то и описывать ее координаты следует вначале, странно что редактор ошибки не выдал....

 

жду вашу программку где нужно найти точки пересечения окружностей:)

 

В Виндоусе ошибка и автокад запчихал Сын видно что-то немного не так поработал со своими автомашинами Завтра подправить обещал и сразу пересмотрю свое построение и пришлю на разбирательство Сама я программки не составляю, не умею в основном стараюсь взять готовые подпрограммки и строить. Добрушанка вроде почти все подпрограммки составила, но честно бывает, что готовое не всегда понятно. Все что из программирования умного получилось это пока Детская рубашка и брюки по Мюллеру. Платье строила, но в том моменте, где сейчас как раз и застряла. В построении платья я просто вывила отрезок а сейчас подумала, что надо построить более грамотнее раз взялась, но увы зависла на пересечении окружностей. Как подладит, сразу прибегу за помощью Сама не разберусь. Я вот начальную точку от которой начинаю строить так и считаю, что она расположена на 0,0 начале координатной оси

[Rochery]

Добрый день.
Мне нужно нарисовать дугу (центр, начало, длина). Можно это как-нибудь запрограммировать?

[sune4ka]

уу, а в автокаде естьтакая функция?
в любом случае, если и возможно такое, то это вопрос к Добрушанке:)

[Rochery]

Да, есть такая функция. Просто начертить такую дугу можно, а вот запрограммировать нужно как-то по другому. В Автокаде я нашла только такой метод построения дуги

 

RetVal = object.AddArc(Center, Radius, StartAngle, EndAngle)