Macro 2d de Verbinding van het Schetspunt

Out of category
1

Hoi allemaal

Ik wil een macro maken waarmee ik een bepaald aantal punten erin op een heel specifieke manier met elkaar kan verbinden: ik maak 2D-plattegronden van trappen.

Ik importeer momenteel alle punten (die in een Excel*-bestand staan met x y z coördinaten)  met behulp van een macro in een 2D-schets en verbind de punten vervolgens met de hand om de trap opnieuw te tekenen.

*excel bestand: 3 kolommen  X Y Z

 

punt A met punt B

Punt C met punt D

Punt A met Punt C

Punt B met Punt D

Enz. om elke stap te tekenen.

als ik VBA niet of heel weinig onder de knie had, zouden sommige liefdadige zielen me te hulp komen?

Hoe ik het zie: ik denk dat je in een 1e keer moet beginnen om alle trapneuzen, d.w.z. een paar steken, met elkaar te verbinden:

a-b; c-d; E-F; enz

verbind vervolgens elke kant van de stap A-C; B-D enz

elke trap heeft een verschillend aantal treden, ik moet een waarde kunnen invoeren om de macro aan het einde van X stappen te stoppen.

Elke stap wordt gedefinieerd door 2 punten

De rest van de punten in het Excel-bestand worden gebruikt voor oriëntatiepunten buiten de stappen zelf, zoals hoeken of muurretouren , deze punten worden met de hand verbonden...

Het idee is om deze functie  in mijn excel  bestand te zetten na de functie die de punten exporteert naar solidworks 

Ik vind het niet heel ingewikkeld, maar ik beheers het programmeren niet. Het is beter om er een te hebben die het weet dan 10 die kijken zoals de ander zei...  

Hier! Als je vragen hebt, sta ik tot je beschikking!

 

Hier is de huidige code:

Privé Sub btnTest_Click()
 Dim swApp als SldWorks.SldWorks
    Dim deel als ModelDoc2
    Dim i als geheel getal

    Stel swApp = CreateObject("SldWorks.Application") in
    Deel instellen = swApp.ActiveDoc
    Als een deel niets is, dan
        MsgBox "Activeer a.u.b. een deeldocument voordat u deze macro gebruikt."
        Sub afsluiten
    Einde als
    Als Part.GetType <> 1 dan
        MsgBox "Activeer a.u.b. een deeldocument voordat u deze macro gebruikt."
        Sub afsluiten
    Einde als
    zo niet Part.GetActiveSketch2 is dan niets
        MsgBox "Sluit de schets af voordat u deze macro uitvoert."
        Sub afsluiten
    Einde als

    Deel.ClearSelection2 Waar
    Deel.InsertSketch
    Part.SetAddToDB Waar

    i = 1
    Terwijl Bereik ("A" & i). Waarde <> ""
        Part.CreatePoint2 Bereik ("A" & i). Waarde / 100, bereik ("B" & i). Waarde / 100, 0
        'Part.CreatePoint2 Range("A" & i). Waarde / 1000, Bereik ("B" & i). Waarde / 1000, Bereik ("C" & i). Waarde / 1000
        i = ik + 1
    Gaan

    Part.SetAddToDB onwaar
    Deel.ClearSelection
    Deel.InsertSketch
    Deel.ClearSelection2 Waar
Einde Sub

Hartelijk dank voor uw medewerking

Vallei

2

Hallo. Probeer het volgende:

Let op: hiermee wordt een 3D-schets gemaakt. Als u een 2D-schets wilt maken , verwijdert u de insert3Dsketch-lijnen, de aanhalingstekens van de InsertSketch-regels en vervangt u de termen Range("C") door 0. Aan de andere kant lijkt het mij dat je in dit geval een plan moet selecteren met de regel SelectByID2.

Ik ging ervan uit dat je de punten niet nodig hebt. Anders zet je de while-lus  er weer op.

Private Sub btnTest_Click()
    Dim swApp As SldWorks.SldWorks
    Dim Part As SldWorks.ModelDoc2
    Dim skSegment As SldWorks.SketchSegment
    Dim i As Integer
    Dim j As Integer
    Dim boolstatus As Boolean

    Set swApp = CreateObject("SldWorks.Application")
    Set Part = swApp.ActiveDoc
    If Part Is Nothing Then
        MsgBox "Please activate a part document before using this macro."
        Exit Sub
    End If
    If Part.GetType <> 1 Then
        MsgBox "Please activate a part document before using this macro."
        Exit Sub
    End If
    If Not Part.GetActiveSketch2 Is Nothing Then
        MsgBox "Please exit the sketch before running this macro."
        Exit Sub
    End If

    Part.ClearSelection2 True
    'boolstatus = Part.Extension.SelectByID2("Front Plane", "PLANE", 0, 0, 0, False, 0, Nothing, 0)
    'Part.InsertSketch
    Part.SketchManager.Insert3DSketch True
    Part.SetAddToDB True

    i = 1
    While Range("A" & i).Value <> ""
        j = i + 1
        If i Mod 4 = 0 Then j = i - 3
        Set skSegment = Part.SketchManager.CreateLine(Range("A" & i).Value / 1000, Range("B" & i).Value / 1000,  Range("C" & i).Value / 1000, Range("A" & j).Value / 1000, Range("B" & j).Value / 1000,  Range("C" & j).Value / 1000)
        i = i + 1
    Wend

    Part.SetAddToDB False
    'Part.InsertSketch
    Part.SketchManager.Insert3DSketch True
    Part.ClearSelection2 True
End Sub

 

2 likes
3

Goedenavond  Hiëronymus, 

Ik wil u bedanken voor uw betrokkenheid bij het oplossen van mijn probleem en ik wil me verontschuldigen voor mijn late terugkeer.

Ik heb geen melding of e-mail ontvangen, ik kwam hier terug uit nieuwsgierigheid en de verrassing dat een liefdadige ziel me antwoordde!

Ik zal dit zo snel mogelijk testen en je feedback geven!

Bedankt