SWJUG-RING: SW2021→SW2026バージョンアップ後のAPI不具合

ブログ
福谷勇時
SW2021→SW2026バージョンアップ後のAPI不具合

SW2021→SW2026バージョンアップ後のAPI不具合

久しぶりの投稿になります。

Assemblyと構成部品に、プロパティから取得した文字を付加して
プロパティより取得した文字列で自動作成したフォルダに保存するAPIですが、
SW2021→SW2026にバージョンアップ後、自動作成フォルダに構成部品が保存され
Assemblyも保存されますが、構成部品の参照が外れ変更前の構成部品が書き換わりません。。
SW2021では、マクロ実行後、デザインツリーの構成部品名が書き換わる様子も目視できてましたが、
SW2026では、なにも起こらないで、終了してしまいます。

多分、実行コマンドが変更？になってると思われますが、探し出せてません。

どなたか分かる方おられましたら、ご教示いただけると幸いです。

'アセンブリファイルと参照部品にプレフィックスつけて保存

ElseIf flag = 3 Then

Dim swAssy As SldWorks.AssemblyDoc
Dim swConfig As SldWorks.Configuration
Dim swRootComp As SldWorks.Component
Dim bRet As Boolean

Set swConfig = swModel.GetActiveConfiguration
Set swRootComp = swConfig.GetRootComponent

Dim Children As Variant
Children = swRootComp.GetChildren

Dim i As Long
For i = 0 To UBound(Children)

Dim swComp As Component2
Set swComp = Children(i)

Debug.Print swComp.Name2 '"Name " + i + ": " +

bRet = swComp.Select(False) 'Append = false

'現在の構成部品名を読み込み
Dim OldName As String
OldName = swComp.Name2

'ファイル名の子NO確認
Dim j As Long
j = InStrRev(OldName, "-")
Dim txt As String
txt = Mid(OldName, j)

'子番号置換（削除）
OldName = Replace(OldName, txt, "")

'取得した構成部品名の左(先頭)から4文字取得
Dim ChangeName As String
ChangeName = OldName
ChangeName = Left(ChangeName, 4)
Debug.Print ChangeName

'取得した構成部品の左4文字が数字だった場合実行
If IsNumeric(ChangeName) = True Then
OldName = Replace(OldName, ChangeName & "_", "")
End If
Debug.Print OldName

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

'構成部品名書込
swComp.Name2 = NewName
Debug.Print NewName
If InStr(OldName, rValOut1) = 0 Then

NewName = fPath1 & "\" & NewName & ".SLDPRT"
fPath = NewName
Set swModel = swComp.GetModelDoc2
Set swExt = swModel.Extension

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

End If

Next i

よろしくお願いします。

- 福谷勇時@akane11112222
福谷勇時 17 日前
すみません。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
- 山本誠@MakotoYamamoto
山本誠 17 日前
『構成部品の名前変更を有効化』がONになってたとしたら、OFFにしてみてどうなるか確認できますかね。
この機能の追加で、ツリー上で名前を変更すると、ファイル名自身を変更できるようになったので、
その辺りが影響しているのかと。

あとは、変数定義時(Dim)のところで、最新のクラス（インターフェース）に変えてあげるとうまくいく事もあるかもしれません。（新しいメソッドで対応できるなど）
例えば、Dim swRootComp As SldWorks.Component の場合、
Component2 という新しいクラスがあるので変えてみるとか。
ただ、メソッドが変わってたり、引数増えてたりなどで、修正が大変だったりもします。
- 福谷勇時@akane11112222
福谷勇時 17 日前
山本さん
いつもお世話になってます。
本件、システムオプションの『構成部品の名前変更を有効化』はONになってました。
ちなみに確認ダイアログもメッセージ閉じていたので、表示させるようにしてみましたが、現象変わらずでした。
とりあえずAPIヘルプ確認してみますね（これだけ英語版のみなので、知りたい情報探すだけでも苦労しますが・・・）
なにか分かれば、また教えていただけると幸いです。
よろしくお願いします。
- 山本誠@MakotoYamamoto
山本誠 19 日前
ゴールデンウィークに入ってしまったので返信が遅くなってしまいました...

ざっとコードを見た限り動きそうな気がしますね。
（実際に試してないのでわからないですが）

たぶん、この状況からするとシステムオプションが関連してそうな気がします。
システムオプションの『FeatureManager』にある『FeatureManagerつりーから構成部品の名前変更を有効化』がOFFになっている可能性があります。
このオプションがどのバージョンで追加されたかは覚えてないのですが、
ONにして構成部品名変更するとそのタイミングで確認ダイアログが表示されるようになったので、
この辺りの処理が必要になってくるかもしれません。

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

福谷勇時

タグクラウド

SW2021→SW2026バージョンアップ後のAPI不具合

コメント

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

福谷勇時

タグクラウド

SW2021→SW2026バージョンアップ後のAPI不具合

コメント

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