C#ATIA

↑タイトル詐欺 主にCATIA V5 の VBA(最近はPMillマクロとFusion360APIが多い)

上書き保存確認ダイアログでの判断

「SaveAsで保存する際、上書き保存確認ダイアログで
 "はい" を選択したか "いいえ" を選択したか、判断したい」
と御質問を頂きました。

SaveAsメソッドは戻り値がない為、保存前と保存後のタイムスタンプで
判断するしか方法が無いような気がします。

'vba
Sub CATMain()
    
    Dim doc As Document
    Set doc = CATIA.ActiveDocument
    
    Dim before As Date
    before = GetDateLastModified(doc.FullName)
    
    '上書きでいいえの場合エラーになる為
    On Error Resume Next
        doc.SaveAs doc.FullName
    On Error GoTo 0
    
    If before = GetDateLastModified(doc.FullName) Then
        MsgBox "保存されていません"
    Else
        MsgBox "保存されました"
    End If
    
End Sub

Private Function GetDateLastModified( _
    ByVal path As String) As Date
    
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    GetDateLastModified = fso.GetFile(path).DateLastModified
End Function

色々を確認が足りないと思いますが、一応判断出来ていると思います。
過去に、マクロで保存を行うことに対しての賛否はありましたが・・・。

Tree順にボディ,形状セット,時系列形状セット名の取得

先日見つけたこちらのトピですが、
CATIA V5 - CATScript - Identify Order of Geometric Sets and Bodies in CATPart - DASSAULT: CATIA products - Eng-Tips
Treeに並んでいる順に、ボディと形状セット名を取得したい
と言う内容です。

検索で選択状態にすれば、Tree順に取得出来たはずなので
サンプルを作ってみたのですが、よく読んだら解決されていた
いたようでした・・・。 折角作ったので記載しておきます。

Treeに直接ぶら下がっているものだけで、子以下のものは取得しません。

'VBA Tree順にボディ,形状セット,時系列形状セット名の取得

Option Explicit

Sub CATMain()

    'start check
    If Not CanExecute("PartDocument") Then Exit Sub
    
    'doc
    Dim doc As PartDocument
    Set doc = CATIA.ActiveDocument
    
    'AllContainer
    Dim bodys As Object
    Set bodys = GetAllContainers(doc)
    If bodys Is Nothing Then
        MsgBox "Element not found", vbExclamation
        Exit Sub
    End If
    
    'LeafContainer
    Set bodys = GetLeafContainerNames(doc, bodys)
    If bodys Is Nothing Then
        MsgBox "Element not found", vbExclamation
        Exit Sub
    End If
    
    'done
    MsgBox Join(bodys.ToArray(), vbCrLf)
End Sub

Private Function GetAllContainers( _
    ByVal doc As PartDocument) As Object
    
    Set GetAllContainers = Nothing
    
    Dim sel As selection
    Set sel = doc.selection
    
    'Search
    Dim word As String
    word = "(CATPrtSearch.BodyFeature + " & _
            "CATPrtSearch.OpenBodyFeature + " & _
            "CATPrtSearch.MMOrderedGeometricalSet),in"
    
    CATIA.HSOSynchronized = False
    sel.Clear
    
    sel.Search word
    If sel.Count2 < 1 Then Exit Function
    
    Dim ary As Object
    Set ary = InitLst()
    
    Dim i As Long
    For i = 1 To sel.Count2
        ary.Add sel.Item(i).Value
    Next
    
    sel.Clear
    CATIA.HSOSynchronized = True
    
    Set GetAllContainers = ary
End Function

Private Function GetLeafContainerNames( _
    ByVal doc As PartDocument, _
    ByVal lst As Object) As Object
    
    Set GetLeafContainerNames = Nothing
    
    'Leaf HybridBodies
    Dim hBdys As Variant
    hBdys = Lst2Ary(doc.Part.HybridBodies)
    
    'Leaf OrderedGeometricalSets
    Dim odrds As Variant
    odrds = Lst2Ary(doc.Part.OrderedGeometricalSets)
    
    'is Leaf?
    Dim leafs As Object
    Set leafs = InitLst()
    
    Dim v As Variant
    For Each v In lst
        Select Case TypeName(v)
            Case "Body"
                If v.InBooleanOperation = False Then
                    leafs.Add v.Name
                End If
            Case "HybridBody"
                If UBound(filter(hBdys, GetInternalName(v))) > -1 Then
                    leafs.Add v.Name
                End If
            Case "OrderedGeometricalSet"
                If UBound(filter(odrds, GetInternalName(v))) > -1 Then
                    leafs.Add v.Name
                End If
        End Select
    Next
    If leafs.count < 1 Then Exit Function
    
    Set GetLeafContainerNames = leafs
End Function

'list2array
Private Function Lst2Ary( _
    ByVal lst As Object) As Variant

    If lst.count < 1 Then Exit Function

    Dim ary As Object
    Set ary = InitLst()
    
    Dim v As Variant
    For Each v In lst
        ary.Add GetInternalName(v)
    Next
    
    Lst2Ary = ary.ToArray()
End Function

'InternalName
Private Function GetInternalName( _
    ByVal AOj As AnyObject) As String
    If AOj Is Nothing Then
        GetInternalName = Empty
        Exit Function
    End If
    GetInternalName = AOj.GetItem("ModelElement").InternalName
End Function

'DotNet ArrayList
Private Function InitLst() As Object
    Set InitLst = CreateObject("System.Collections.ArrayList")
End Function

'OK?
Private Function CanExecute( _
    ByVal docType As String) As Boolean
    
    CanExecute = False
    
    If CATIA.Windows.count < 1 Then
        MsgBox "Please open the file", vbExclamation
        Exit Function
    End If
    
    Dim doc As Document
    Set doc = CATIA.ActiveDocument
    
    If Not TypeName(doc) = docType Then
        MsgBox docType & " Only!", vbExclamation
        Exit Function
    End If
    
    CanExecute = True
End Function

f:id:kandennti:20190112084014p:plain

異なるUUIDのDraw参照元ファイルを差し替える3

こちらの続きです。
異なるUUIDのDraw参照元ファイルを差し替える2 - C#ATIA

あちらのマクロを実際に業務で使用していると、リンクを持たないビューまで
リンク付きのビューにしてしまう為、使い勝手が非常に悪かったです。

その為、リンク元を差し替えるビューをユーザーが選択できるように
変更しました。

'vba ChangeDrawLink ver0.0.2  using-'KCL0.0.12'  by Kantoku
'Drawのビューのリンクの参照元を差し替える
'Partのみ?で UUID違いOK

'ver0.0.1:完成
'ver0.0.2:ビューを指定するように変更

Option Explicit

Private Const SelectionType = "*.CATPart"

Sub CATMain()
    'ドキュメントのチェック
    If Not CanExecute("DrawingDocument") Then Exit Sub
    
    'view選択
    Dim Msg As String
    Msg = "置き換えるビューを選択してください"
    
    Dim views As Collection
    Set views = SelectViews(Msg)
    If views Is Nothing Then Exit Sub
    If views.Count < 1 Then Exit Sub
    
    'ファイル選択
    Msg = "Drawで参照するファイルを選択してください"
    
    Dim path As String
    path = CATIA.FileSelectionBox( _
        Msg, _
        SelectionType, _
        CatFileSelectionModeOpen)
    If path = vbNullString Then Exit Sub
    
    'Draw
    Dim drawDoc As DrawingDocument
    Set drawDoc = CATIA.ActiveDocument
    
    '確認
    Msg = "以下のビュー" & vbCrLf & _
        GetViewsName(views) & _
        "を、リンクの参照元" & vbCrLf & _
        path & vbCrLf & _
        "に置き換えます。宜しいですか?"
        
    If MsgBox(Msg, vbYesNo + vbQuestion) = vbNo Then Exit Sub
    
    Dim viws As DrawingViews
    Set viws = drawDoc.Sheets.ActiveSheet.views
    
    '参照オープン
    Dim refDoc As Document
    Set refDoc = CATIA.Documents.Open(path)
    
    'すり替え
    Dim vi As DrawingView
    
    For Each vi In views
        Call ChangeLink(vi, refDoc)
    Next
    
    '参照クローズ
    Call refDoc.Close
    
    MsgBox "Done"
End Sub

'ビューの選択
Private Function SelectViews( _
    ByVal Msg As String) As Collection

    Dim sel As Variant
    Set sel = CATIA.ActiveDocument.selection

    Dim filter As Variant
    filter = Array("DrawingView")

    sel.Clear
    Select Case sel.SelectElement3(filter, Msg, True, _
        CATMultiSelTriggWhenUserValidatesSelection, False)
        Case "Cancel", "Undo", "Redo"
            Exit Function
    End Select

    Dim lst As Collection
    Set lst = New Collection

    Dim i As Long
    For i = 1 To sel.Count2
        lst.Add sel.Item(i).Value
    Next
    sel.Clear

    Set SelectViews = lst
End Function

'コレクション内のビュー名をテキスト化
Private Function GetViewsName( _
    ByVal lst As Collection) As String

    Dim ary() As String
    ReDim ary(lst.Count)
    
    Dim i As Long
    For i = 1 To lst.Count
        ary(i - 1) = lst.Item(i).Name
    Next
    
    GetViewsName = Join(ary, vbCrLf)
End Function

'すり替え&Update
Private Sub ChangeLink( _
    ByVal viw As DrawingView, _
    ByVal doc As Document)

    Dim links As DrawingViewGenerativeLinks
    Set links = viw.GenerativeLinks
    links.RemoveAllLinks

    Dim behv As DrawingViewGenerativeBehavior
    Set behv = viw.GenerativeBehavior

    behv.Document = doc
    behv.Update
End Sub

マクロ実行後、ビューを選択(複数選択可能です)し、続いて
リンク元となるPartファイルを指定すればOKです。
指定するPartファイルはUUIDの一致不一致を問いません。

唯一の欠点は、更新後本来寸法解析した際赤くなるべき寸法が
何食わぬ顔して(黒のまま)終了してしまう事です。
これは更新しても直りません。

対策としては、再度手動でリンク元を同じファイルで置換し更新すれば
OKなのですが手間と言えばかなり手間です。

但し、UUID違いは手動ではリンク元を置換できない為、個人的には
かなり重宝します。

そして、リンクを分断したビューでもリンクを復活させる事も可能です!
(もちろん寸法はチマチマ直す必要は有ります)

オフセット平面をリネーム3

こちらの続きです。
オフセット平面をリネーム2 - C#ATIA

また、面倒くさい虫が現れました。
大量のPartファイルが有り、一枚一枚平面名を修正するのが面倒です。

以前は、オフセット平面の親子関係を取得できないので断念していたのですが、
平面名が変更されなくなるまで強制的にループさせてしまおう と思い付き
Partファイル内のオフセット平面をまとめて処理させるようにしました。

'vba Part_OffsetPleneRename_ver0.0.3  using-'KCL0.0.12'  by Kantoku

'ver0.0.1:完成
'ver0.0.2:座標系平面対応
'ver0.0.3:全体を自動化

Option Explicit

Sub CATMain()
    'ドキュメントのチェック
    If Not CanExecute("PartDocument") Then Exit Sub
    
    'オフセット平面
    Dim offs As Object
    Set offs = GetPlaneOffset()
    If offs Is Nothing Then
        MsgBox "修正すべきオフセット平面が有りませんでした", vbInformation
        Exit Sub
    End If
    
    '確認
    Dim msg As String
    msg = offs.count & "個のオフセット平面があります。" & vbCrLf & _
        "リネームを試みますか?"
    If MsgBox(msg, vbYesNo + vbQuestion) = vbNo Then Exit Sub
    
    '実行前ネームリスト
    Dim before As Object
    Set before = GetPlaneNameLst(offs)
    
    'リネーム
    Call ExecRename(offs)
    
    '変更リスト
    Dim changes As Object
    Set changes = GetChangeLst(offs, before)
    
    '結果
    If changes Is Nothing Then
        msg = "変更有りませんでした"
    Else
        msg = "以下を変更しました" & vbCrLf & _
            String(20, "-") & vbCrLf & _
            Join(changes.ToArray(), vbCrLf)
    End If
    
    CATIA.RefreshDisplay = True
    MsgBox msg, vbInformation

End Sub

'参照元座標系時の新たな平面名取得
Private Function GetAxisPlaneName(ByVal pln As Plane) As String
    GetAxisPlaneName = vbNullString
    
    Dim info As Variant
    info = GetBrepInfo(pln.Plane.DisplayName)
    
    Dim pt As part
    Set pt = KCL.GetParent_Of_T(pln, "Part")
    
    Dim inter As String
    Dim ax As AxisSystem
    Dim hit As AxisSystem: Set hit = Nothing
    
    For Each ax In pt.AxisSystems
        inter = KCL.GetInternalName(ax)
        If inter = info(0) Then
            Set hit = ax
            Exit For
        End If
    Next
    If hit Is Nothing Then Exit Function
    
    Dim direction As String
    Select Case info(1)
        Case 1 'XY平面
            direction = "Z"
        Case 2 'YZ平面
            direction = "X"
        Case 3 'ZX平面
            direction = "Y"
        Case Else
            '多分無いはず。止まったら連絡下さい
            Stop
    End Select
    GetAxisPlaneName = hit.name & "_" & direction & "="
End Function

'BrapNameから参照情報取得
Private Function GetBrepInfo(ByVal BrepName As String) As Variant
    Dim tmp As Variant
    tmp = Split(BrepName, "RSur:(Face:(Brp:(")
    tmp = Split(tmp(1), ")")
    GetBrepInfo = Split(tmp(0), ";")
End Function

'数値を+-付きの文字にする
Private Function Num2Str(ByVal Num As Double) As String
    Num2Str = IIf(Num > 0, "+", "") & CStr(Num)
End Function
 
'新たな平面名取得
Private Function GetPlaneName(ByVal RefPlnName As Reference) As String
    Select Case RefPlnName.DisplayName
        Case "xy plane", "XY平面"
            GetPlaneName = "Z"
        Case "yz plane", "YZ平面"
            GetPlaneName = "X"
        Case "zx plane", "ZX平面"
            GetPlaneName = "Y"
        Case Else
            GetPlaneName = RefPlnName.DisplayName
    End Select
End Function

'リネームする可能性のある平面リスト取得
Private Function GetPlaneOffset() As Object

    Set GetPlaneOffset = Nothing
    
    Dim sel As Selection
    Set sel = CATIA.ActiveDocument.Selection
    
    CATIA.HSOSynchronized = False
    
    sel.Clear
    sel.Search "CATPrtSearch.GSMPlaneOffset,all"
    If sel.Count2 < 1 Then Exit Function
    
    Dim lst As Object
    Set lst = KCL.InitLst()
    
    Dim i As Long
    Dim pln As Plane
    For i = 1 To sel.Count2
        Set pln = sel.Item(i).Value
        If IsReferencePlane(pln) Then
            lst.Add pln
        End If
    Next
    sel.Clear
    CATIA.HSOSynchronized = True
    
    If lst.count < 1 Then Exit Function
    
    Set GetPlaneOffset = lst
End Function

'参照元は平面か?
Private Function IsReferencePlane( _
    ByVal pln As Plane) As Boolean
    
    IsReferencePlane = True
    
    If InStr(pln.Plane.DisplayName, "RSur:") > 0 Then
        '座標系の可能性
        Dim newName As String
        newName = GetAxisPlaneName(pln)
        If Len(newName) < 1 Then
            IsReferencePlane = False
        End If
    End If
End Function

'平面名リスト
Private Function GetPlaneNameLst( _
    plns As Object) As Object
    
    Dim lst As Object
    Set lst = KCL.InitLst()
    
    Dim p As Plane
    For Each p In plns
        lst.Add p.name
    Next
    
    Set GetPlaneNameLst = lst
End Function

'リネーム実行
Private Sub ExecRename( _
    plns As Object)
    
    Dim pln As Plane
    Dim newName As String
    Dim changeFG As Boolean
    
    Do
        changeFG = False
        
        For Each pln In plns
            If InStr(pln.Plane.DisplayName, "RSur:") > 0 Then
                newName = GetAxisPlaneName(pln)
            Else
                newName = GetPlaneName(pln.Plane)
            End If
            
            newName = newName & _
                Num2Str(pln.Offset.Value * pln.Orientation) & "mm"
            
            If Not pln.name = newName Then
                'リネーム
                pln.name = newName
                changeFG = True
            End If
        Next
        
        If Not changeFG Then Exit Do
    Loop
End Sub

'変更された平面名のみ取得
Private Function GetChangeLst( _
    plns As Object, _
    before As Object) As Object
    
    Set GetChangeLst = Nothing
    
    Dim lst As Object
    Set lst = KCL.InitLst()
    
    Dim i As Long
    For i = 0 To plns.count - 1
        If Not plns(i).name = before(i) Then
            lst.Add before(i) & " -> " & plns(i).name
        End If
    Next
    
    If lst.count < 1 Then Exit Function
    
    Set GetChangeLst = lst
End Function

平面1 -> 平面2 -> 平面3 -> 平面1 -> ・・・
の様に参照元が循環ループ状態になっているのはCATIA自身で
チェックしてくれているので、無限ループには陥らないはず。

DrawをPDFでエクスポート (未解決)3

こちらの続きです。
DrawをPDFでエクスポート (未解決)2 - C#ATIA

ほぼ使わないので存在すら忘れていましたが、こちらのバッチマネージャに
印刷バッチがある事に気が付きました。
f:id:kandennti:20181214153054p:plain
起動しプリンタでCubePDFを指定すると出ます。
f:id:kandennti:20181214153116p:plain
しかも良く見ると、CATScriptが作れるようです。
(後でわかりましたが、印刷バッチ時に毎回CATScriptを実行しているようです)

VBAエディタにコードを貼り付けます(一部型指定のエラーがあるのでコメント化)

'Language = "VBSCRIPT"
Dim logFile As TextStream

'------------------------------------------
'---- CATMain()
'------------------------------------------
Sub CATMain()
  CATIA.DisplayFileAlerts = False

  '------------------------------------------
  '-  open the log file : C:\Users\XXX\AppData\Local\Temp\PrintBatch.log
  '------------------------------------------
  Dim AppliFileSys 'As FileSystem
  Set AppliFileSys = CATIA.FileSystem
  Dim FileObj As File
  Set FileObj = AppliFileSys.CreateFile("C:\Users\XXX\AppData\Local\Temp\PrintBatch.log", True)
  Set logFile = FileObj.OpenAsTextStream("ForWriting")

  '------------------------------------------
  '-  open the document file : C:\temp\hoge.CATDrawing
  '------------------------------------------
  OpenDocument "C:\temp\hoge.CATDrawing"

  Dim sheet As AnyObject
  Set sheet = CATIA.ActiveDocument.Sheets.Item(1)
  sheet.Activate

  '------------------------------------------
  '-  printer -
  '------------------------------------------
  Dim thePrinter As Printer
  Set thePrinter = CATIA.Printers.Item(3) '←プリンタを指定
  CATIA.ActivePrinter = thePrinter

  '------------------------------------------
  '-  parameters -
  '------------------------------------------
  Dim PageSetUp 'As CATIADrawingPageSetup
  Set PageSetUp = sheet.PageSetUp
  PageSetUp.PaperWidth = 210
  PageSetUp.PaperHeight = 297
  PageSetUp.Orientation = 0
  PageSetUp.LeftMargin = 10
  PageSetUp.RightMargin = 10
  PageSetUp.TopMargin = 10
  PageSetUp.BottomMargin = 10
  PageSetUp.BottomMargin = 10
  PageSetUp.FitToSheetFormat = True
  PageSetUp.MaximumSize = False
  PageSetUp.Left = 0
  PageSetUp.Bottom = 0
  PageSetUp.Zoom = 1
  PageSetUp.Rotation = 0
  PageSetUp.Color = 0
  PageSetUp.Quality = 0
  PageSetUp.Dpi = 150
  PageSetUp.Banner = "xxxx"
  PageSetUp.BannerPosition = 0
  PageSetUp.TextBlanking = False
  PageSetUp.WhiteVectorsInBlack = True
  PageSetUp.LineWidthSpecification = 0
  PageSetUp.LineTypeSpecification = 0
  PageSetUp.LineCap = 0
  PageSetUp.TextScaling = True
  PageSetUp.LineTypeOverlappingCheck = False
  PageSetUp.Gamma = 1
  Dim Document 'As CATIADocument
  Set Document = CATIA.ActiveDocument
  Err.Clear
  On Error Resume Next
  sheet.PrintOut '←印刷
  If Err = 0 Then
    logFile.Write "  Printing done "
  Else
    logFile.Write "  Printing failed "
    Err.Clear
  End If

  Set thePrinter = Nothing
  Set sheet = Nothing

  '------------------------------------------
  '-  close the document file : C:\temp\hoge.CATDrawing
  '------------------------------------------
  CloseDocument

  '------------------------------------------
  '-  close the log file -
  '------------------------------------------
  Set FileObj = Nothing
  Set AppliFileSys = Nothing
  logFile.Write " End of printing   "
  logFile.Close

  MsgBox "End of printing"
End Sub

'-------------------------------------------------------
'---- OpenDocument(FileName)
'-------------------------------------------------------
Sub OpenDocument(FileName As String)
  Dim TheCATIADocument As Document
  On Error Resume Next
  Set TheCATIADocument = CATIA.Documents.Open(FileName)
  If Err = 0 Then
    logFile.Write FileName
    logFile.Write " Opened "
  Else
    logFile.Write FileName
    logFile.Write " Failed to open "
    Err.Clear
  End If
  CATIA.ActiveWindow.WindowState = 0
End Sub

'-------------------------------------------------------
'---- CloseDocument()
'-------------------------------------------------------
Sub CloseDocument()
  Dim ActiveDoc As Document
  Set ActiveDoc = CATIA.ActiveDocument
  On Error Resume Next
  ActiveDoc.Close
  If Err = 0 Then
    logFile.Write " Active document closed "
  Else
    logFile.Write " Failed to close active document "
    Err.Clear
  End If
End Sub

プリンタの指定のインデックス部分は、各々の環境で違うはずです。
印刷自体はDrawingSheetのPrintOutメソッドで行っているんですね。
気が付かなかったです。

で、実行すると・・・白紙なんです。
試しに通常のプリンタを指定して実行しても、プリンタが少しだけ
反応して結局出ないんです。何だか煮え切らないです。

バッチマネージャは何をやっているのだろうか?

CATIA VBAの参照設定

UserFormでD&Dを実現させるために、ListViewコントロールを
利用すると出来るようなのですが、ちょっぴり問題が・・・。

定かではないのですが、ListViewコントロールを利用する為に
参照設定でこちらの
f:id:kandennti:20181205151118p:plain
Microsoft Windows Common Controls 5.0(SP2)
が、必要そうなのですが、特定の客先環境のCATIA VBAでは
出てくるのですが、通常インストールの環境では出てきません。
(同一PCで リリース SP FH も同一です)

調べたからかも知れませんが、「MSComctlLib.ocx」は
ナカナカの曲者のようで・・・。

「Browse...」でムリムリ参照させてもダメっぽいんです。
かなり完成しているのに、何故?

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

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