C#ATIA

↑タイトル詐欺 主にFusion360API 偶にCATIA V5 VBA(絶賛ネタ切れ中)

同一UUIDのDraw参照元ファイルを差し替える4

こちらの続きです。
同一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したくなくなる気持ちもわかりますが、上記のマクロでは
対応出来ていると思います。

まだ、ちょっと機能不足なのですが、組合せリストを作る方の
マクロが異常なほど使いにくい・・・。