異なる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違いは手動ではリンク元を置換できない為、個人的には
かなり重宝します。

そして、リンクを分断したビューでもリンクを復活させる事も可能です！
（もちろん寸法はﾁﾏﾁﾏ直す必要は有ります）

形状ｾｯﾄ要素の対称化ﾏｸﾛ2

こちらの続きです。
形状ｾｯﾄ要素の対称化ﾏｸﾛ - C#ATIA

元の対称化するマクロですが、色の反映を追加しました。

'vba 指定した形状ｾｯﾄを対称化しｺﾋﾟﾍﾟ2
Option Explicit

Dim PartDoc As PartDocument
Dim Part As Part
Dim sel 'As Selection
Dim HSFact As HybridShapeFactory
Dim BasePlane As Reference
Dim DeleteItems As New Collection

Sub CATMain()
    '初期設定
    Set PartDoc = CATIA.ActiveDocument
    Set Part = PartDoc.Part
    Set sel = PartDoc.selection
    
    '元の形状ｾｯﾄ選択
    Dim BaseHBody As HybridBody
    Set BaseHBody = SelectHybridBody
    
    '対象平面選択
    Set BasePlane = SelectPlanarFace
    
    '形状ｾｯﾄｺﾋﾟﾍﾟ
    Dim MirrerHBody As HybridBody
    Set MirrerHBody = CopyPasteHybridBody(BaseHBody)
    MirrerHBody.Name = BaseHBody.Name + "_Symmetry"
    
    '対称化
    Set HSFact = Part.HybridShapeFactory
    Call HBodyLoop(MirrerHBody)
    
    '終了
    Call DeleteItem
    Part.Update
    MsgBox ("終了")
End Sub

'ｺﾋﾟﾍﾟした要素を削除
Private Sub DeleteItem()
    Dim Ref As Reference
    For Each Ref In DeleteItems
        Call HSFact.DeleteObjectForDatum(Ref)
    Next
End Sub

'形状ｾｯﾄﾙｰﾌﾟ-再帰
Private Sub HBodyLoop(HBody As HybridBody)
    Call SymmetryItem(HBody.HybridShapes)
    If HBody.HybridBodies.Count = 0 Then Exit Sub '下階層無し
    
    Dim HB As HybridBody
    For Each HB In HBody.HybridBodies
        Call HBodyLoop(HB)
    Next
End Sub

'対称
Private Sub SymmetryItem(HShapes As HybridShapes)
    Dim HShape As HybridShape
    Dim Ref As Reference
    Dim rgb As Variant
    Dim sym As HybridShape
    
    For Each HShape In HShapes
        Set Ref = Part.CreateReferenceFromObject(HShape)
        rgb = GetColor(HShape)
        If HSFact.GetGeometricalFeatureType(Ref) <> 0 Then
            Call DeleteItems.Add(Ref) '削除登録
            Set sym = CreateDatum(CreateSymmetry(Ref, BasePlane))
            Call setColor(sym, rgb)
            Call HShapes.Parent.AppendHybridShape(sym)
        End If
    Next
End Sub

'色取得
Private Function GetColor( _
    ByVal shape As HybridShape) As Variant
    
    sel.Clear
    sel.Add shape
    
    Dim vis As VisPropertySet
    Set vis = sel.VisProperties
    
    Dim rgb(2) As Long
    vis.GetRealColor rgb(0), rgb(1), rgb(2)
    
    sel.Clear
    GetColor = rgb
End Function

'色設定
Private Sub setColor( _
    ByVal shape As HybridShape, _
    ByVal rgb As Variant)
        
    sel.Clear
    sel.Add shape
    
    Dim vis As VisPropertySet
    Set vis = sel.VisProperties
    
    Call vis.SetRealColor(rgb(0), rgb(1), rgb(2), 1)
    sel.Clear
End Sub

'Symmetry
Private Function CreateSymmetry(ItemRef As Reference, PlaneRef As Reference) As Reference
    Dim Symmetry As HybridShapeSymmetry
    Set Symmetry = HSFact.AddNewSymmetry(ItemRef, PlaneRef)
    Symmetry.VolumeResult = False
    Call Part.UpdateObject(Symmetry)
    Set CreateSymmetry = Part.CreateReferenceFromObject(Symmetry)
    Call DeleteItems.Add(CreateSymmetry) '削除登録
End Function

'Datum
Private Function CreateDatum(Ref As Reference) As AnyObject
    Dim Datum As AnyObject
    Select Case HSFact.GetGeometricalFeatureType(Ref)
        Case 1 'Point
            Set Datum = HSFact.AddNewPointDatum(Ref)
        Case 2 'Curve
            Set Datum = HSFact.AddNewCurveDatum(Ref)
        Case 3 'Line
            Set Datum = HSFact.AddNewLineDatum(Ref)
        Case 4 'Circle
            Set Datum = HSFact.AddNewCircleDatum(Ref)
        Case 5 'Surface
            Set Datum = HSFact.AddNewSurfaceDatum(Ref)
        Case 6 'Plane
            Set Datum = HSFact.AddNewPlaneDatum(Ref)
        Case 7 'Volume
            Set Datum = HSFact.AddNewVolumeDatum(Ref)
    End Select
    Call Part.UpdateObject(Datum)
    Set CreateDatum = Datum
End Function

'形状ｾｯﾄのｺﾋﾟﾍﾟ
Private Function CopyPasteHybridBody(HBody As HybridBody) As HybridBody
    With sel
        .Clear
        .Add HBody
        .Copy
        .Clear
        .Add Part
        .Paste
    End With
    With Part.HybridBodies
        Set CopyPasteHybridBody = .Item(.Count)
    End With
End Function

'平面の選択
Private Function SelectPlanarFace() As Reference
    Dim FilterType(0)  As Variant
    FilterType(0) = "PlanarFace"
    Call SelectItem(FilterType, "対称基準となる平面を選択して下さい / ESCｷｰ ｷｬﾝｾﾙ")
    Set SelectPlanarFace = Part.CreateReferenceFromBRepName( _
                    GetBrepName(sel.Item(1).Value.Name), sel.Item(1).Value.Parent)
End Function

'SelectElement用BrapName取得
Private Function GetBrepName(MyBRepName As String) As String
    MyBRepName = Replace(MyBRepName, "Selection_", "")
    MyBRepName = Left(MyBRepName, InStrRev(MyBRepName, "));"))
    MyBRepName = MyBRepName + ");WithPermanentBody;WithoutBuildError;WithSelectingFeatureSupport;MFBRepVersion_CXR15)"
    GetBrepName = MyBRepName
End Function

'形状ｾｯﾄ選択
Private Function SelectHybridBody() As HybridBody
    Dim FilterType(0)  As Variant
    FilterType(0) = "HybridBody"
    Call SelectItem(FilterType, "元となる形状ｾｯﾄを選択して下さい / ESCｷｰ ｷｬﾝｾﾙ")
    Set SelectHybridBody = sel.Item(1).Value
End Function

'選択
Private Sub SelectItem(FilterType As Variant, Msg As String)
    sel.Clear
    If sel.SelectElement2(FilterType, Msg, False) = "Cancel" Then End
End Sub

SymmetryItem関数を修正し、GetColor関数、SetColor関数の2個を追加
しました。

ｵﾌｾｯﾄ平面をﾘﾈｰﾑ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

ほぼ使わないので存在すら忘れていましたが、こちらのバッチマネージャに
印刷バッチがある事に気が付きました。

起動しプリンタでCubePDFを指定すると出ます。

しかも良く見ると、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コントロールを利用する為に
参照設定でこちらの

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

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

Drawﾋﾞｭｰのリンク元ﾌｧｲﾙ名のチェック

タイトルが正しくないのですが、Drawのﾋﾞｭｰの参照元ファイル名と
Drawファイルのファイル名が一致しているかどうかをﾁｪｯｸします。

'vba Link_DrawLinkCheck ver0.0.1  using-'KCL0.0.12'  by Kantoku
'Drawのﾋﾞｭｰ参照元ﾌｧｲﾙ名とDrawﾌｧｲﾙ名の一致確認
'OK - ﾌｧｲﾙ名一致
'NG - ﾌｧｲﾙ名食い違い
'Nothing - ﾘﾝｸ無し

Option Explicit

Sub CATMain()
    'ﾄﾞｷｭﾒﾝﾄのﾁｪｯｸ
    If Not CanExecute("DrawingDocument") Then Exit Sub
    
    'views
    Dim viws As DrawingViews
    Set viws = CATIA.ActiveDocument.Sheets.ActiveSheet.Views
    
    'get
    Dim infos As Object
    Set infos = KCL.InitLst()
    
    Dim i As Long
    For i = 3 To viws.count
        infos.Add GetViewLinkInfo(viws.Item(i))
    Next
    
    'done
    MsgBox Join(infos.toArray(), "")
End Sub

'ﾋﾞｭｰﾘﾝｸ情報
Private Function GetViewLinkInfo( _
    ByVal vi As DrawingView) As String
    
    Dim fso As Object
    Set fso = KCL.GetFSO()
    
    'viewのdoc
    Dim drw_doc As DrawingDocument
    Set drw_doc = KCL.GetParent_Of_T(vi, "DrawingDocument")
    
    Dim drw_name As String
    drw_name = fso.GetBaseName(drw_doc.path)
    
    'refのdoc
    Dim behv As DrawingViewGenerativeBehavior
    Set behv = vi.GenerativeBehavior
    
    Dim ref_Doc As Document
    Set ref_Doc = GetBehaviorDoc(behv)
    
    Dim ref_name As String
    If ref_Doc Is Nothing Then
        ref_name = vbNullString
    Else
        ref_name = fso.GetBaseName(ref_Doc.path)
    End If
    
    'info
    Dim info As String
    info = "[" & vi.name & "]-"
    
    Select Case True
        Case drw_name = ref_name
            info = info & "OK" & vbCrLf
        Case ref_name = vbNullString
            info = info & "Nothing" & vbCrLf
        Case Else
            info = info & "NG!!!" & vbCrLf & _
                "     path:" & ref_Doc.path & vbCrLf
    End Select
    
    GetViewLinkInfo = info
End Function

Private Function GetBehaviorDoc( _
    ByVal behv As DrawingViewGenerativeBehavior) As Document
    
    On Error Resume Next
    
    Dim v As Variant
    Set v = behv.Document
    
    Set GetBehaviorDoc = v.Parent
    
    On Error GoTo 0
End Function

実行するとこんな感じです。

UUID違いの物を、こちらの方法で差し替えたつもりでも
変わってくれない為、手っ取り早く確認したいからです。
同一UUIDのDraw参照元ファイルを差し替える1 - C#ATIA

恐らく、ここを取得しているんじゃないかと思います。

違うかな？

念の為、こちらのプロパティ

Set v = behv.Document

"Document" じゃなくて "Product" が返ってきます。