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

------------------------------------------------------------------------