Jump to content

VBA limitations


GreenBee

Recommended Posts

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?

Link to comment
Share on other sites

  • Replies 26
  • Created
  • Last Reply

Top Posters In This Topic

  • GreenBee

    12

  • RICVBA

    7

  • BlackBox

    4

  • Tyke

    3

Top Posters In This Topic

Why are you reinventing the square wheel ? There is plenty of programs out there starting with CIV3D and others that are free.

 

....... 1+

Link to comment
Share on other sites

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+

Link to comment
Share on other sites

@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). :thumbsup:

 

Cheers

Link to comment
Share on other sites

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

Link to comment
Share on other sites

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

Link to comment
Share on other sites

(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.

Link to comment
Share on other sites

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

Link to comment
Share on other sites

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

Link to comment
Share on other sites

'<<<<<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

Link to comment
Share on other sites

        
'<<<<<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

Link to comment
Share on other sites

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

Link to comment
Share on other sites

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

Link to comment
Share on other sites

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.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.


×
×
  • Create New...