こちらの続きです。
同一UUIDのDraw参照元ファイルを差し替える3 - C#ATIA
まだちょっと不安定な気もしているのですが、手元のデータでは
上手く行っているので公開しておきます。
先日の組合せのファイルを読み込ませ、Partファイルと同一名の
Drawingファイルを作成します。
'vba ReplaceDrawLink ver0.0.3 using-'KCL0.0.12' by Kantoku 'ベースとなるファイル名はCATPartとCATDrawingで一致している事が前提 'UUIDが一致している事前提です(違うと置換されないです) 'ver0.0.1:完成(テストコード) 'ver0.0.2:バッチ処理で複数変換対応 'ver0.0.3:Update改善(LockViewによるマクロ停止) ' ターゲットPartファイル一時的にバックアップ Option Explicit '*********** Private Const EXP_EXTENSION = "comb" Private Const SelectionType = "*." & EXP_EXTENSION Private Const BAT_CATVBS = "ReplaceDrawLinkBat.catvbs" Private Const BAT_SCRIPT = "ReplaceDrawLink" '重要!モジュール名 Private Const BAT_FUNCTION = "ExecReplaceLink" '重要!バッチモードのエントリーポイント関数名 PrivateはNG Private Const EVACUATION_NAME = "EVAC" Private Const DELIMTER = "@" Private Const DELIMTER_COMB = "|" Private Const DEBUGMODE = False Sub CATMain() 'リンク修正リストファイル選択 Dim msg As String msg = "Drawリンクを修正する為のリストファイル(" & EXP_EXTENSION & ")を選択してください" Dim lst_path As String lst_path = CATIA.FileSelectionBox( _ msg, _ SelectionType, _ CatFileSelectionModeOpen) If lst_path = vbNullString Then Exit Sub 'リンク修正リストファイル読み込み Dim paths As Variant paths = KCL.ReadFile(lst_path) '確認 msg = UBound(paths) + 1 & "個のバッチ処理を行います。宜しいですか?" If MsgBox(msg, vbYesNo + vbQuestion) = vbNo Then Exit Sub End If 'catiaの実行ファイルパス取得 Dim catPathtmp As Variant catPathtmp = Split(CATIA.SystemService.Environ("CATDLLPath"), ";") Dim catPath As String catPath = catPathtmp(0) '環境ファイルパス取得 Dim environmentPath As Variant environmentPath = SplitPathName(CATIA.SystemService.Environ("CATEnvName")) 'CATTempパス取得 Dim catTmp As Variant catTmp = CATIA.SystemService.Environ("CATTemp") 'バッチ用catvbs Dim macroPath As String macroPath = catTmp & "\" & BAT_CATVBS Dim code As String code = GetCatvbsCode(Join(paths, DELIMTER), macroPath) KCL.WriteFile macroPath, code 'バッチコマンド Dim cmd As String cmd = catPath & "\CNEXT.exe -direnv " & _ environmentPath(0) & " -env " & _ environmentPath(1) & " -batch -macro " & _ Chr(34) & macroPath & Chr(34) 'バッチスタート Call CreateObject("Wscript.Shell").exec(cmd) MsgBox "バッチ処理をスタートしました" End Sub '******* バッチ処理前 ********* 'バッチ用スプリクトソース Private Function GetCatvbsCode( _ ByVal path As String, _ ByVal me_path As String) As String 'VBProjectパス取得 Dim apc As Object Set apc = GetApc() Dim execPjt As Object Set execPjt = apc.ExecutingProject Dim pjtPath As String pjtPath = execPjt.DisplayName Dim code As String code = _ "Set SS = CATIA.SystemService" & vbCrLf & _ "VBAProjectPath = " & Chr(34) & CStr(pjtPath) & Chr(34) & vbCrLf & _ "LibraryType = catScriptLibraryTypeVBAProject" & vbCrLf & _ "ScriptName = " & Chr(34) & BAT_SCRIPT & Chr(34) & vbCrLf & _ "FunctionName = " & Chr(34) & BAT_FUNCTION & Chr(34) & vbCrLf & _ "Dim Params(0)" & vbCrLf & _ "Params(0) = " & Chr(34) & path & Chr(34) & vbCrLf & _ "Call SS.ExecuteScript(VBAProjectPath, LibraryType, ScriptName, FunctionName, Params)" & vbCrLf If Not DEBUGMODE Then code = code & _ "CreateObject(" & Chr(34) & "Scripting.FileSystemObject" & Chr(34) & ").DeleteFile(" & _ Chr(34) & me_path & Chr(34) & ")" & vbCrLf End If code = code & _ "CreateObject(" & Chr(34) & "WScript.Shell" & Chr(34) & ").Popup " & Chr(34) & "Done" & _ Chr(34) & ", 0 , " & Chr(34) & "ReplaceDrawLink" & Chr(34) & " , 0" GetCatvbsCode = code End Function 'パスとファイル名分割 'Return: 0-Path 1-BaseName Private Function SplitPathName(ByVal FullPath) As Variant Dim path(1) As String With CreateObject("Scripting.FileSystemObject") path(0) = .GetParentFolderName(FullPath) path(1) = .GetBaseName(FullPath) End With SplitPathName = path End Function 'Apc取得 Private Function GetApc() As Object Set GetApc = Nothing 'VBAバージョンチェック Dim COMObjectName$ #If VBA7 Then COMObjectName = "MSAPC.Apc.7.1" #ElseIf VBA6 Then COMObjectName = "MSAPC.Apc.6.2" #Else MsgBox "VBAのバージョンが未対応です" Exit Function #End If 'APC取得 Dim apc As Object: Set apc = Nothing On Error Resume Next Set apc = CreateObject(COMObjectName) On Error GoTo 0 If apc Is Nothing Then MsgBox "MSAPC.Apcが取得できませんでした" Exit Function End If Set GetApc = apc End Function '******* バッチ処理用 ********* '差し替え処理 Sub ExecReplaceLink(ByVal all_path As String) Dim paths As Variant paths = Split(all_path, DELIMTER) Dim i As Long Dim path As Variant For i = 0 To UBound(paths) path = Split(paths(i), DELIMTER_COMB) If UBound(path) < 1 Then GoTo continue If IsExistsFiles(path) Then Call ReplaceLink(path(0), path(1)) End If continue: Next If Not DEBUGMODE Then CATIA.Quit End If End Sub '差し替えたDrawファイル作成 Private Sub ReplaceLink( _ ByVal tgtPartPath As String, _ ByVal refDrawPath As String) '避難先フォルダ Dim evac As String evac = GetEvacuationPath(refDrawPath) 'refPartの避難 Dim refPartAry As Variant refPartAry = KCL.SplitPathName(refDrawPath) refPartAry(2) = "CATPart" Dim refPart As String refPart = refPartAry(0) & "\" & _ refPartAry(1) & "." & _ refPartAry(2) Dim fso As Object Set fso = KCL.GetFSO() If KCL.IsExists(refPart) Then fso.MoveFile refPart, evac & "\" refPart = evac & "\" & _ refPartAry(1) & "." & _ refPartAry(2) Else refPart = vbNullString End If 'tgtPartのバックアップ Dim tgtBackup As String tgtBackup = tgtPartPath & ".backup" fso.CopyFile tgtPartPath, tgtBackup 'tgtPartのリネーム Dim tgtPartAry As Variant tgtPartAry = KCL.SplitPathName(tgtPartPath) Dim tmpPart As String tmpPart = refPartAry(1) & "." & _ tgtPartAry(2) fso.GetFile(tgtPartPath).name = tmpPart tmpPart = tgtPartAry(0) & "\" & _ tmpPart 'tgt(tmp)Partのオープン Dim tgtDoc As PartDocument Set tgtDoc = CATIA.Documents.Open(tmpPart) 'refDrawのオープン Dim refDoc As DrawingDocument Set refDoc = CATIA.Documents.Open(refDrawPath) 'refDrawのUpdate Call UpdateUnlockViews(refDoc) 'SaveAs Call SaveAs(tgtDoc, tgtPartPath) Dim tgtDraw As String tgtDraw = tgtPartAry(0) & "\" & _ tgtPartAry(1) & ".CATDrawing" Call SaveAs(refDoc, tgtDraw) 'tgtPartのバックアップ削除 fso.DeleteFile tgtBackup 'refPart戻し If Not refPart = vbNullString Then fso.MoveFile refPart, refPartAry(0) & "\" End If '避難先フォルダ削除 fso.DeleteFolder evac 'リネームファイル削除 fso.DeleteFile tmpPart 'ファイルを閉じる tgtDoc.Close refDoc.Close End Sub 'ロックしていないリンク付きビューの更新 Private Sub UpdateUnlockViews( _ ByVal doc As DrawingDocument) Dim sht As DrawingSheet Dim v As DrawingView For Each sht In doc.Sheets If sht.IsDetail Then GoTo continue_sheet For Each v In sht.Views If v.LockStatus Then GoTo continue_view If Not HasLink(v) Then GoTo continue_view v.GenerativeBehavior.Update continue_view: Next continue_sheet: Next End Sub 'リンク付きビューか? Private Function HasLink( _ ByVal view As DrawingView) As Boolean HasLink = False On Error Resume Next Dim behv As DrawingViewGenerativeBehavior Set behv = view.GenerativeBehavior Dim v As Document Set v = behv.Document.Parent On Error GoTo 0 If v Is Nothing Then Exit Function HasLink = True End Function '避難フォルダ Private Function GetEvacuationPath( _ ByVal path As String) As String Dim evac As String evac = KCL.GetFSO.GetParentFolderName(path) & "\" & _ EVACUATION_NAME evac = GetNewFolderName(evac) GetEvacuationPath = evac KCL.GetFSO.CreateFolder evac End Function '重複しないフォルダ名 Private Function GetNewFolderName$(ByVal oldPath$) Dim newPath As String newPath = oldPath If Not KCL.IsExists(newPath) Then GetNewFolderName = newPath Exit Function End If Dim TempName$, i&: i = 0 Do i = i + 1 TempName = newPath + "_" + CStr(i) If Not KCL.IsExists(TempName) Then GetNewFolderName = TempName Exit Function End If Loop End Function '複数ファイル有無チェック Private Function IsExistsFiles( _ ByVal ary As Variant) As Boolean IsExistsFiles = False Dim i As Long For i = 0 To UBound(ary) If Not KCL.IsExists(ary(i)) Then Exit Function Next IsExistsFiles = True End Function 'ダイアログをブロックしたSaveAs Private Sub SaveAs( _ ByVal doc As Document, _ ByVal path As String) CATIA.DisplayFileAlerts = False doc.SaveAs path CATIA.DisplayFileAlerts = True End Sub
最大の特徴は、マクロの実行はバッチモードで起動させたCATIA側に
処理させる点です。その為、作業を行っているCATIAのオペレーションは
マクロの起動までしか奪われません。
イロイロと注意すべき点があるのですが、恐らく世間的には
「今更・・・」なマクロだろうとは思ってます。
先日客先より支給されたDrawファイルは、リンク元の差し替えは
行われていましたが、Updateされていませんでした。
恐らく、リンク元を差し替えるマクロのようなものを持っている
のではないかな? と勝手に思っています。
実は単純にUpdateした際、データの状態によってはダイアログが
出現しマクロが停止してしまう状況に遭遇しました。
Updateしたくなくなる気持ちもわかりますが、上記のマクロでは
対応出来ていると思います。
まだ、ちょっと機能不足なのですが、組合せリストを作る方の
マクロが異常なほど使いにくい・・・。