VBA限制乐筑天下 - Powered by Discuz! Archiver

RICVBA 发表于 2022-7-6 22:44:07

无论如何，如果你决定继续你的“轮子”，我很乐意尝试并帮助你的VBA代码（并获得相应的负面论坛数字！）

Tyke 发表于 2022-7-6 22:47:45

对不起，我不明白你的意思。你想详细说明一下吗？

BigAl所说的是正确的，你没有重新发明已经存在的东西，但如果你没有访问它的权限，其他工具不能满足你的需要，那么编写自己的模块是唯一的出路。在这方面，我认为如果可以的话，这里有足够多的人愿意提供帮助。

RICVBA 发表于 2022-7-6 22:52:11

很高兴见到你，泰克

我认为你可以做任何你感兴趣的事情。
这只是严格选择更有价值的东西的另一个角度。
但两者都有资格，这取决于你自己的需要。和倾向。

因此，比格尔的建议当然是公平的，如果绿蜂有兴趣以最少的努力（时间和金钱）获得特定的结果，他会遵循它。
如果GreenBee有兴趣开发一段VBA代码，以加深他在该特定方向上的对象/方法管理知识，并将其用于进一步的需要，他会选择自己开发一些代码。
在我明确支持的后一种情况下，这个论坛的人肯定会提供很大帮助。

最后，与比格尔和你的观点（我相信这里也有许多其他人的观点）相比，我的“（并因此获得负面论坛数字）”既是对我先验非实用主义观点的自我讽刺评论，也是一种确认我最初立场的方式，尽管随后出现了“嘘声”。

希望这样做

再见

GreenBee 发表于 2022-7-6 22:52:56

我必须承认RICVBA有道理。我的目的是看看在写一段代码时我能把我的知识（不是那么广博）推到多大程度，同时也要加快我的工作过程。
这是代码。我承认这可能会让人困惑，但这只是一个过程中的版本。用户输入两个变量，即道路宽度和横截面之间的距离，然后在屏幕上依次选择道路的第一个点、最后一个点和它们之间的所有路段。

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

GreenBee 发表于 2022-7-6 22:58:41

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

GreenBee 发表于 2022-7-6 23:01:51

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

GreenBee 发表于 2022-7-6 23:02:09

我知道它又长又乱，所以如果你们没有时间玩的话，我会理解的。

再见

RICVBA 发表于 2022-7-6 23:05:34

我自找的！这段代码非常简洁，因为它是用您的母语术语编写的，但如果您附加一个示例dwg（可能是您遇到问题的dwg），我会尝试一下。
再见

GreenBee 发表于 2022-7-6 23:09:03

我完全理解。这需要付出很大的努力才能让它变得有意义，我真的非常感谢你的帮助。

道路由直线、多段线和圆弧段组成。

这些评论是用克罗地亚语写的，如果你想翻译其中一些术语的话，这会有所帮助。然而，变量名没有多大意义，因为它们大多数是缩写。

再次感谢。
路图纸

BlackBox 发表于 2022-7-6 23:12:53

大声思考。。。VBA是否具有Visual LISP的vlax曲线*函数的等效项？

页: 1 [2]

乐筑天下's Archiver