Makro Łącze punktowe szkicu 2D

Out of category
1

Cze wszystkim

Chcę zrobić makro, które pozwoli mi połączyć w nich pewną liczbę punktów w bardzo specyficzny sposób: Tworzę plany 2D schodów.

Obecnie importuję wszystkie punkty (które znajdują się w pliku Excel* ze współrzędnymi x, y, z) za pomocą makra w szkicu 2D,  a następnie łączę punkty ręcznie w celu przerysowania schodów.

*plik excel: 3 kolumny  X, Y, Z

 

punkt A z punktem B

Punkt C z punktem D

Punkt A z punktem C

Punkt B z punktem D

Itp., aby narysować każdy krok.

nie opanowując VBA lub bardzo mało, czy jakieś dobroczynne dusze przyjdą mi z pomocą?

Jak ja to widzę: Myślę, że trzeba zacząć za 1 raz, aby połączyć wszystkie noski schodowe, czyli parę ściegów:

a-b; c-d; e-f; itd

następnie połącz każdą stronę stopnia A-C; B-D itp

każda klatka schodowa ma inną liczbę kroków, muszę być w stanie wprowadzić wartość, aby zatrzymać makro na końcu X kroków.

Każdy krok jest zdefiniowany przez 2 punkty

Reszta punktów w pliku Excel jest używana do punktów orientacyjnych poza samymi stopniami, takich jak narożniki lub wyłukowania ścian , punkty te zostaną połączone ręcznie...

Chodzi o to, aby umieścić tę funkcję  w moim pliku Excela  po funkcji, która eksportuje punkty do solidworks 

Myślę, że nie jest to bardzo skomplikowane, ale nie jestem mistrzem programowania. Lepiej mieć jednego , który wie, niż 10, którzy patrzą tak, jak powiedział drugi...  

Tu! W razie jakichkolwiek pytań jestem do Państwa dyspozycji!

 

Oto aktualny kod:

Prywatny Sub btnTest_Click()
 Dim swApp jako SldWorks.SldWorks
    Przyciemnij część jako ModelDoc2
    Dim i jako liczba całkowita

    Ustaw swApp = CreateObject("SldWorks.Application")
    Ustaw część = swApp.ActiveDoc
    Jeśli część jest niczym, to
        MsgBox "Proszę aktywować dokument części przed użyciem tego makra."
        Wyjdź z subwoofera
    Zakończ jeżeli:
    Jeśli Part.GetType <> 1, to
        MsgBox "Proszę aktywować dokument części przed użyciem tego makra."
        Wyjdź z subwoofera
    Zakończ jeżeli:
    Jeśli nie Part.GetActiveSketch2 to nic to
        MsgBox "Proszę wyjść ze szkicu przed uruchomieniem tego makra."
        Wyjdź z subwoofera
    Zakończ jeżeli:

    Part.ClearSelection2 Prawda
    Part.InsertSketch
    Part.SetAddToDB Prawda

    i = 1
    While Range("A" & i). Wartość <> ""
        Zakres: Part.CreatePoint2 ("A" & i). Wartość / 100, Zakres("B" & i). Wartość / 100, 0
        'Part.CreatePoint2 Range("A" & i). Wartość / 1000, Zakres("B" & i). Wartość / 1000, zakres ("C" i i). Wartość / 1000
        i = i + 1
    Wend

    Part.SetAddToDB Fałsz
    Part.ClearSelection
    Part.InsertSketch
    Part.ClearSelection2 Prawda
Koniec subwoofera

Dziękujemy za współpracę

Dolina

2

Witam. Spróbuj tego:

Uwaga: spowoduje to utworzenie szkicu 3D. Jeśli chcesz utworzyć szkic 2D, usuń linie insert3Dsketch, znaki cudzysłowu z linii InsertSketch i zastąp warunki Range("C") wartością 0. Z drugiej strony wydaje mi się, że w tym przypadku trzeba wybrać plan z linią SelectByID2.

Wyszedłem z założenia, że punkty nie są potrzebne. W przeciwnym razie włącz ponownie pętlę while.

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 polubienia
3

Dobry wieczór  Hieronim, 

Chciałbym podziękować za zaangażowanie w rozwiązanie mojego problemu i przepraszam za mój spóźniony powrót.

Nie otrzymałem żadnego powiadomienia ani e-maila, wróciłem tu z ciekawości i niespodzianka odpowiedziała mi charytatywna dusza!

Przetestuję to tak szybko, jak to możliwe i przekażę Ci opinię!

Dziękuję