GreenBee Posted January 30, 2014 Share Posted January 30, 2014 I'm trying to write a piece of VBA code to help me in making a road designs in which the most boring part is drawing all those sectional designations every 50 or so meters. The code works in a way that user selects all the elements of the road (lines, arcs, etc) end draws sectional designations in given intervals. The code works fine but after some number of elements it just stops as the elements behind it were not selected. I tried on several drafts but it always stops after some number of elements (it's not always the same number, roughly between 10 and 20). Is there a limitation to number of operations which a code can perform or to number of elements in a selection set, or am I missing something here? Quote Link to comment Share on other sites More sharing options...
BIGAL Posted January 31, 2014 Share Posted January 31, 2014 Why are you reinventing the square wheel ? There is plenty of programs out there starting with CIV3D and others that are free. Quote Link to comment Share on other sites More sharing options...
RICVBA Posted January 31, 2014 Share Posted January 31, 2014 let us have a look at your code toghether with a sample dwg. Quote Link to comment Share on other sites More sharing options...
BlackBox Posted January 31, 2014 Share Posted January 31, 2014 Why are you reinventing the square wheel ? There is plenty of programs out there starting with CIV3D and others that are free. Â ....... 1+ Quote Link to comment Share on other sites More sharing options...
GreenBee Posted January 31, 2014 Author Share Posted January 31, 2014 I don't have acces to any software for road designs so I tried to create some routine to help myself on those rare occasions when I'm forced to design roads. Â I'm not home right now, I can post the code later. Â @blackbox I don't get it. What's 1+ Quote Link to comment Share on other sites More sharing options...
BlackBox Posted January 31, 2014 Share Posted January 31, 2014 @blackbox I don't get it. What's 1+ Â Sorry for confusion, this is common forum response, which simply means that 'I agree' with the quoted comment(s). Â Cheers Quote Link to comment Share on other sites More sharing options...
GreenBee Posted January 31, 2014 Author Share Posted January 31, 2014 No problem. I'm obviously not an expert in forum communication. Can you recommend me any free software which can help me? Quote Link to comment Share on other sites More sharing options...
BlackBox Posted January 31, 2014 Share Posted January 31, 2014 No problem. I'm obviously not an expert in forum communication. Can you recommend me any free software which can help me? Â No worries; we all start somewhere. Â I happen to use Civil 3D for daily production (always have since Land Desktop), so I'll have to defer to someone more knowledgeable on the C3D alternatives. Â Cheers Quote Link to comment Share on other sites More sharing options...
Tyke Posted January 31, 2014 Share Posted January 31, 2014 Lars Karlsson has some free software which is very good. It is shareware where you have to make a donation of how much you think it is worth to you to become a fully functioning set of programs, or else a few of the functions will not work. I know a few people who use it and are very pleased with it. Other than that he has his CADTools which is a bundle of great tools for every day work. Here's a link http://www.surveydrawing.net/glamsen.html Quote Link to comment Share on other sites More sharing options...
GreenBee Posted January 31, 2014 Author Share Posted January 31, 2014 Thank you both Quote Link to comment Share on other sites More sharing options...
RICVBA Posted February 1, 2014 Share Posted February 1, 2014 anyhow, if you decided to go on with your "wheel" I'd gladly try and help with your VBA code (and earn consequent negative forum numbers!) Quote Link to comment Share on other sites More sharing options...
Tyke Posted February 1, 2014 Share Posted February 1, 2014 (and earn consequent negative forum numbers!) Â Sorry I don't understand what you mean with that. Do you want to elaborate on it? Â What BigAl said is correct, you don't re-invent something that is already there, but if you don't have access to it and other tools don't meet your needs then writing your own modules is the only way to go. And in that respect I think there are enough people here willing to help out if they can. Quote Link to comment Share on other sites More sharing options...
RICVBA Posted February 3, 2014 Share Posted February 3, 2014 with pleasure Tyke  I think that you can work on whatever you're interested in. Which is simply another perspective from strictly choosing what's more worthwhile. But both are eligible, it's up to your own needs. and inclinations.  So, BigAl's piece of advice is certainly fair and if GreenBee is interested in obtaining the specific result with the least effort (in time and, therefore, money), he'll follow it. While should GreenBee be interested in developing a piece of VBA code to deepen his knowledge in objects/method management in that specific direction, and having them available for further needs, he'd choose to develope some code by himself. In this latter case, which I clearly endorse, this forum people would certainly be of great help.  Finally, my "(and earn consequent negative forum numbers)" was both a self ironic comment on my a priori non-pragmatic perspective, as compared to BigAl's and yours (and many other people's here too, I believe), and a way to confirm my initial position despite subsequent "boohs".  hope this does it  bye Quote Link to comment Share on other sites More sharing options...
GreenBee Posted February 3, 2014 Author Share Posted February 3, 2014 I must admit that RICVBA has a point. My intention was both to see how far can I push my (not so vast) knowledge in writing a piece of code and also to speed up my working process. Here's the code. I admit it could be confusing but it's just a work-in-process version. The user inputs two variables, the width of the road and the distance between cross sections and then selects on screen the first point, the last point of the road and all segments between them one by one in order as they come. Â Private Sub CommandButton1_Click() Dim SOS As AcadSelectionSet Dim objSS As AcadSelectionSet Dim PopLin As AcadLine Dim Kruzic As AcadCircle Dim objent As AcadEntity Dim Pravac As AcadLine Dim PrKrivina As AcadLWPolyline Dim Luk As AcadArc Dim Rluk, Alfa As Double Dim L, Lpravac, Lprkriv, Lluk, Lostatak As Double Dim PocToc As Variant Dim ZadToc As Variant Dim PrvaTocka(0 To 2) As Double Dim DrugaTocka(0 To 2) As Double Dim RazProf, SirCest As Double Dim Krug As AcadCircle Dim sjeciste As Variant Dim sjeciste2 As Variant Dim BrProfila, i, n As Integer Dim PlusMinus As Boolean Dim Rpoplin As Double Dim pi As Double Dim linija, linija1, linija2 As AcadLine Dim BrojacProfila As Integer Dim SredisnjaTockaLuka As Variant Dim BrPomaka, brojX As Integer Dim kolicnik As Double Dim PomocnaTocka1(0 To 2) As Double Dim PomocnaTocka2(0 To 2) As Double Dim BrTocakaPlinea, Kocnica, LostatakPrKr As Integer Dim Lpomocni As Double Dim KoorNaopakePrKr() As Double UserForm1.hide pi = 3.14159265358979 RazProf = txtRazProf.Value SirCest = txtSirCest.Value Rpoplin = SirCest * 2 PocToc = ThisDrawing.Utility.GetPoint(, "Odaberite pocetnu tocku trase") ZadToc = ThisDrawing.Utility.GetPoint(, "Odaberite zadnju tocku trase") For Each SOS In ThisDrawing.SelectionSets If SOS.Name = "MySS" Then ThisDrawing.SelectionSets("MySS").Delete Exit For End If Next ThisDrawing.SelectionSets.Add ("MySS") Set objSS = ThisDrawing.SelectionSets("MySS") objSS.SelectOnScreen If objSS.Count < 1 Then Exit Sub i = 0 L = 0 Lostatak = 0 PlusMinus = False '********GLAVNI DIO PROGRAMA******** For Each objent In objSS Select Case objent.ObjectName '<<<<<PRAVAC>>>>> Case "AcDbLine" Set Pravac = objent PlusMinus = False L = L + Pravac.Length 'Ako pravac nije prvi element trase If Abs(DrugaTocka(0) - Pravac.StartPoint(0)) < 0.000001 And Abs(DrugaTocka(1) - Pravac.StartPoint(1)) < 0.000001 _ And PrvaTocka(0) <> Pravac.EndPoint(0) And PrvaTocka(1) <> Pravac.EndPoint(1) Then PrvaTocka(0) = DrugaTocka(0) PrvaTocka(1) = DrugaTocka(1) PrvaTocka(2) = DrugaTocka(2) DrugaTocka(0) = Pravac.EndPoint(0) DrugaTocka(1) = Pravac.EndPoint(1) DrugaTocka(2) = Pravac.EndPoint(2) PlusMinus = True End If If Abs(DrugaTocka(0) - Pravac.EndPoint(0)) < 0.000001 And Abs(DrugaTocka(1) - Pravac.EndPoint(1)) < 0.000001 _ And PrvaTocka(0) <> Pravac.StartPoint(0) And PrvaTocka(1) <> Pravac.StartPoint(1) Then PrvaTocka(0) = DrugaTocka(0) PrvaTocka(1) = DrugaTocka(1) PrvaTocka(2) = DrugaTocka(2) DrugaTocka(0) = Pravac.StartPoint(0) DrugaTocka(1) = Pravac.StartPoint(1) DrugaTocka(2) = Pravac.StartPoint(2) PlusMinus = True End If If PlusMinus = True Then If Pravac.Length > Lostatak Then BrProfila = (Pravac.Length - Lostatak) \ RazProf kolicnik = (Pravac.Length - Lostatak) / RazProf If BrProfila > kolicnik Then BrProfila = BrProfila - 1 End If For i = 1 To BrProfila 'Za sve ostale profile Set Krug = ThisDrawing.ModelSpace.AddCircle _ (PrvaTocka, (RazProf * (i - 1) + Lostatak)) sjeciste = Pravac.IntersectWith(Krug, acExtendNone) Set Kruzic = ThisDrawing.ModelSpace.AddCircle(sjeciste, SirCest / 3.5) Krug.Delete Set Krug = ThisDrawing.ModelSpace.AddCircle _ (PrvaTocka, (RazProf * (i - 1) + Lostatak + Rpoplin)) sjeciste = Pravac.IntersectWith(Krug, acExtendNone) Set linija = ThisDrawing.ModelSpace.AddLine(Kruzic.Center, sjeciste) linija.Rotate Kruzic.Center, pi / 2 Set PopLin = ThisDrawing.ModelSpace.AddLine(linija.EndPoint, Kruzic.Center) linija.Delete PopLin.Mirror DrugaTocka, PrvaTocka Krug.Delete Next 'Za predzadnji profil na pravcu Set Krug = ThisDrawing.ModelSpace.AddCircle _ (DrugaTocka, (Pravac.Length - RazProf * BrProfila - Lostatak)) sjeciste = Pravac.IntersectWith(Krug, acExtendNone) Set Kruzic = ThisDrawing.ModelSpace.AddCircle(sjeciste, SirCest / 3.5) Krug.Delete Set linija = ThisDrawing.ModelSpace.AddLine(DrugaTocka, sjeciste) If Pravac.Length > (linija.Length + Rpoplin) Then Set Krug = ThisDrawing.ModelSpace.AddCircle(DrugaTocka, (linija.Length + Rpoplin)) linija.Delete sjeciste2 = Pravac.IntersectWith(Krug, acExtendNone) Krug.Delete Set PopLin = ThisDrawing.ModelSpace.AddLine(sjeciste2, sjeciste) PopLin.Rotate sjeciste, pi / 2 PopLin.Mirror PrvaTocka, DrugaTocka Else linija.Delete Set linija = ThisDrawing.ModelSpace.AddLine(PrvaTocka, DrugaTocka) linija.Rotate sjeciste, pi / 2 linija.Move linija.StartPoint, sjeciste BrPomaka = (Rpoplin) \ Pravac.Length kolicnik = (Rpoplin) / Pravac.Length If BrPomaka < kolicnik Then For i = 1 To BrPomaka linija.Move linija.StartPoint, linija.EndPoint Next Else For i = 1 To (BrPomaka - 1) linija.Move linija.StartPoint, linija.EndPoint Next End If Set Krug = ThisDrawing.ModelSpace.AddCircle(sjeciste, Rpoplin) sjeciste2 = linija.IntersectWith(Krug, acExtendNone) Krug.Delete linija.Delete Set PopLin = ThisDrawing.ModelSpace.AddLine(sjeciste2, sjeciste) PopLin.Mirror PrvaTocka, DrugaTocka End If Lostatak = RazProf - (Pravac.Length - (BrProfila * RazProf) - Lostatak) 'Ako je pravac zadnji element trase If DrugaTocka(0) = ZadToc(0) And DrugaTocka(1) = ZadToc(1) Then Set Krug = ThisDrawing.ModelSpace.AddCircle(DrugaTocka, Rpoplin) sjeciste = Pravac.IntersectWith(Krug, acExtendNone) Set Kruzic = ThisDrawing.ModelSpace.AddCircle(DrugaTocka, SirCest / 3.5) Krug.Delete Set linija = ThisDrawing.ModelSpace.AddLine(sjeciste, DrugaTocka) linija.Rotate DrugaTocka, pi / 2 Set PopLin = ThisDrawing.ModelSpace.AddLine(linija.StartPoint, DrugaTocka) linija.Delete PopLin.Mirror DrugaTocka, PrvaTocka End If 'Ako je duljina pravca manja od Lostatak Else Lostatak = Lostatak - Pravac.Length 'Ako je pravac zadnji element trase If DrugaTocka(0) = ZadToc(0) And DrugaTocka(1) = ZadToc(1) Then Set Krug = ThisDrawing.ModelSpace.AddCircle(DrugaTocka, Rpoplin) sjeciste = Pravac.IntersectWith(Krug, acExtendNone) Set Kruzic = ThisDrawing.ModelSpace.AddCircle(DrugaTocka, SirCest / 3.5) Krug.Delete Set linija = ThisDrawing.ModelSpace.AddLine(sjeciste, DrugaTocka) linija.Rotate DrugaTocka, pi / 2 Set PopLin = ThisDrawing.ModelSpace.AddLine(linija.StartPoint, DrugaTocka) linija.Delete PopLin.Mirror DrugaTocka, PrvaTocka End If End If PlusMinus = False End If 'Ako je pravac prvi element trase If (Pravac.StartPoint(0) = PocToc(0)) And (Pravac.StartPoint(1) = PocToc(1)) Then PrvaTocka(0) = PocToc(0) PrvaTocka(1) = PocToc(1) PrvaTocka(2) = PocToc(2) DrugaTocka(0) = Pravac.EndPoint(0) DrugaTocka(1) = Pravac.EndPoint(1) DrugaTocka(2) = Pravac.EndPoint(2) PlusMinus = True End If If (Pravac.EndPoint(0) = PocToc(0)) And (Pravac.EndPoint(1) = PocToc(1)) Then PrvaTocka(0) = PocToc(0) PrvaTocka(1) = PocToc(1) PrvaTocka(2) = PocToc(2) DrugaTocka(0) = Pravac.StartPoint(0) DrugaTocka(1) = Pravac.StartPoint(1) DrugaTocka(2) = Pravac.StartPoint(2) PlusMinus = True End If If PlusMinus = True Then 'Za prvi profil na pravcu Set Krug = ThisDrawing.ModelSpace.AddCircle(PrvaTocka, Rpoplin) sjeciste = Pravac.IntersectWith(Krug, acExtendNone) Set Kruzic = ThisDrawing.ModelSpace.AddCircle(PrvaTocka, SirCest / 3.5) Krug.Delete Set linija = ThisDrawing.ModelSpace.AddLine(sjeciste, PrvaTocka) linija.Rotate PrvaTocka, pi / 2 Set PopLin = ThisDrawing.ModelSpace.AddLine(linija.StartPoint, PrvaTocka) linija.Delete PopLin.Mirror DrugaTocka, PrvaTocka 'Provjeriti je li razmak profila manji od duljine pravca If Pravac.Length > RazProf Then Set Krug = ThisDrawing.ModelSpace.AddCircle(PrvaTocka, Rpoplin) sjeciste = Pravac.IntersectWith(Krug, acExtendNone) Set Kruzic = ThisDrawing.ModelSpace.AddCircle(PrvaTocka, SirCest / 3.5) Krug.Delete Set linija = ThisDrawing.ModelSpace.AddLine(sjeciste, PrvaTocka) linija.Rotate PrvaTocka, pi / 2 Set PopLin = ThisDrawing.ModelSpace.AddLine(linija.StartPoint, PrvaTocka) linija.Delete PopLin.Mirror DrugaTocka, PrvaTocka BrProfila = Pravac.Length \ RazProf kolicnik = Pravac.Length / RazProf If BrProfila > kolicnik Then BrProfila = BrProfila - 1 End If For i = 1 To BrProfila Set Krug = ThisDrawing.ModelSpace.AddCircle(PrvaTocka, RazProf * i) sjeciste = Pravac.IntersectWith(Krug, acExtendNone) Set Kruzic = ThisDrawing.ModelSpace.AddCircle(sjeciste, SirCest / 3.5) Krug.Delete Set Krug = ThisDrawing.ModelSpace.AddCircle(PrvaTocka, RazProf * i - Rpoplin) sjeciste = Pravac.IntersectWith(Krug, acExtendNone) Set linija = ThisDrawing.ModelSpace.AddLine(Kruzic.Center, sjeciste) linija.Rotate Kruzic.Center, pi / 2 Set PopLin = ThisDrawing.ModelSpace.AddLine(linija.EndPoint, Kruzic.Center) linija.Delete PopLin.Mirror DrugaTocka, PrvaTocka Krug.Delete Next Lostatak = RazProf - (Pravac.Length - ((i - 1) * RazProf)) 'Ako je pravac zadnji element trase If DrugaTocka(0) = ZadToc(0) And DrugaTocka(1) = ZadToc(1) Then Set Krug = ThisDrawing.ModelSpace.AddCircle(DrugaTocka, Rpoplin) sjeciste = Pravac.IntersectWith(Krug, acExtendNone) Set Kruzic = ThisDrawing.ModelSpace.AddCircle(DrugaTocka, SirCest / 3.5) Krug.Delete Set linija = ThisDrawing.ModelSpace.AddLine(sjeciste, DrugaTocka) linija.Rotate DrugaTocka, pi / 2 Set PopLin = ThisDrawing.ModelSpace.AddLine(linija.StartPoint, DrugaTocka) linija.Delete PopLin.Mirror DrugaTocka, PrvaTocka End If 'Ako je duljina pravca manja od razmaka profila Else 'Ako je pravac zadnji element trase If DrugaTocka(0) = ZadToc(0) And DrugaTocka(1) = ZadToc(1) Then Set Krug = ThisDrawing.ModelSpace.AddCircle(DrugaTocka, Rpoplin) sjeciste = Pravac.IntersectWith(Krug, acExtendNone) Set Kruzic = ThisDrawing.ModelSpace.AddCircle(DrugaTocka, SirCest / 3.5) Krug.Delete Set linija = ThisDrawing.ModelSpace.AddLine(sjeciste, DrugaTocka) linija.Rotate DrugaTocka, pi / 2 Set PopLin = ThisDrawing.ModelSpace.AddLine(linija.StartPoint, DrugaTocka) linija.Delete PopLin.Mirror DrugaTocka, PrvaTocka End If Lostatak = RazProf - Pravac.Length End If End If Quote Link to comment Share on other sites More sharing options...
GreenBee Posted February 3, 2014 Author Share Posted February 3, 2014 '<<<<<PRIJELAZNA KRIVINA>>>>> Case "AcDbPolyline" Set PrKrivina = objent BrTocakaPlinea = UBound(PrKrivina.Coordinates) ReDim KoorNaopakePrKr(BrTocakaPlinea) L = L + PrKrivina.Length LostatakPrKr = Lostatak 'Ako prijelazna krivina nije prvi element trase If Abs(DrugaTocka(0) - PrKrivina.Coordinates(0)) < 0.00001 And _ Abs(DrugaTocka(1) - PrKrivina.Coordinates(1)) < 0.00001 And _ PrKrivina.Coordinates(BrTocakaPlinea - 1) <> PrvaTocka(0) And _ PrKrivina.Coordinates(BrTocakaPlinea) <> PrvaTocka(1) Then PrvaTocka(0) = PrKrivina.Coordinates(0) PrvaTocka(1) = PrKrivina.Coordinates(1) PrvaTocka(2) = 0 DrugaTocka(0) = PrKrivina.Coordinates(BrTocakaPlinea - 1) DrugaTocka(1) = PrKrivina.Coordinates(BrTocakaPlinea) DrugaTocka(2) = 0 PlusMinus = True End If If Abs(DrugaTocka(0) - PrKrivina.Coordinates(BrTocakaPlinea - 1)) < 0.00001 And _ Abs(DrugaTocka(1) - PrKrivina.Coordinates(BrTocakaPlinea)) < 0.00001 And _ PrKrivina.Coordinates(0) <> PrvaTocka(0) And _ PrKrivina.Coordinates(1) <> PrvaTocka(1) Then For i = 0 To BrTocakaPlinea Step 2 KoorNaopakePrKr(i) = PrKrivina.Coordinates(BrTocakaPlinea - i - 1) KoorNaopakePrKr(i + 1) = PrKrivina.Coordinates(BrTocakaPlinea - i) Next PrKrivina.Delete Set PrKrivina = ThisDrawing.ModelSpace.AddLightWeightPolyline(KoorNaopakePrKr) PrvaTocka(0) = PrKrivina.Coordinates(0) PrvaTocka(1) = PrKrivina.Coordinates(1) PrvaTocka(2) = 0 DrugaTocka(0) = PrKrivina.Coordinates(BrTocakaPlinea - 1) DrugaTocka(1) = PrKrivina.Coordinates(BrTocakaPlinea) DrugaTocka(2) = 0 PlusMinus = True End If If PlusMinus = True Then 'Prva tocka prijelazne krivine PomocnaTocka1(0) = PrKrivina.Coordinates(2) PomocnaTocka1(1) = PrKrivina.Coordinates(3) PomocnaTocka1(2) = 0 Set linija1 = ThisDrawing.ModelSpace.AddLine(PrvaTocka, PomocnaTocka1) Set linija2 = ThisDrawing.ModelSpace.AddLine(PrvaTocka, PomocnaTocka1) linija1.Rotate PrvaTocka, pi / 2 linija2.Rotate PrvaTocka, 3 * pi / 2 BrPomaka = (Rpoplin) \ linija1.Length kolicnik = (Rpoplin) / linija1.Length If BrPomaka < kolicnik Then For i = 1 To BrPomaka linija1.Move linija1.StartPoint, linija1.EndPoint linija2.Move linija2.StartPoint, linija2.EndPoint Next Else For i = 1 To (BrPomaka - 1) linija1.Move linija1.StartPoint, linija1.EndPoint linija2.Move linija2.StartPoint, linija2.EndPoint Next End If Set Krug = ThisDrawing.ModelSpace.AddCircle(PrvaTocka, Rpoplin) sjeciste = linija1.IntersectWith(Krug, acExtendNone) sjeciste2 = linija2.IntersectWith(Krug, acExtendNone) Krug.Delete linija1.Delete linija2.Delete Set PopLin = ThisDrawing.ModelSpace.AddLine(sjeciste, sjeciste2) Set Kruzic = ThisDrawing.ModelSpace.AddCircle(PrvaTocka, SirCest / 3.5) 'Ostali profili na prijelaznoj krivini brojX = 0 Lpomocni = 0 If PrKrivina.Length > LostatakPrKr Then BrProfila = (PrKrivina.Length - LostatakPrKr) \ RazProf kolicnik = (PrKrivina.Length - LostatakPrKr) / RazProf If BrProfila > kolicnik Then BrProfila = BrProfila - 1 End If For i = 1 To BrProfila + 1 If i < 2 Or i = 2 Then Kocnica = i - 1 Else Kocnica = Kocnica End If LostatakPrKr = LostatakPrKr + RazProf * Kocnica Do PomocnaTocka1(0) = PrKrivina.Coordinates(brojX) PomocnaTocka1(1) = PrKrivina.Coordinates(brojX + 1) PomocnaTocka1(2) = 0 PomocnaTocka2(0) = PrKrivina.Coordinates(brojX + 2) PomocnaTocka2(1) = PrKrivina.Coordinates(brojX + 3) PomocnaTocka2(2) = 0 brojX = brojX + 2 Set linija1 = ThisDrawing.ModelSpace.AddLine(PomocnaTocka1, PomocnaTocka2) Lpomocni = Lpomocni + linija1.Length If Lpomocni < LostatakPrKr Then linija1.Delete End If Loop While Lpomocni < LostatakPrKr Set Krug = ThisDrawing.ModelSpace.AddCircle(PomocnaTocka2, (Lpomocni - LostatakPrKr)) sjeciste = linija1.IntersectWith(Krug, acExtendNone) Set Kruzic = ThisDrawing.ModelSpace.AddCircle(sjeciste, SirCest / 3.5) linija1.Delete Krug.Delete Set linija1 = ThisDrawing.ModelSpace.AddLine(PomocnaTocka1, sjeciste) Set linija2 = ThisDrawing.ModelSpace.AddLine(PomocnaTocka1, sjeciste) linija1.Rotate sjeciste, pi / 2 linija2.Rotate sjeciste, 3 * pi / 2 BrPomaka = (Rpoplin) \ linija1.Length kolicnik = (Rpoplin) / linija1.Length If BrPomaka < kolicnik Then For n = 1 To BrPomaka linija1.Move linija1.EndPoint, linija1.StartPoint linija2.Move linija2.EndPoint, linija2.StartPoint Next Else For n = 1 To (BrPomaka - 1) linija1.Move linija1.EndPoint, linija1.StartPoint linija2.Move linija2.EndPoint, linija2.StartPoint Next End If Set Krug = ThisDrawing.ModelSpace.AddCircle(sjeciste, Rpoplin) sjeciste = linija1.IntersectWith(Krug, acExtendNone) sjeciste2 = linija2.IntersectWith(Krug, acExtendNone) Krug.Delete linija1.Delete linija2.Delete Set PopLin = ThisDrawing.ModelSpace.AddLine(sjeciste, sjeciste2) Next Lostatak = RazProf - (PrKrivina.Length - Lostatak - BrProfila * RazProf) Else Lostatak = Lostatak - PrKrivina.Length End If 'Ako je prijelazna krivina zadnji element trase If DrugaTocka(0) = ZadToc(0) And DrugaTocka(1) = ZadToc(1) Then PomocnaTocka1(0) = PrKrivina.Coordinates(BrTocakaPlinea - 3) PomocnaTocka1(1) = PrKrivina.Coordinates(BrTocakaPlinea - 2) PomocnaTocka1(2) = 0 Set linija1 = ThisDrawing.ModelSpace.AddLine(PomocnaTocka1, DrugaTocka) Set linija2 = ThisDrawing.ModelSpace.AddLine(PomocnaTocka1, DrugaTocka) linija1.Rotate DrugaTocka, pi / 2 linija2.Rotate DrugaTocka, 3 * pi / 2 BrPomaka = (Rpoplin) \ linija1.Length kolicnik = (Rpoplin) / linija1.Length If BrPomaka < kolicnik Then For n = 1 To BrPomaka linija1.Move linija1.EndPoint, linija1.StartPoint linija2.Move linija2.EndPoint, linija2.StartPoint Next Else For n = 1 To (BrPomaka - 1) linija1.Move linija1.EndPoint, linija1.StartPoint linija2.Move linija2.EndPoint, linija2.StartPoint Next End If Set Krug = ThisDrawing.ModelSpace.AddCircle(DrugaTocka, Rpoplin) sjeciste = linija1.IntersectWith(Krug, acExtendNone) sjeciste2 = linija2.IntersectWith(Krug, acExtendNone) Krug.Delete linija1.Delete linija2.Delete Set PopLin = ThisDrawing.ModelSpace.AddLine(sjeciste, sjeciste2) Set Kruzic = ThisDrawing.ModelSpace.AddCircle(DrugaTocka, SirCest / 3.5) End If End If Quote Link to comment Share on other sites More sharing options...
GreenBee Posted February 3, 2014 Author Share Posted February 3, 2014 '<<<<<KRUZNI LUK>>>>> Case "AcDbArc" Set Luk = objent L = L + Luk.ArcLength Lluk = Luk.ArcLength Rluk = Luk.Radius PlusMinus = False 'Ako luk nije prvi element trase 'Ako je startpoint luka jednak drugoj tocki If Abs(Luk.StartPoint(0) - DrugaTocka(0)) < 0.000001 And Abs(Luk.StartPoint(1) - DrugaTocka(1)) < 0.000001 _ And Luk.EndPoint(0) <> PrvaTocka(0) And Luk.EndPoint(1) <> PrvaTocka(1) Then PrvaTocka(0) = Luk.StartPoint(0) PrvaTocka(1) = Luk.StartPoint(1) PrvaTocka(2) = Luk.StartPoint(2) DrugaTocka(0) = Luk.EndPoint(0) DrugaTocka(1) = Luk.EndPoint(1) DrugaTocka(2) = Luk.EndPoint(2) PlusMinus = True End If 'Ako je endpoint luka jednak drugoj tocki If Abs(Luk.EndPoint(0) - DrugaTocka(0)) < 0.000001 And Abs(Luk.EndPoint(1) - DrugaTocka(1)) < 0.000001 _ And Luk.StartPoint(0) <> PrvaTocka(0) And Luk.StartPoint(1) <> PrvaTocka(1) Then PrvaTocka(0) = Luk.EndPoint(0) PrvaTocka(1) = Luk.EndPoint(1) PrvaTocka(2) = Luk.EndPoint(2) DrugaTocka(0) = Luk.StartPoint(0) DrugaTocka(1) = Luk.StartPoint(1) DrugaTocka(2) = Luk.StartPoint(2) PlusMinus = True End If If PlusMinus = True Then 'pocetna tocka luka Set linija1 = ThisDrawing.ModelSpace.AddLine(PrvaTocka, Luk.Center) Set Krug = ThisDrawing.ModelSpace.AddCircle(PrvaTocka, Rpoplin) sjeciste = linija1.IntersectWith(Krug, acExtendNone) Krug.Delete linija1.Delete Set linija1 = ThisDrawing.ModelSpace.AddLine(PrvaTocka, sjeciste) Set linija2 = ThisDrawing.ModelSpace.AddLine(linija1.EndPoint, PrvaTocka) linija2.Move linija2.StartPoint, PrvaTocka Set PopLin = ThisDrawing.ModelSpace.AddLine(linija1.EndPoint, linija2.EndPoint) Set Kruzic = ThisDrawing.ModelSpace.AddCircle(PrvaTocka, SirCest / 3.5) linija1.Delete linija2.Delete 'sredisnja tocka luka Set linija1 = ThisDrawing.ModelSpace.AddLine(PrvaTocka, DrugaTocka) Set Krug = ThisDrawing.ModelSpace.AddCircle(PrvaTocka, (linija1.Length / 2)) sjeciste = linija1.IntersectWith(Krug, acExtendNone) Krug.Delete linija1.Rotate sjeciste, pi / 2 SredisnjaTockaLuka = linija1.IntersectWith(Luk, acExtendNone) linija1.Delete Set Krug = ThisDrawing.ModelSpace.AddCircle(SredisnjaTockaLuka, Rpoplin) Set linija1 = ThisDrawing.ModelSpace.AddLine(SredisnjaTockaLuka, Luk.Center) sjeciste = linija1.IntersectWith(Krug, acExtendNone) If UBound(sjeciste) = -1 Then linija1.Move SredisnjaTockaLuka, Luk.Center sjeciste = linija1.IntersectWith(Luk, acExtendNone) End If Krug.Delete linija1.Delete Set linija2 = ThisDrawing.ModelSpace.AddLine(SredisnjaTockaLuka, sjeciste) linija2.Copy linija2.Move sjeciste, SredisnjaTockaLuka Set PopLin = ThisDrawing.ModelSpace.AddLine(linija2.StartPoint, sjeciste) linija2.Delete Set Kruzic = ThisDrawing.ModelSpace.AddCircle(SredisnjaTockaLuka, SirCest / 3.5) '------>Ostali profili na luku 'Ako je luk duzi od razmaka profila n = 0 If Lluk > Lostatak Then BrProfila = (Lluk - Lostatak) \ RazProf kolicnik = (Lluk - Lostatak) / RazProf If BrProfila > kolicnik Then BrProfila = BrProfila - 1 End If For i = 1 To (BrProfila + 1) Alfa = (Lostatak + n) / Rluk Set linija1 = ThisDrawing.ModelSpace.AddLine(Luk.Center, PrvaTocka) linija1.Rotate Luk.Center, Alfa sjeciste2 = linija1.IntersectWith(Luk, acExtendNone) If UBound(sjeciste2) = -1 Then Alfa = -1 * Alfa linija1.Rotate Luk.Center, (2 * Alfa) sjeciste2 = linija1.IntersectWith(Luk, acExtendNone) End If Set Krug = ThisDrawing.ModelSpace.AddCircle(sjeciste2, Rpoplin) sjeciste = Krug.IntersectWith(linija1, acExtendNone) linija1.Delete Krug.Delete Set linija2 = ThisDrawing.ModelSpace.AddLine(sjeciste2, sjeciste) linija2.Copy linija2.Move sjeciste, sjeciste2 Set linija1 = ThisDrawing.ModelSpace.AddLine(sjeciste2, sjeciste) Set PopLin = ThisDrawing.ModelSpace.AddLine(linija2.StartPoint, linija1.EndPoint) linija1.Delete linija2.Delete Set Kruzic = ThisDrawing.ModelSpace.AddCircle(sjeciste2, SirCest / 3.5) n = n + RazProf Next Lostatak = RazProf - (Luk.ArcLength - Lostatak - BrProfila * RazProf) Else Lostatak = Lostatak - Luk.ArcLength End If 'Provjeriti da li je luk zadnji element trase If Abs(DrugaTocka(0) - ZadToc(0)) < 0.00001 And Abs(DrugaTocka(1) - ZadToc(1)) < 0.00001 Then Set linija1 = ThisDrawing.ModelSpace.AddLine(DrugaTocka, Luk.Center) Set Krug = ThisDrawing.ModelSpace.AddCircle(DrugaTocka, Rpoplin) sjeciste = linija1.IntersectWith(Krug, acExtendNone) Krug.Delete linija1.Delete Set PopLin = ThisDrawing.ModelSpace.AddLine(DrugaTocka, sjeciste) PopLin.Copy PopLin.Move sjeciste, DrugaTocka Set Kruzic = ThisDrawing.ModelSpace.AddCircle(DrugaTocka, SirCest / 3.5) End If PlusMinus = False End If 'Provjeriti da li je luk prvi element trase 'Ako je prva tocka trase jednaka startpointu luka If Luk.StartPoint(0) = PocToc(0) And Luk.StartPoint(1) = PocToc(1) Then PrvaTocka(0) = Luk.StartPoint(0) PrvaTocka(1) = Luk.StartPoint(1) PrvaTocka(2) = Luk.StartPoint(2) DrugaTocka(0) = Luk.EndPoint(0) DrugaTocka(1) = Luk.EndPoint(1) DrugaTocka(2) = Luk.EndPoint(2) PlusMinus = True End If 'Ako je prva tocka trase jednaka endpointu luka If Luk.EndPoint(0) = PocToc(0) And Luk.EndPoint(1) = PocToc(1) Then PrvaTocka(0) = Luk.EndPoint(0) PrvaTocka(1) = Luk.EndPoint(1) PrvaTocka(2) = Luk.EndPoint(2) DrugaTocka(0) = Luk.StartPoint(0) DrugaTocka(1) = Luk.StartPoint(1) DrugaTocka(2) = Luk.StartPoint(2) PlusMinus = True End If If PlusMinus = True Then 'pocetna tocka luka Set linija1 = ThisDrawing.ModelSpace.AddLine(PrvaTocka, Luk.Center) Set Krug = ThisDrawing.ModelSpace.AddCircle(PrvaTocka, Rpoplin) sjeciste = linija1.IntersectWith(Krug, acExtendNone) Krug.Delete linija1.Delete Set linija1 = ThisDrawing.ModelSpace.AddLine(PrvaTocka, sjeciste) Set linija2 = ThisDrawing.ModelSpace.AddLine(linija1.EndPoint, PrvaTocka) linija2.Move linija2.StartPoint, PrvaTocka Set PopLin = ThisDrawing.ModelSpace.AddLine(linija1.EndPoint, linija2.EndPoint) Set Kruzic = ThisDrawing.ModelSpace.AddCircle(PrvaTocka, SirCest / 3.5) linija1.Delete linija2.Delete 'sredisnja tocka luka Set linija1 = ThisDrawing.ModelSpace.AddLine(PrvaTocka, DrugaTocka) Set Krug = ThisDrawing.ModelSpace.AddCircle(PrvaTocka, (linija1.Length / 2)) sjeciste = linija1.IntersectWith(Krug, acExtendNone) Krug.Delete linija1.Rotate sjeciste, pi / 2 SredisnjaTockaLuka = linija1.IntersectWith(Luk, acExtendNone) linija1.Delete Set Krug = ThisDrawing.ModelSpace.AddCircle(SredisnjaTockaLuka, Rpoplin) Set linija1 = ThisDrawing.ModelSpace.AddLine(SredisnjaTockaLuka, Luk.Center) sjeciste = linija1.IntersectWith(Krug, acExtendNone) If UBound(sjeciste) = -1 Then linija1.Move SredisnjaTockaLuka, Luk.Center sjeciste = linija1.IntersectWith(Luk, acExtendNone) End If Krug.Delete linija1.Delete Set linija2 = ThisDrawing.ModelSpace.AddLine(SredisnjaTockaLuka, sjeciste) linija2.Copy linija2.Move sjeciste, SredisnjaTockaLuka Set PopLin = ThisDrawing.ModelSpace.AddLine(linija2.StartPoint, sjeciste) linija2.Delete Set Kruzic = ThisDrawing.ModelSpace.AddCircle(SredisnjaTockaLuka, SirCest / 3.5) '------>Ostali profili na luku 'Ako je luk duzi od razmaka profila n = 0 If Lluk > Lostatak Then BrProfila = (Lluk - Lostatak) \ RazProf kolicnik = (Lluk - Lostatak) / RazProf If BrProfila > kolicnik Then BrProfila = BrProfila - 1 End If For i = 1 To (BrProfila + 1) Alfa = (Lostatak + n) / Rluk Set linija1 = ThisDrawing.ModelSpace.AddLine(Luk.Center, PrvaTocka) linija1.Rotate Luk.Center, Alfa sjeciste2 = linija1.IntersectWith(Luk, acExtendNone) If UBound(sjeciste2) = -1 Then Alfa = -1 * Alfa linija1.Rotate Luk.Center, (2 * Alfa) sjeciste2 = linija1.IntersectWith(Luk, acExtendNone) End If Set Krug = ThisDrawing.ModelSpace.AddCircle(sjeciste2, Rpoplin) sjeciste = Krug.IntersectWith(linija1, acExtendNone) linija1.Delete Krug.Delete Set linija2 = ThisDrawing.ModelSpace.AddLine(sjeciste2, sjeciste) linija2.Copy linija2.Move sjeciste, sjeciste2 Set linija1 = ThisDrawing.ModelSpace.AddLine(sjeciste2, sjeciste) Set PopLin = ThisDrawing.ModelSpace.AddLine(linija2.StartPoint, linija1.EndPoint) linija1.Delete linija2.Delete Set Kruzic = ThisDrawing.ModelSpace.AddCircle(sjeciste2, SirCest / 3.5) n = n + RazProf Next Lostatak = RazProf - (Luk.ArcLength - Lostatak - BrProfila * RazProf) Else Lostatak = Lostatak - Luk.ArcLength End If 'Provjeriti da li je luk zadnji element trase If Abs(DrugaTocka(0) - ZadToc(0)) < 0.00001 And Abs(DrugaTocka(1) - ZadToc(1)) < 0.00001 Then Set linija1 = ThisDrawing.ModelSpace.AddLine(DrugaTocka, Luk.Center) Set Krug = ThisDrawing.ModelSpace.AddCircle(DrugaTocka, Rpoplin) sjeciste = linija1.IntersectWith(Krug, acExtendNone) Krug.Delete linija1.Delete Set PopLin = ThisDrawing.ModelSpace.AddLine(DrugaTocka, sjeciste) PopLin.Copy PopLin.Move sjeciste, DrugaTocka Set Kruzic = ThisDrawing.ModelSpace.AddCircle(DrugaTocka, SirCest / 3.5) End If End If End Select Next End Sub Quote Link to comment Share on other sites More sharing options...
GreenBee Posted February 3, 2014 Author Share Posted February 3, 2014 I know it's long and messy so I'll understand if you guys won't have time to fool around with it. Â Bye Quote Link to comment Share on other sites More sharing options...
RICVBA Posted February 3, 2014 Share Posted February 3, 2014 I asked for it! The code is quite crpitic in that it's written using your mother language terms, but I'll give it a try if you attach a sample dwg (maybe the one you're having troubles with). Bye Quote Link to comment Share on other sites More sharing options...
GreenBee Posted February 3, 2014 Author Share Posted February 3, 2014 I understand completely. It will take a great effort to make sense out of it and I really appreciate your help. Â The road consists of lines, polylines and arc segments. Â The comments are written in Croatian if it's gonna be of any help if you want to translate some of the terms. The variable names however will not make much sense because most of them are abbreviations. Â Thanks again. Road.dwg Quote Link to comment Share on other sites More sharing options...
BlackBox Posted February 3, 2014 Share Posted February 3, 2014 Thinking out loud... Does VBA have an equivalent for Visual LISP's vlax-Curve* functions? Quote Link to comment Share on other sites More sharing options...
Recommended Posts
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.