| |
| Gut zu wissen: Hilfreiche Tipps und Tricks aus der Praxis prägnant, und auf den Punkt gebracht für SOLIDWORKS |
| |
| FMB |
Autor
|
Thema: Mehrere Teile in Baugruppe mit Makro einfügen (2278 mal gelesen)
|
AndreasBo Mitglied TZ & Konstruktion
Beiträge: 861 Registriert: 16.11.2006 ******** Wenn am Anfang alles schief geht, nenne es Version 1.0!
|
erstellt am: 07. Aug. 2014 21:44 <-- editieren / zitieren --> Unities abgeben:
|
Rigobert Mitglied Konstrukteur
Beiträge: 239 Registriert: 21.11.2001 SWX 2017x64-Edition SP 4.1
|
erstellt am: 08. Aug. 2014 07:12 <-- editieren / zitieren --> Unities abgeben: Nur für AndreasBo
Hallo, Ich habe es in einem meiner Makros so gelöst: Dim SWX As SldWorks.SldWorks Dim Baugruppe As SldWorks.AssemblyDoc Dim Einfuegematrix(0 To 15) As Double
SWX = GetObject(, "Sldworks.Application") Baugruppe = SWX.INewAssembly Einfuegematrix(0) = 1 : Einfuegematrix(1) = 0 : Einfuegematrix(2) = 0 : Einfuegematrix(3) = 0 Einfuegematrix(4) = 1 : Einfuegematrix(5) = 0 : Einfuegematrix(6) = 0 : Einfuegematrix(7) = 0 Einfuegematrix(8) = 1 : Einfuegematrix(9) = 0 : Einfuegematrix(10) = 0 : Einfuegematrix(11) = 0 Einfuegematrix(12) = 0 : Einfuegematrix(13) = 0 : Einfuegematrix(14) = 0 : Einfuegematrix(15) = 0 ReDim Compnames(0) Compnames(0) = My.Settings.temporary_Data & "\Partname.sldprt" Baugruppe.AddComponents(Compnames, Einfuegematrix) hoffe es hilft weiter
------------------ Gruß Andreas Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
AndreasBo Mitglied TZ & Konstruktion
Beiträge: 861 Registriert: 16.11.2006 ******** Wenn am Anfang alles schief geht, nenne es Version 1.0!
|
erstellt am: 08. Aug. 2014 07:54 <-- editieren / zitieren --> Unities abgeben:
Zitat: Original erstellt von Rigobert: Hallo,Ich habe es in einem meiner Makros so gelöst: ... hoffe es hilft weiter
Leider nicht wirklich. Es wirft nur mehr Fragen auf, wenn man so wie ich nicht so tief in der Makromaterie drinn steckt. Vieleicht hat jemand schon ein fertiges Makro dafür? ------------------ Gruß AndreasBo Ich nutze alte Boardsuche | Google | Netiquette | Wie stellt man Fragen richtig? | Systeminfo ******** SolidWorks 2014 SP4 | Alibre Design 2012 ******** IntelXeon CPU E5-1620 | @ 3,60 GHz | Windows 7 64 BIT | 32GB RAM | NVIDIA Quadro 4000 | Samsung SyncMaster 24" Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
Lutz Federbusch Ehrenmitglied V.I.P. h.c. Dipl.-Ing. Maschinenbau
Beiträge: 3094 Registriert: 03.12.2001 alle SW seit 97+ AutoCAD2016-2022 ERP ProAlpha + CA-Link Intel Core i7-7820K 32GB Win10x64 Quadro K5000 SpacePilot
|
erstellt am: 08. Aug. 2014 08:52 <-- editieren / zitieren --> Unities abgeben: Nur für AndreasBo
|
nahe Ehrenmitglied
Beiträge: 1747 Registriert: 18.01.2001 arbeite mit: Dell Precision 7750 i7 2,6 GHz 6 Kerne 32GB RAM 512GB SSD NVIDIA Quadro RTX 4000 ------------------------ SWX-2020 SP5.0 EPDM ---------------- Windows 10 ---------------- VB.net VB VBA ein wenig Swift am Mac
|
erstellt am: 08. Aug. 2014 09:04 <-- editieren / zitieren --> Unities abgeben: Nur für AndreasBo
Hallo Andreas vielleicht hilft Dir das weiter Option Explicit Sub insert() Dim swapp As SldWorks.SldWorks Dim ass As AssemblyDoc Dim swMathUtil As MathUtility Dim swxform As MathTransform Dim modeldoc As ModelDoc2 Dim pa() As Component2 Dim errors As Long Dim warnings As Long Dim tmpObj() As SldWorks.ModelDoc2 Dim assemblytitle As String Dim teile() As String Dim i As Integer Dim pfad As String Dim name1 As String pfad = BrowseForFolder("C:\") i = 0 name1 = Dir(pfad & "\*.SLDPRT", vbNormal) Do While name1 <> "" If name1 <> "." And name1 <> ".." Then If (GetAttr(pfad & "\" & name1) And vbDirectory) <> vbDirectory Then If i = 0 Then ReDim teile(i) Else ReDim Preserve teile(i) End If teile(i) = pfad & "\" & name1 i = i + 1 End If End If name1 = Dir Loop ReDim pa(i - 1) ReDim tmpObj(i - 1) Set swapp = Application.SldWorks Set modeldoc = swapp.ActiveDoc assemblytitle = modeldoc.GetTitle Set ass = modeldoc '** Alle Teile öffnen For i = 0 To UBound(teile) Set tmpObj(i) = swapp.OpenDoc6(teile(i), swDocPART, 0, "", errors, warnings) Next i '** Zurück zur Baugruppe Set modeldoc = swapp.ActivateDoc3(assemblytitle, True, swUserDecision, errors) Set ass = modeldoc '** Teile einfügen und zum Ursprung verschieben For i = 0 To UBound(teile) Set pa(i) = ass.AddComponent5(teile(i), swAddComponentConfigOptions_CurrentSelectedConfig, "", False, "", -1, -1, -1) Set swMathUtil = swapp.GetMathUtility Set swxform = swMathUtil.CreateTransform(Nothing) ' create unit transform pa(i).Transform2 = swxform Next i End Sub Function BrowseForFolder(Optional OpenAt As Variant) As Variant 'Function purpose: To Browser for a user selected folder. 'If the "OpenAt" path is provided, open the browser at that directory 'NOTE: If invalid, it will open at the Desktop level Dim ShellApp As Object 'Create a file browser window at the default folder Set ShellApp = CreateObject("Shell.Application"). _ BrowseForFolder(0, "Please choose a folder", 0, OpenAt) 'Set the folder to that selected. (On error in case cancelled) On Error Resume Next BrowseForFolder = ShellApp.self.Path On Error GoTo 0 'Destroy the Shell Application Set ShellApp = Nothing 'Check for invalid or non-entries and send to the Invalid error 'handler if found 'Valid selections can begin L: (where L is a letter) or '\\ (as in \\servername\sharename. All others are invalid Select Case Mid(BrowseForFolder, 2, 1) Case Is = ":" If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid Case Is = "\" If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid Case Else GoTo Invalid End Select Exit Function Invalid: 'If it was determined that the selection was invalid, set to False BrowseForFolder = False End Function ------------------ Grüße Heinz Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
AndreasBo Mitglied TZ & Konstruktion
Beiträge: 861 Registriert: 16.11.2006 ******** Wenn am Anfang alles schief geht, nenne es Version 1.0!
|
erstellt am: 08. Aug. 2014 09:08 <-- editieren / zitieren --> Unities abgeben:
Zitat: Original erstellt von Lutz Federbusch: Das fertige Makro könntest Du, wenn Du Dich mal in die API-Hilfe bemüht hättest, längst gefunden haben. Da gibt es ein fertiges Beispiel...
Wenn man nicht weiter weiß, sucht man ja in Foren und es wäre nett wenn du mir noch sagst wonach ich da suchen soll? Danke!! @ Nahe: Vielen Dank. Es Funktioniert, wenn die 3D-Teile Fehlerfrei sind aber damit kann ich leben. ------------------ Gruß AndreasBo Ich nutze alte Boardsuche | Google | Netiquette | Wie stellt man Fragen richtig? | Systeminfo ******** SolidWorks 2014 SP4 | Alibre Design 2012 ******** IntelXeon CPU E5-1620 | @ 3,60 GHz | Windows 7 64 BIT | 32GB RAM | NVIDIA Quadro 4000 | Samsung SyncMaster 24" [Diese Nachricht wurde von AndreasBo am 08. Aug. 2014 editiert.] Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
Lutz Federbusch Ehrenmitglied V.I.P. h.c. Dipl.-Ing. Maschinenbau
Beiträge: 3094 Registriert: 03.12.2001 alle SW seit 97+ AutoCAD2016-2022 ERP ProAlpha + CA-Link Intel Core i7-7820K 32GB Win10x64 Quadro K5000 SpacePilot
|
erstellt am: 08. Aug. 2014 09:33 <-- editieren / zitieren --> Unities abgeben: Nur für AndreasBo
|
KMassler Ehrenmitglied V.I.P. h.c. CAD Admin + Mädchen für Alles...
Beiträge: 2675 Registriert: 06.11.2000 SolidWorks Start 1999 ** CSWP 01/2008 ** ------------------ Zuletzt beruflich: - SWX2020 SP5; - SAP/PLM+ECTR; - DriveWorks Pro; - Programmierung: VBA, aktuell Visual Studio 2022/VB.Net ------------------ ab 2024 (privat): Onshape und anderes
|
erstellt am: 08. Aug. 2014 09:43 <-- editieren / zitieren --> Unities abgeben: Nur für AndreasBo
Will mal nicht so sein Code:
Dim swApp As SldWorks.SldWorks Dim Baugruppe As SldWorks.AssemblyDoc Dim Part As SldWorks.PartDoc Dim swcomponent As SldWorks.Component2Dim boolstatus As Boolean Dim longstatus As Long, longwarnings As Long Dim Pfad As String Dim Dateiname As String Dim Pfadname As String Dim errors As Long Dim warnings As Long Dim n As Integer Sub main() Set swApp = _ Application.SldWorks Pfad = InputBox("Bitte den Ordner angeben:", "Ordnerauswahl", "C:\SW-WORK\MoveTo-TEST") If Pfad = "" Then Exit Sub Set Baugruppe = swApp.INewAssembly Dateiname = Dir(Pfad & "\*.sldprt") 'n = 0 Do While Dateiname <> "" Pfadname = Pfad & "\" & Dateiname Debug.Print Pfadname Set Part = Nothing Set Part = swApp.OpenDoc6(Pfadname, swDocPART, 0, "", errors, warnings) If Not Part Is Nothing Then Set swcomponent = Baugruppe.AddComponent5(Pfadname, 0, "", False, "", 0, 0, 0) End If swApp.CloseDoc (Dateiname) Dateiname = Dir() ' n = n + 1 ' If n > 3 Then Exit Do Loop End Sub
[Edit]Die Zeilen mit der Variablen n habe ich jetzt auskommentiert, das war nur um die Laufzeit beim Testen zu begrenzen. Du kannst es natürlich auch sicherheitshalber drin lassen und auf einen vernünftigen Wert setzen, falls du das Makro mal auf ein Verzeichnis mit megavielen Parts los lässt.[/Edit] Für weitergehende Infos, z.B. zum Einfügen von Verknüpfungen etc. beherzige bitte Lutz' Rat. Suche in der API-Hilfe mal nach "Add Component and Mate Example"- da hab ich meine Weisheit auch her. ------------------ Klaus www.al-ko.com | mein Gästebuch [Diese Nachricht wurde von KMassler am 11. Aug. 2014 editiert.] Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
AndreasBo Mitglied TZ & Konstruktion
Beiträge: 861 Registriert: 16.11.2006 ******** Wenn am Anfang alles schief geht, nenne es Version 1.0!
|
erstellt am: 08. Aug. 2014 10:17 <-- editieren / zitieren --> Unities abgeben:
|
Locke79 Mitglied Arbeitsvorbereitung
Beiträge: 12 Registriert: 08.03.2022
|
erstellt am: 08. Mrz. 2022 10:01 <-- editieren / zitieren --> Unities abgeben: Nur für AndreasBo
Hallo Klaus, dies ist ein super Makro, allerdings setzt dieses Makro alle Teile in den Baugruppen Urspung. Kann man das auch irgendwie umschreiben das die Teil Urspünge auf den Baugruppen Ursprung ausgerichtet werden? Wäre für eure Unterstützung sehr dankbar. Grüße Locke Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |