SWJUG-RING

SOLIDWORKS Japan User Group 公式コミュニティサイト

山本さん

いつもお世話になってます。

本件、システムオプションの『構成部品の名前変更を有効化』はONになってました。

ちなみに確認ダイアログもメッセージ閉じていたので、表示させるようにしてみましたが、現象変わらずでした。

とりあえずAPIヘルプ確認してみますね（これだけ英語版のみなので、知りたい情報探すだけでも苦労しますが・・・）

なにか分かれば、また教えていただけると幸いです。

よろしくお願いします。

『構成部品の名前変更を有効化』がONになってたとしたら、OFFにしてみてどうなるか確認できますかね。
この機能の追加で、ツリー上で名前を変更すると、ファイル名自身を変更できるようになったので、
その辺りが影響しているのかと。

あとは、変数定義時(Dim)のところで、最新のクラス（インターフェース）に変えてあげるとうまくいく事もあるかもしれません。（新しいメソッドで対応できるなど）
例えば、Dim swRootComp As SldWorks.Component の場合、
Component2 という新しいクラスがあるので変えてみるとか。
ただ、メソッドが変わってたり、引数増えてたりなどで、修正が大変だったりもします。

すみません。ChatGPTに丸投げし修正してもらいました。
恐ろしい時代ですね。。数回のやりとりで脆弱箇所含め
2026版APIに修正できました。

褒めた後のチャッピー返答と修正マクロです。

やりましたね…！
これはかなり厄介なSOLIDWORKS2026移行問題でした。

特に今回ハマっていたのは、

• FileCopy 不可
• ReplaceComponents2 不安定
• Name2 が実質使えない
• SaveAs の仕様変更
• swComp が置換後に無効化
• 軽量モード問題

この辺が全部同時発生していたので、2021コードが2026で壊れる典型パターンでした。

最終的に安定したポイントは：

SaveAs3 + swSaveAsOptions_Copy
↓
Select4
↓
ReplaceComponents
↓
swComp再取得
↓
RenameDocument
↓
Rebuild

この順番です。

これで2026系でもかなり安定します。

あと今後もし機能追加するなら、
次に問題になりやすいのは：

• 仮想部品
• Toolbox部品
• SpeedPak
• 抑制部品
• サブアセンブリ再帰
• 図面参照更新

この辺です。

特にサブアセンブリ対応するなら、
今の GetChildren 1階層だけでは不足するので、
再帰処理化するとかなり強いマクロになります。

以下、修正マクロです

Dim swApp               As SldWorks.SldWorks
Dim swModel             As SldWorks.ModelDoc2
Dim swModelDoc          As SldWorks.ModelDoc2
Dim swExt               As SldWorks.ModelDocExtension

Dim Part                As SldWorks.ModelDoc2
Dim Assem               As SldWorks.ModelDoc2

Dim Doctype             As Long
Public flag             As Integer
Dim boolstatus          As Boolean
Dim longstatus          As Long
Dim longwarnings        As Long

Sub main()

    On Error GoTo ERR_HANDLER

    '==========================================
    ' 初期化
    '==========================================

    flag = 0

    Set swModel = Nothing
    Set swExt = Nothing
    Set Part = Nothing
    Set Assem = Nothing

    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc

    If swModel Is Nothing Then

        MsgBox "ﾌｧｲﾙが開かれてません" & vbCrLf & _
               "ファイルを開きマクロ実行して下さい", vbCritical

        Exit Sub

    End If

    Doctype = swModel.GetType

    If Doctype = swDocPART Then

        Set Part = swModel

    ElseIf Doctype = swDocASSEMBLY Then

        UserForm1.Show

        If flag = 5 Then

            flag = 0

            MsgBox "最初からやり直して下さい", vbInformation

            Exit Sub

        End If

        Set Assem = swModel

    Else

        MsgBox "部品orｱｾﾝﾌﾞﾘﾌｧｲﾙを選択して下さい" & vbCrLf & _
               "選択後マクロ実行して下さい", vbInformation

        Exit Sub

    End If

    '==================================================
    ' 保存先選択
    '==================================================

    Dim objshell       As Object
    Dim objFolder      As Object
    Dim BrowseFolder   As String
    Dim PathName       As String

    Set objshell = CreateObject("Shell.Application")

    Set objFolder = objshell.BrowseForFolder( _
                    0, _
                    "保存先フォルダを選択してください。", _
                    &H1, _
                    0)

    If objFolder Is Nothing Then

        MsgBox "キャンセルしました", vbInformation

        GoTo FINISH

    End If

    BrowseFolder = objFolder.Self.Path

    Set objFolder = Nothing
    Set objshell = Nothing

    PathName = Right(BrowseFolder, 6)

    '==================================================
    ' 保存確認
    '==================================================

    Dim rc As VbMsgBoxResult

    rc = MsgBox("保存してもよろしいですか？", _
                vbYesNoCancel + vbInformation, _
                "保存確認")

    If rc <> vbYes Then

        MsgBox "キャンセルしました", vbInformation

        GoTo FINISH

    End If

    '==================================================
    ' Extension取得
    '==================================================

    If Doctype = swDocPART Then
        Set swExt = Part.Extension
    Else
        Set swExt = Assem.Extension
    End If

    '==================================================
    ' プロパティ取得
    '==================================================

    Dim swPropMgr      As CustomPropertyManager
    Dim config         As Configuration

    Dim ValOut         As String
    Dim rValOut        As String

    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 "ファイル名", ValOut, rValOut

    If Doctype = swDocPART Then
        Set config = Part.GetActiveConfiguration
    Else
        Set config = Assem.GetActiveConfiguration
    End If

    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が入力されてません"
        GoTo FINISH
    End If

    If rValOut2 = "" Then
        MsgBox "プロパティ部位記号が入力されてません"
        GoTo FINISH
    End If

    If rValOut3 = "" Then
        MsgBox "プロパティ品番が入力されてません"
        GoTo FINISH
    End If

    If rValOut4 = "" Then
        MsgBox "プロパティ品名が入力されてません"
        GoTo FINISH
    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 fileNG = 1 Then

        MsgBox "ファイル名に使用出来ない文字が含まれてます"

        GoTo FINISH

    End If

    '==================================================
    ' 保存処理
    '==================================================

    Dim fPath      As String
    Dim fPath1     As String

    If Doctype = swDocPART Then

        fPath = BrowseFolder & "\" & rValOut & ".SLDPRT"

        SAVE_DOCUMENT swModel, fPath

    Else

        Select Case flag

            Case 1

                fPath = BrowseFolder & "\" & rValOut & ".SLDASM"

                SAVE_DOCUMENT swModel, fPath

            Case 2

                fPath = BrowseFolder & "\" & rValOut & ".SLDPRT"

                SAVE_AS_PART swModel, fPath

            Case 3

                fPath1 = BrowseFolder & "\" & rValOut

                If Dir(fPath1, vbDirectory) = "" Then
                    MkDir fPath1
                End If

                SAVE_WITH_PREFIX _
                    swModel, _
                    fPath1, _
                    BrowseFolder, _
                    rValOut, _
                    rValOut1, _
                    rValOut2

        End Select

    End If

    MsgBox "保存完了", vbInformation

    GoTo FINISH

'==================================================
' エラー
'==================================================

ERR_HANDLER:

    MsgBox "エラー発生" & vbCrLf & _
           Err.Number & vbCrLf & _
           Err.Description, vbCritical

FINISH:

    On Error Resume Next

    If Not swModel Is Nothing Then

        swModel.ClearSelection2 True

        swModel.ForceRebuild3 False

        swModel.GraphicsRedraw2

        DoEvents

    End If

    swApp.CommandInProgress = False

    flag = 0

    Doctype = 0

    boolstatus = False

    longstatus = 0
    longwarnings = 0

    Set swExt = Nothing

    Set Part = Nothing
    Set Assem = Nothing

    Set swModelDoc = Nothing
    Set swModel = Nothing

    Set swApp = Nothing

    DoEvents

    On Error GoTo 0

End Sub

'==================================================
' SaveAs3 共通
'==================================================

Private Sub SAVE_DOCUMENT( _
                ByVal mdl As ModelDoc2, _
                ByVal savePath As String)

    Dim swExt           As ModelDocExtension
    Dim errors          As Long
    Dim warnings        As Long
    Dim ret             As Boolean

    Set swExt = mdl.Extension

    mdl.ForceRebuild3 False

    ret = swExt.SaveAs3( _
                savePath, _
                swSaveAsCurrentVersion, _
                swSaveAsOptions_Silent, _
                Nothing, _
                Nothing, _
                errors, _
                warnings)

    If ret = False Then

        MsgBox "保存失敗" & vbCrLf & _
               "Error:" & errors & vbCrLf & _
               "Warning:" & warnings, vbCritical

    End If

End Sub

'==================================================
' Assembly → Part
'==================================================

Private Sub SAVE_AS_PART( _
                ByVal mdl As ModelDoc2, _
                ByVal savePath As String)

    Dim errors As Long
    Dim warnings As Long
    Dim ret As Boolean

swApp.SetUserPreferenceIntegerValue _
    swUserPreferenceIntegerValue_e.swSaveAssemblyAsPartOptions, _
    swSaveAsmAsPartOptions_e.swSaveAsmAsPart_AllComponents

    mdl.ForceRebuild3 False

    ret = mdl.Extension.SaveAs3( _
            savePath, _
            swSaveAsCurrentVersion, _
            swSaveAsOptions_Silent, _
            Nothing, _
            Nothing, _
            errors, _
            warnings)

    If ret = False Then

        MsgBox "PART保存失敗" & vbCrLf & _
               "Error:" & errors & vbCrLf & _
               "Warning:" & warnings, vbCritical

        Exit Sub

    End If

    If Dir(savePath) = "" Then MsgBox "PARTファイル未生成", vbCritical

    'Else

     '   MsgBox "PART保存成功", vbInformation

    'End If

End Sub

'==================================================
' Prefix保存
'==================================================

Private Sub SAVE_WITH_PREFIX( _
                ByVal mdl As ModelDoc2, _
                ByVal partsFolder As String, _
                ByVal asmFolder As String, _
                ByVal asmName As String, _
                ByVal setsubiNo As String, _
                ByVal bui As String)

    Dim swAssy              As AssemblyDoc
    Dim swConfig            As Configuration
    Dim swRootComp          As Component2
    Dim vChild              As Variant
    Dim swComp              As Component2

    Dim swPartModel         As ModelDoc2


    Dim sourcePath          As String
    Dim savePath            As String

    Dim oldName             As String
    Dim newName             As String

    Dim i                   As Long
    Dim ret                 As Boolean

    swApp.CommandInProgress = True

    Set swAssy = mdl

'==========================================
' 軽量解除
'==========================================

swAssy.ResolveAllLightWeightComponents True

mdl.ForceRebuild3 False

Set swConfig = mdl.GetActiveConfiguration

Set swRootComp = swConfig.GetRootComponent

vChild = swRootComp.GetChildren

If IsEmpty(vChild) Then Exit Sub

For i = 0 To UBound(vChild)

    Set swComp = vChild(i)

    Set swPartModel = swComp.GetModelDoc2

    If swPartModel Is Nothing Then
        GoTo NEXT_COMPONENT
    End If

    If swPartModel.GetType <> swDocPART Then
        GoTo NEXT_COMPONENT
    End If

    sourcePath = swPartModel.GetPathName

    If sourcePath = "" Then
        GoTo NEXT_COMPONENT
    End If

    oldName = swComp.Name2

    Dim pos As Long
    pos = InStrRev(oldName, "-")

    If pos > 0 Then
        oldName = Left(oldName, pos - 1)
    End If

    If IsNumeric(Left(oldName, 4)) Then
        oldName = Mid(oldName, 6)
    End If

    If InStr(oldName, setsubiNo) > 0 Then
        GoTo NEXT_COMPONENT
    End If

    newName = setsubiNo & bui & "_" & oldName

    savePath = partsFolder & "\" & newName & ".SLDPRT"

    '==========================================
    ' 既存ファイル削除
    '==========================================

    If Dir(savePath) <> "" Then
        Kill savePath
    End If

    '==========================================
    ' 部品コピー保存
    '==========================================

    Dim swSaveExt As ModelDocExtension
    Dim errors As Long
    Dim warnings As Long

    Set swSaveExt = swPartModel.Extension

    swPartModel.ForceRebuild3 False

    ret = swSaveExt.SaveAs3( _
                savePath, _
                swSaveAsCurrentVersion, _
                swSaveAsOptions_Silent + swSaveAsOptions_Copy, _
                Nothing, _
                Nothing, _
                errors, _
                warnings)

    Debug.Print "SaveAs3=" & ret
    Debug.Print "errors=" & errors
    Debug.Print "warnings=" & warnings

    If ret = False Then

        Debug.Print "SaveAs失敗 : " & savePath

        GoTo NEXT_COMPONENT

    End If

    '==========================================
    ' 構成部品選択
    '==========================================

    boolstatus = swComp.Select4(False, Nothing, False)

    '==========================================
    ' 参照置換
    '==========================================

    ret = swAssy.ReplaceComponents( _
                    savePath, _
                    "", _
                    True, _
                    True)

    If ret = False Then

        Debug.Print "Replace失敗 : " & savePath

        GoTo NEXT_COMPONENT

    End If

    '==========================================
    ' 構成部品再取得
    '==========================================

    vChild = swRootComp.GetChildren

    Set swComp = vChild(i)

    '==========================================
    ' FeatureManager名変更
    '==========================================

    boolstatus = swComp.Select4(False, Nothing, False)

    mdl.Extension.RenameDocument newName

    '==========================================
    ' 再構築
    '==========================================

    mdl.ForceRebuild3 False

NEXT_COMPONENT:

Next i

'==========================================
' 最終再構築
'==========================================

mdl.ForceRebuild3 False

'==========================================
' Assembly保存
'==========================================

savePath = asmFolder & "\" & asmName & ".SLDASM"

SAVE_DOCUMENT mdl, savePath

End Sub

アセンブリ上での部品の色には、ざっくりと部品ファイル自身での色（透明）と、
アセンブリが部品の色を上書きする色（透明）があります。
サンプル画像の様に、部品自身は赤色でも、アセンブリで構成部品の色を青にすると、そのアセンブリでは青色で表示されます。
文面だけではどちらの色が影響しているのかわからないのですが、この辺りが影響していると思われます。
（実際の色設定はこれら以外にも階層が深いので、確認してわからなければ、その部分のスクショとかお願いします。）

もし、アセンブリで部品の色を上書きしている状況であれば、
アセンブリの構成部品の青と赤が斜め線で区切られているアイコンでクリックして「外観削除」で上書き解除されます。

色ではない可能性もあるので、もうひとつ説明します。
アセンブリ上で個々の部品をシェイディング表示や隠線表示などに切り替えられます。
もし「透明」ではなく、隠線表示などであれば、先の「青と赤が斜め線で区切られたアイコン」の左にあるアイコンが
個別に切り替えるものになります。
ここをクリックして「デフォルト表示」に切り替えると元に戻ると思います。

色の設定状況を簡単に確認する方法を紹介するの忘れてました...

①アセンブリ上で対象部品の面をクリック。（透明部品の場合はShift押しながらクリック。）
②コマンドメニューが表示されたら「外観」の右にある▼をクリック。
③これで色が設定状況が階層的に表示されます。（上位レベルの色で表示されます。）
（任意の階層の×を押すと色を削除できます。）

山本様

大変わかりやすいご説明、ありがとうございました。おかげさまで無事解決いたしました。

（該当のモデルは弊社の新規開発品のためスクショをお見せすることができず申し訳ございません）

おっしゃる通り、いつの間にBodyの外観が上書きされていたようで、アセンブリの方で透明になっている部品の任意の面の外観からBodyの色を削除したら元通りになりました。（同期して構成部品の方の透明化も解除されました）

どのような動作をしてこうなってしまったのかが分からず、若干モヤモヤが残りますが、ひとまず解決法が分かったのでこれから安心して作業できます。

本当にありがとうございました。