アクティブモデル（Partsファイル、Assemblyファイル）のファイル名を
プロパティユーザー定義情報の組合せにより自動生成し指定保存するマクロになります。

「Parts保存」、「AssemblyをPartsとして保存」、「Assemblyのみ保存」は、問題なく出来ますが、
「Assembly保存+参照Partsを保存」が外部参照がはずれる関係で求めていることが出来ません。

外部参照が外れる原因は、参照部品の名前をコードで操作変更したときに外れるようで、
リネームなども試しましたが、AssemblyのFutureManager上では、名前リネームされますが、
外部参照が外れる関係で部品を開くとリネーム前の名前で部品が開きます。（外部参照設定もコードで有効にしてますが駄目です）

当方が求めている内容としては、下記になります。

①「Assembly保存+参照Partsを保存」を選択
②参照Partsは、自動生成したフォルダにプレフィックス追加し保存
※数個ある部品が正常に保存される時と1個しか保存されない時がある（不安定）
③Assemblyファイルは選択したフォルダに保存（参照は外さない）
※まともに②部品が保存できても参照が外れAssembly選択フォルダに名前変更前の部品ファイルが保存される。

すでに数日悩んでますが、どうしたら正常実行可能か分かりません。。
どなたか解決頂けると非常に助かります。

悩んでいるコード抜粋します。

'Assemblyの構成部品を指定フォルダに保存
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)

'現在の構成部品名を読み込み
OldName = swChild.Name2

'外部参照有効化
swApp.SetUserPreferenceToggle swUserPreferenceToggle_e.swExtRefUpdateCompNames, True
swApp.SetUserPreferenceToggle swUserPreferenceToggle_e.swReferenceOnlyEnvelopeComponentType, False
swApp.SetUserPreferenceToggle swUserPreferenceToggle_e.swReferenceInContextOfTopLevelAssembly, False

'現在の構成部品名に設備NOを追加
NewName = rValOut1 & "_" & OldName

'構成部品名書込
swChild.Name2 = NewName

'Set Part = swApp.ActiveDoc
'boolstatus = Part.Extension.SelectByID2(rValOut, "COMPONENT", 0, 0, 0, False, 0, Nothing, 0)

'Rename
'longstatus = Part.Extension.RenameDocument(NewName)
'boolstatus = Part.ForceRebuild3(True)

'構成部品保存
NewName = fPath1 & "\" & NewName & ".SLDPRT"
fPath1 = NewName
boolstatus = swExt.SaveAs(fPath1, 0, Options, Nothing, errors, warnings)

i1 = i1 + 1

Next i

boolstatus = swAssy.ForceRebuild3(False)

'Assemblyを保存
fPath = BrowseFolder & "\" & rValOut & ".SLDASM"
boolstatus = swExt.SaveAs(fPath, 0, Options, Nothing, errors, warnings)

よろしくお願いします。

勉強になりました。情報提供ありがとうございます！

アセンブリパーツをパーツとして保存する場合は、部品種類ごとに作成してあるテンプレートを選択できるように
SW標準のテンプレート選択ウィンドウ表示し選択適用できるようにしました。

参考コード抜粋：
Dim Ptemp As String

'SW標準のテンプレート選択ウィンドウ表示
Ptemp = swApp.GetDocumentTemplate(swDocPART, "", 0, 0#, 0#)

'部品デフォルトテンプレートを選択テンプレートに設定
boolstatus = swApp.SetUserPreferenceStringValue(swUserPreferenceStringValue_e.swDefaultTemplatePart, Ptemp)

【システムオプション】→【デフォルトテンプレート】の設定は、
「ドキュメントのテンプレートを選択するようプロンプト表示」を選択にして下さい。

AssemblyファイルをPartsとして保存するときに「オプション」設定のデフォルトテンプレート（部品）が
適用されますが、これを指定して適用したい方法が不明です。

SW標準保存であれば、テンプレート選択ウィンドウが表示され選択可能なので、マクロ記録し試しましたが、
NewDocumentで指定した部品ファイルは開くが、モデルが保存されないです。

【SW標準保存記録コードAssemblyファイルをPartsとして保存】

Dim swApp As Object

Dim Part As Object
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long

Sub main()

Set swApp = Application.SldWorks

Set Part = swApp.ActiveDoc
boolstatus = swApp.SetUserPreferenceIntegerValue(swUserPreferenceIntegerValue_e.swSaveAssemblyAsPartOptions, swSaveAsmAsPartOptions_e.swSaveAsmAsPart_AllComponents)

' New Document
Dim swSheetWidth As Double
swSheetWidth = 0
Dim swSheetHeight As Double
swSheetHeight = 0
Set Part = swApp.NewDocument("指定テンプレート.prtdot", 0, swSheetWidth, swSheetHeight)
Dim swPart As PartDoc
Set swPart = Part
swApp.ActivateDoc2 "Part1", False, longstatus

"Part1"は、NewDocument実行した時点で、自動で割付され部品用指定テンプレートが開くが、
SW終了するまで、NewDocument実行するたび番号積算されるので、何番になるか毎回番号が
変わるので、実際は指定ができない。次番号が何番になるか確認し数字入れてはみましたが、
NewDocumentで開いた部品ファイルに保存されません。

Set Part = swApp.ActiveDoc
Set Part = swApp.ActiveDoc
Dim myModelView As Object
Set myModelView = Part.ActiveView
myModelView.FrameLeft = 0
myModelView.FrameTop = 0
Set myModelView = Part.ActiveView
myModelView.FrameState = swWindowState_e.swWindowMaximized
swApp.ActivateDoc2 "テスト用Assemblyモデル.SLDASM", False, longstatus
Set Part = swApp.ActiveDoc

' Save As
longstatus = Part.SaveAs3("ファイルパス.SLDPRT", 0, 2)
End Sub

何か方法あれば、教えて下さい。
よろしくお願いします。

AssemblyファイルをPartsとして保存するときに作成済みの部品用プロパティテンプレートを
適用したいのですが、方法がわかりません。今は勝手に違う部品用テンプレートが適用されてしまいます。

保存時に指定プロパティテンプレートを適用する方法を教えて下さい。
よろしくお願いします。

連休前に追加しておいた「一度保存したデータを違う設備で使い回す」は、多々あるので残しました。
  '取得した構成部品名の左(先頭)から4文字取得
  Dim ChangeName As String
  ChangeName = OldName
  ChangeName = Left(ChangeName, 4)
 
  '取得した構成部品の左4文字が数字だった場合実行
  If IsNumeric(ChangeName) = True Then
  OldName = Replace(OldName, ChangeName & "_", "")
  End If

あとは、サブアセンブリがあった場合の処理を頑張ります！

Instrやっと理解できました。今回のように詳しく教えて頂かないと、
すぐパンクするので手取り足取りで説明お願いします（笑）

たしかにこの方法であれば、Nextで回してるので、つけたいプレフィックス名で判断がつくことになります。

If InStr(取得名, プレフィックス名) = 0 Then
SaveAs実行

実行結果はすばらしい完璧です！これなら子番号に左右されず判定できますね。

AAAA<1>
AAAA<2>
※取得順は選べない
↓
OldName：AAAA-1　or　AAAA-2
Prefix：0000_
InStr (OldName, Prefix) = 0なので、SaveAs実行
↓
0000_AAAA-1<1>
0000_AAAA-1<2>
※SaveAsで同名部品書換られる
※取得順は選べない
↓
OldName：0000_AAAA-1-1　or　0000_AAAA-1-2
Prefix：0000_
InStr (OldName, Prefix) = 1なので、SaveAs未実行

すごくスッキリしました！
あとは、アセンブリにサブアセンブリがあった場合どうするか・・・う～ん。。。Zzzzzz

STEP BY STEPで１行ずつ見ていくと解りますが、SaveAsの行を実行すると、保存と同時に複数ある同じ構成部品の名前は一斉に変更されます。

なので”For　Next”なり”Do　While”なりの内側で次の名前を取得すると、同じ部品なら既に追加したい文字が付いていることになります。（だからここで再度同じ処理をすると文字の追加を繰り返してしまうのですね。）

ここで、InStr(取得した名前，追加したい文字）で判定すると戻り値は、既に追加したい文字が含まれていれば何番目かの数字になるので１以上、含まれていなければ０となって区別できることになります。（０の時だけ保存処理を実行）

保存の繰り返し処理の前に、現状の名前を取得して配列に入れておき、それに対して文字追加するという方法も可能ですが、この場合インスタンス数回、同名で上書き保存することなってわずらわしいですよね。

> PathName = Right(PathName, 1)

11個以上同じファイルがあるとだぶりそうです。
ちなみにぼくはファイル名を配列に入れて逐一チェックしようかとイメージしてたので
それよりはマシですね（笑）

> 【設備ハンディボックス用カールコード】設計に必要アルかナシかで言えば、ナシ

見てわかりやすいのはいろいろ気づくきっかけになるので大事だと思いますよ！
色もつけましょう！笑

<>番号1のインスタンスを削除・・確かにレアケースではありますが、無くはないですね。
さて、どうしましょう？少し考えます。明日からの3連休で記憶から消す可能性もありますが・・（笑）
アップサンプル画像の【元データ構成】から、同名参照部品が何個あるか見分ける
何かいい方法あれば、教えて頂けると助かります。

プレフィックスに関しては、表現が悪かったですね。.AddPrefix専用コード？で接頭につけていないです。
単純に取得した名前の先頭に4桁の設備NO,＆"_"をつけただけで、同じ部品であっても
設備ごとに名前を変えて保存してます。

理由としては、社内で部品ファイル共有できてなく基本個人プレーで、ファイルは設備ごとのフォルダ作り
共有ネットワークに保存してます。仮にAさんとBさんで同じアセンブリを使用しAさんが参照部品を変更した場合、
Bさんの部品も変更されてしまうので、設備ごとに違う設備番号をファイル名や参照部品名の先頭につけることで、
同じ部品であってもリンクしないようにしてます。なので、InStrでの判定はできないかと。。

ただ、一度保存したデータを違う設備で使用する場合、既に先頭に違う設備NO,がついているので
違う名前にしたいときに追加で違う設備NO,をつけることになり、0000_1111_・・・マクロ使うたび増えるので、
取得部品名の左4文字取得し数字だった場合は、一度消して新たな設備NO,をつけるようにしておきました。
ChangeName = swComp.Name2
ChangeName = Left(ChangeName, 4)
If IsNumeric(ChangeName) = True Then
OldName = Replace(OldName, ChangeName & "_", "")
End If

今回作ったマクロは毎回このマクロで保存する訳ではなく、プロパティ組合せた決まった形式で
ファイル名を自動でつけたい場合に使用することを大前提としているので、マクロで保存した後の
変更や追加後の保存は基本的にSW標準の保存を使用します。じゃないと複雑になりすぎるので・・・

なので、万人向けではありません。

一度構成部品を複数挿入・配置したけど、「やっぱりこれ要らんわ。」となって”－１”番目を削除していたら？という場合です。まあ、レアケースかもしれませんが無くはないということで。

InStrでの判定も、マクロ中のプレフィックス文字を付けるタイミングでの、「既に付いているか？」を見るので、その後の改定とはあまり関係ないかと思うのですが・・・。

また元々の名前に含まれている可能性についても、更に手間をかけると、プレフィックスなら文字の位置を特定することで識別は可能ですね。

＞業務の傍ら挑戦したところ業務以上にどっぷりハマってます。。。

わかります！私もうまくいかないと気になってしょうがないので、マクロは暇な時しか手を出さないようにしています。

可能性の話となりますが、複数ある構成部品の”－１”付きのインスタンスを削除したASSYの場合、追番が繰り上がっては振られないようのでその構成部品は保存されなくなりますね。

別の識別方法として、名前に追加するプレフィックス（サフィックス）が既に含まれているかを”InStr”の戻り値が０かどうかで判定する方法もアリかと思います。（元々の名前にもう含まれているとダメですが・・・）

更に言うと、構成部品にサブアセンブリが含まれている場合など、あらゆるパターンをカバーしようとすると悩みは尽きず、どんどん肥大化していくんですよね。

マクロの世界は奥が深いです。

  '現在の取得構成部品より追番取得
  Dim PathName As String
  PathName = swComp.Name2
  PathName = Right(PathName, 1)

  '追番が1の参照部品のみ保存対象
  If PathName = 1 Then

  '現在の構成部品名を読み込み
  Dim OldName As String
  OldName = swComp.Name2
    
  '追番置換（削除）
  OldName = Replace(OldName, -1, "")
  Debug.Print OldName
 
  '現在の構成部品名に設備NOを追加
  Dim NewName As String
  NewName = prefix & "_" & OldName
 
  '構成部品名書込
  swComp.Name2 = NewName
 
  NewName = saveFolderPath & "\" & NewName & ".SLDPRT"
  fPath = NewName
  Set swModel = swComp.GetModelDoc2
  Set swExt = swModel.Extension
  boolstatus = swExt.SaveAs(fPath, 0, 1, Nothing, errors, warnings)
 
  End If

これで、やっと完成できそうです！！

また、困った時は投稿させて頂きますので、よろしくお願いします。
ご協力頂き本当に有難う御座いました。

やはり、ファイル名からなんとかスキップさせる方法しかないですよね？
イミディエイト確認したところ参照部品取得した時点で、必ず部品名末尾にー追番がつくので、
追番取得しー１以外は保存しないようにする方向で考えてみます。

なにか方法あれば、教えて下さい。

【マクロ実行希望構成】構成部品7（同名2）、保存ファイル5（参照ファイル5）

そうなんですよね。
ファイル名チェックして，同名のファイルはスキップするとかでうまくいかないですかね。

提供頂いたサンプルマクロ「SaveViaVBA31」ですが、新規、既存ともに
問題なく名前変更し保存が出来ることを確認しました。私が求めていたことが出来てます。

ただ、初投稿前にも確認済みではありましたが、swRootComp.GetChildrenで
参照部品を取得すると同じ名前の参照部品がある場合、子ナンバー別に
全て取り込んでしまう為、同名の保存部品が１ファイルでいいところ
子ナンバー分、保存されてしまいます。

【元データ構成】構成部品7（同名2）、保存ファイル5（参照ファイル5）


【マクロ実行構成】構成部品7（同名2）、保存ファイル7（参照ファイル5）

【マクロ実行希望構成】構成部品7（同名2）、保存ファイル5（参照ファイル5）

また、サンプルマクロ「CopyViaVBA」ですが、保存済みアセンブリの参照ファイルリスト取得後に
名前を変更している関係で、子ナンバー別にファイル取得しません。ただし、参照ファイルリストは、
保存済みデータが無いと取得できないので、④が正常実行できなかったのは、フォルダの場所は関係なく
未保存データを新規保存（中間ファイル新規保存など）する関係で参照ファイルリスト取得しても
dependFilesListがTrueにならないことが、原因です。なので、④を「CopyViaVBA」で正常実行させるには、
名前変更前に一度保存する必要があります。（不要データが増えますが・・・）

新規、既存どちらでも使える「SaveViaVBA3」で、子ナンバー別保存さえなんとかなれば、
希望していたマクロになるのですが、難しいですかね？

ご面倒掛けますが、よろしくお願いします。

フォルダ決め打ちだとできました。

内容的に外部参照は関係なさそうなので(中間ファイルには外部参照ないので)
辻さん助言によりつくりなおしたSaveAsメソッド版をおいてます→サンプル

複数含まれてる部品のファイル名の変更がまだバグってますがサンプルにはなるかなと思います

ほんとは　保存ダイアログボックスを表示して選択するようなのを試してみたんですけど
それだとうまくいきませんでした。

>これを見ると，Assyを上書きはできても新規保存はできない，のかなと思うのですが，
そのとおりです。中間ファイル開き何も保存されていない状態から、アセンブリファイルと参照部品を
名前変更し新規保存するときにどうするべきか悩んでます。

よろしくお願いします。

> ③既存Assembly+参照Partsﾌｧｲﾙを指定ﾌｫﾙﾀﾞ+自動生成ﾌｫﾙﾀﾞに保存
> ④新規Assembly+参照Partsﾌｧｲﾙを指定ﾌｫﾙﾀﾞ+自動生成ﾌｫﾙﾀﾞに保存※悩み中です。。。

これを見ると，Assyを上書きはできても新規保存はできない，のかなと思うのですが，

ぼくがこちらにあげたサンプルでは，アセンブリもリネームして保存できてるので，
CopyDocumentメソッドを使って別名保存の例はできてるのかなと思ってます。

なお外部参照ついてなければ，辻さんの助言のもとSaveAsメソッドを使っても
アセンブリ＆部品ファイルを別名保存できました。このサンプルも必要ならあげます。

現在、ご教示頂いた内容を変数など、作成済みマクロで使えるように変更してます。

Pack and goのサンプルマクロは、APIに公開されてるのは知ってましたが、
既存ファイルを変更する場合は有効かと思いますが、メーカーよりダウンロードした中間ファイルなど、
開いて新規保存する前には、使用できないので他の方法を模索してました。

既存（保存済み）ファイルの場合は、提供頂いたマクロでなんとかなりそうです！！（コードあまり理解できてませんが(^_^;)・・・
メーカーなどから、ダウンロードした中間ファイルを開いて、ファイルプロパティ入力後に名前を変更し新規保存は、難しいでしょうか？
（元データは保存しない）現在作成中ではありますが、下記①～③に関しては、お力添え頂いた結果、成功してます。

①Assemblyﾌｧｲﾙのみ指定ﾌｫﾙﾀﾞに保存
②AssemblyﾌｧｲﾙをPartsﾌｧｲﾙとして指定ﾌｫﾙﾀﾞに保存
③既存Assembly+参照Partsﾌｧｲﾙを指定ﾌｫﾙﾀﾞ+自動生成ﾌｫﾙﾀﾞに保存
④新規Assembly+参照Partsﾌｧｲﾙを指定ﾌｫﾙﾀﾞ+自動生成ﾌｫﾙﾀﾞに保存※悩み中です。。。

途中までのマクロになります↓組み方は素人なのでツッコミどころ沢山あるかと・・（笑）

・UserForm1

Private Sub UserForm_Initialize()

OptionButton1.Caption = "Assemblyﾌｧｲﾙのみ指定ﾌｫﾙﾀﾞに保存"
OptionButton2.Caption = "AssemblyﾌｧｲﾙをPartsﾌｧｲﾙとして" & vbCrLf & "指定ﾌｫﾙﾀﾞに保存"
OptionButton3.Caption = "既存Assembly+参照Partsﾌｧｲﾙを" & vbCrLf & "指定ﾌｫﾙﾀﾞ+自動生成ﾌｫﾙﾀﾞに保存"
OptionButton4.Caption = "新規Assembly+参照Partsﾌｧｲﾙを" & vbCrLf & "指定ﾌｫﾙﾀﾞ+自動生成ﾌｫﾙﾀﾞに保存"
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

If OptionButton4.Value = True Then
flag = 4
End If

Unload Me

End Sub

Private Sub CommandButton2_Click()

flag = 5
Unload Me

End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)

'Xボタンが押されたとき

  If CloseMode = 0 Then
    flag = 5
    Unload Me
  End If

End Sub

・作成中マクロ

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


'Assembly保存方法選択画面
UserForm1.Show

If flag = 5 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
Dim PathName As String

Set objshell = CreateObject("Shell.Application")
Set objFolder = objshell.BrowseForFolder(0, "ファイルを含むフォルダーを選択してください。", 0, 0)
BrowseFolder = ""
If Not objFolder Is Nothing Then
BrowseFolder = objFolder.Self.Path

PathName = BrowseFolder
PathName = Right(PathName, 6)

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

'ModelDocExtensionに接続
'Dim swExt As ModelDocExtension

If Doctype = 1 Then Set swExt = Part.Extension

If Doctype = 2 Then Set swExt = Assem.Extension

'ユーザー定義プロパティを取得(API HELPで"ICustomPropertyManager"を参照)
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 '評価値
Dim ValOut4 As String '値/ﾃｷｽﾄ表現
Dim rValOut4 As String '評価値
Dim ValOut5 As String '値/ﾃｷｽﾄ表現
Dim rValOut5 As String '評価値
Dim ValOut6 As String '値/ﾃｷｽﾄ表現
Dim rValOut6 As String '評価値


'ユーザー定義プロパティを取得------------------------
Set swPropMgr = swExt.CustomPropertyManager("")

swPropMgr.Get2 pName, ValOut, rValOut

'コンフィギュレーション特有のプロパティを取得--------
Dim config As Configuration

If Doctype = 1 Then Set config = Part.GetActiveConfiguration
If Doctype = 2 Then Set config = Assem.GetActiveConfiguration
Set swPropMgr = config.CustomPropertyManager

swPropMgr.Get2 "設備NO", ValOut1, rValOut1
swPropMgr.Get2 "部位記号", ValOut2, rValOut2
swPropMgr.Get2 "品番", ValOut3, rValOut3
swPropMgr.Get2 "品名", ValOut4, rValOut4

If PathName = "supply" Then
swPropMgr.Get2 "型番", ValOut5, rValOut5
swPropMgr.Get2 "メーカー", ValOut6, rValOut6
End If

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 rValOut4 = "" Then
MsgBox "プロパティ品名が入力されてません" & vbCrLf & "入力後マクロ実行して下さい"
Exit Sub
End If

If PathName = "supply" Then
If rValOut5 = "" Then
MsgBox "プロパティ型番が入力されてません" & vbCrLf & "入力後マクロ実行して下さい"
Exit Sub
End If
If rValOut6 = "" Then
MsgBox "プロパティメーカーが入力されてません" & vbCrLf & "入力後マクロ実行して下さい"
Exit Sub
End If
End If

Dim fileNG As Integer
fileNG = 0
If InStr(rValOut, "\") > 0 Then fileNG = 1
If InStr(rValOut, "/") > 0 Then fileNG = 1
If InStr(rValOut, ":") > 0 Then fileNG = 1
If InStr(rValOut, "*") > 0 Then fileNG = 1
If InStr(rValOut, "?") > 0 Then fileNG = 1
If InStr(rValOut, """") > 0 Then fileNG = 1
If InStr(rValOut, "<") > 0 Then fileNG = 1
If InStr(rValOut, ">") > 0 Then fileNG = 1
If InStr(rValOut, "|") > 0 Then fileNG = 1
If InStr(rValOut, "[") > 0 Then fileNG = 1
If InStr(rValOut, "]") > 0 Then fileNG = 1
If fileNG = 1 Then
MsgBox "ファイル名に使用出来ない文字が含まれてます" & vbCrLf & "\ , / , : , * , ? , "" , < , > , | , [ , ]" & vbCrLf & "修正後マクロ実行して下さい"
fileNG = 0
Exit Sub
End If


'Parts保存
If Doctype = 1 Then fPath = BrowseFolder & "\" & rValOut & ".SLDPRT"

If Doctype = 2 Then

'Assemblyのみ保存

If flag = 1 Then fPath = BrowseFolder & "\" & rValOut & ".SLDASM"

'AssemblyをPartsとして保存

If flag = 2 Then fPath = BrowseFolder & "\" & rValOut & ".SLDPRT"

'Assemblyの参照Partsをフォルダに保存用のフォルダ作成

If flag = 3 Or flag = 4 Then
fPath = BrowseFolder & "\" & rValOut
If Dir(fPath, vbDirectory) = "" Then 'フォルダがなければ作る
MkDir fPath
End If
fPath1 = fPath
End If

End If

'指定保存(API HELPで"SaveAs Method (IModelDocExtension)"を参照)

Dim Options As Long
Dim errors As Long
Dim warnings As Long

'指定保存のオプション(API HELPで"swSaveAsOptions_e"を参照)
Options = 1

If Doctype = 1 Or flag = 1 Or flag = 2 Then

boolstatus = swExt.SaveAs(fPath, 0, Options, Nothing, errors, warnings)


'既存アセンブリファイルと参照部品を保存

ElseIf flag = 3 Then

    Dim Root3DModelPath As String
    
    Dim traverse As Boolean
    Dim search As Boolean
    Dim addreadonlyinfo As Boolean
    
    Dim dependFilesList As Variant
    Dim sourceFilesPath() As String
    Dim saveFilesPath() As String
    Dim i As Integer
    Dim j As Integer
    Dim copyopt As Long
    
    Root3DModelPath = swModel.GetPathName
    
    ' 参照関係があるファイルリストの取得
    ' 設定は公式Exampleをわけもわからずコピー (Copy_Document_and_Its_Dependencies_Example)
    traverse = True
    search = True
    addreadonlyinfo = False

    '参照関係があるファイルのリスト，だが，一ファイルあたり2つずつ要素がある(ファイル名とフルパス)
    dependFilesList = swApp.GetDocumentDependencies2(Root3DModelPath, traverse, search, addreadonlyinfo)
    If IsEmpty(dependFilesList) Then Exit Sub
   
    i = 1
    While i <= UBound(dependFilesList)

        ReDim Preserve sourceFilesPath(j)
        ReDim Preserve saveFilesPath(j)
   
        sourceFilesPath(j) = dependFilesList(i) 'フルパスのほう
        saveFilesPath(j) = fPath + "\" + rValOut1 + "_" + Right(sourceFilesPath(j), Len(sourceFilesPath(j)) - InStrRev(sourceFilesPath(j), "\"))
   
        j = j + 1
        i = i + 2
    Wend

    swApp.CloseAllDocuments True 'There can be no documents open when using this method(CopyDocument).
    
    fPath = BrowseFolder & "\" & rValOut & ".sldasm"
    copyopt = SwConst.swMoveCopyOptions_e.swMoveCopyOptionsOverwriteExistingDocs
    errors = swApp.CopyDocument(Root3DModelPath, fPath, (sourceFilesPath), (saveFilesPath), copyopt)

    If errors = 0 Then
    boolstatus = True
    Else
    boolstatus = False
    End If
    

'新規アセンブリファイルと参照部品を保存

Else

'考え中・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・

End If


If boolstatus Then
MsgBox "保存に成功しました"
Else
MsgBox "保存に失敗しました"
End If

End Sub

ぼくも同じ間違いしてました。

部品のModelDocExtentionからSaveAsを使うと

swModel = swComp.getModelDoc2
swExt = swModel.Extention

部品→アセンブリの順番で保存してるので，アセンブリ構造は（リネーム後のファイル名で）保持されてました。

しかし，部品→アセンブリの順番で保存してるので，
部品の中のアセンブリへの外部参照は切れてました（参照先が，リネーム前の親ファイルになっている）

> ”Pack and Go”をマクロで
Pack and goのリネームすごいめんどくさいから，マクロもめんどいんだろうな，と，
見てみたらPackAndGoオブジェクトとかあって笑いました。
意外と使いやすそうなので，エクセル連携とかすると汎用性高いかもしれないですね！

「構成部品保存」のときの"swExt"は各構成部品ドキュメントのエクステンションに定義されているでしょうか？

もしアセンブリのものだと、アセンブリを部品として保存することになりそうです。

その後の「Assemblyを保存」と同じなので気になりました。

また、リネームと構成部品のSaveAsを両方行っていますが、どちらか一方で良いのではないでしょうか？

リネームの場合はアセンブリ保存のSaveAsのオプションで"_SaveReferenced"も指定しておく必要があるかと思います。

いずれの場合も、複数のインスタンスをもつ構成部品があると名前を複数回変更してしまう恐れがあるので注意が必要です。（１つのインスタンスを変更すると、他のインスタンスも同時に変更されるため。）

アセンブリを構成ごとそっくりコピーするなら”Pack and Go”をマクロで使ってもいいかもしれませんね。

参考になるかわかりませんがぼくが実験で作ったマクロファイルも置いときます！→こちら