please tell me.
A macro that saves assemblies and components to a specified folder.
I am in trouble because I cannot do it normally.
You can rename the assembly and components and save as usual.
However, when I open the saved assembly, the name of the component changes,but it still references the pre-saved component.
Works with flag = 3. Please try with SampleAssembly.
The save speed is also quite slow.
Please send me the corrected code to solve it. I would appreciate it if you could cooperate.
The environment is SolidWorks2020.
-----------Assembly & Component Save--------------------
Dim swApp As SldWorks.SldWorks
Dim swModelDoc As SldWorks.ModelDoc2
Dim swExt As SldWorks.ModelDocExtension
Dim Part As Object
Dim Assem As Object
Dim Doctype As Long
Public flag As Integer
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long
Sub main()
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
If swModel Is Nothing Then
MsgBox "ファイルが開かれてません"
Exit Sub
End If
Doctype = swModel.GetType
If Doctype = 1 Then
Set Part = swApp.ActiveDoc
ElseIf Doctype = 2 Then
UserForm1.Show
If flag = 4 Then
flag = 0
Exit Sub
End If
Set Assem = swApp.ActiveDoc
Else
MsgBox "部品orアセンブリファイルを選択下さい"
Exit Sub
End If
Dim objshell As Object
Dim objFolder As Object
Set objshell = CreateObject("Shell.Application")
Set objFolder = objshell.BrowseForFolder(0, "ファイルを含むフォルダーを選択してください。", 0, 0)
BrowseFolder = ""
If Not objFolder Is Nothing Then
BrowseFolder = objFolder.Self.Path
Else
Exit Sub
End If
Set objFolder = Nothing
Set objshell = Nothing
Dim rc As VbMsgBoxResult
rc = MsgBox("保存してもよろしいですか?", vbYesNoCancel + vbExclamation, "保存確認")
If rc <> vbYes Then
If (rc = vbNo) Or (rc = vbCancel) Then
MsgBox "キャンセルしました"
flag = 0
Exit Sub
End If
End If
If Doctype = 1 Then Set swExt = Part.Extension
If Doctype = 2 Then Set swExt = Assem.Extension
Dim swPropMgr As CustomPropertyManager
Dim ValOut As String
Dim rValOut As String
Dim fPath As String
Dim fPath1 As String
Dim pName As String
pName = "ファイル名"
Dim ValOut1 As String
Dim rValOut1 As String
Dim ValOut2 As String
Dim rValOut2 As String
Dim ValOut3 As String
Dim rValOut3 As String
Set swPropMgr = swExt.CustomPropertyManager("")
swPropMgr.Get2 pName, ValOut, rValOut
Dim config As Configuration
Set config = Assem.GetActiveConfiguration
Set swPropMgr = config.CustomPropertyManager
swPropMgr.Get2 "設備NO", ValOut1, rValOut1
swPropMgr.Get2 "部位記号", ValOut2, rValOut2
swPropMgr.Get2 "品番", ValOut3, rValOut3
If rValOut1 = "" Then
MsgBox "プロパティ設備NOが入力されてません" & vbCrLf & "入力後マクロ実行して下さい"
Exit Sub
End If
If rValOut2 = "" Then
MsgBox "プロパティ部位記号が入力されてません" & vbCrLf & "入力後マクロ実行して下さい"
Exit Sub
End If
If rValOut3 = "" Then
MsgBox "プロパティ品番が入力されてません" & vbCrLf & "入力後マクロ実行して下さい"
Exit Sub
End If
If Doctype = 1 Then fPath = BrowseFolder & "\" & rValOut & ".SLDPRT"
If Doctype = 2 Then
If flag = 1 Then fPath = BrowseFolder & "\" & rValOut & ".SLDASM"
If flag = 2 Then fPath = BrowseFolder & "\" & rValOut & ".SLDPRT"
'****************Code in trouble****************************************
If flag = 3 Then
fPath = BrowseFolder & "\" & rValOut
If Dir(fPath, vbDirectory) = "" Then 'フォルダがなければ作る
MkDir fPath
End If
fPath1 = fPath
fPath = fPath & "\" & rValOut
End If
End If
Dim Options As Long
Dim errors As Long
Dim warnings As Long
Options = 1
If flag = 1 Or flag = 2 Then
boolstatus = swExt.SaveAs(fPath, 0, Options, Nothing, errors, warnings)
Else
Dim swAssy As SldWorks.AssemblyDoc
Dim swConfig As SldWorks.Configuration
Dim swRootComp As SldWorks.Component
Dim Children As Variant
Dim swChild As SldWorks.Component
Dim ChildCount As Integer
Dim OldName As String
Dim NewName As String
Dim bOldSetting As Boolean
Dim bRet As Boolean
Dim i As Long
Dim i1 As Long
Set swApp = CreateObject("SldWorks.Application")
Set swAssy = swApp.ActiveDoc
Set swConfig = swAssy.GetActiveConfiguration
Set swRootComp = swConfig.GetRootComponent
bOldSetting = swApp.GetUserPreferenceToggle(swExtRefUpdateCompNames)
swApp.SetUserPreferenceToggle swExtRefUpdateCompNames, False
Children = swRootComp.GetChildren
ChildCount = UBound(Children)
i = 0
i1 = 1
For i = 0 To ChildCount
Set swChild = Children(i)
bRet = swChild.Select(False)
NewName = rValOut1 & rValOut2 & rValOut3 & "_part_" & i1
swChild.Name2 = NewName
NewName = fPath1 & "\" & NewName
boolstatus = swExt.SaveAs(NewName & ".SLDPRT", 0, Options, Nothing, errors, warnings)
i1 = i1 + 1
Next i
boolstatus = swExt.SaveAs(fPath & ".SLDASM", 0, Options, Nothing, errors, warnings)
End If
'**********************************************************************************
If boolstatus Then
MsgBox "保存に成功しました"
Else
MsgBox "保存に失敗しました"
End If
End Sub
-----------UserForm1.Show-------------
Private Sub UserForm_Initialize()
OptionButton1.Caption = "Assemblyのみ保存"
OptionButton2.Caption = "AssemblyをPartsとして保存"
OptionButton3.Caption = "AssemblyとPartsを同じフォルダに保存"
OptionButton1.Value = True
End Sub
Private Sub CommandButton1_Click()
If OptionButton1.Value = True Then
flag = 1
End If
If OptionButton2.Value = True Then
flag = 2
End If
If OptionButton3.Value = True Then
flag = 3
End If
Unload Me
End Sub
Private Sub CommandButton2_Click()
flag = 4
Unload Me
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
'Xボタンが押されたとき
If CloseMode = 0 Then
flag = 4
Unload Me
End If
End Sub
------------------------------------------------------------------------
SolidworksApi/macros