Space-e D&Dでﾌｧｲﾙ変換するｽﾌﾟﾘｸﾄ

気が付いたら、今月は一度もﾌﾞﾛｸﾞを書いていませんでした。
（案外、業務以外の事が忙しい・・・）

以前、CATIA V5でD&Dでﾌｧｲﾙ変換するｽﾌﾟﾘｸﾄを作成しました。
D&DでIgesﾌｧｲﾙを変換する(ｵﾏｹ付き) - C#ATIA

業務では他にSpace-eと言うCADCAMを利用しているのですが、こちらでも類似したものを
作り利用しています。　但し、使用しているｿﾌﾄのﾊﾞｰｼﾞｮﾝが古く最近のﾊﾞｰｼﾞｮﾝでは
"ｴﾗｰが出て動かなかったよ" と客先に言われ公開出来ずにいたのですが、
最近になりVer5.5を触る機会があり修正出来ました、ので公開。

Option Explicit
'vbs igs2mdp006.vbs by kantoku
'Space-e用iges mdp sat変換スプリクト ver0.06

Dim igs2mdp
Dim igs2mdp_param
Dim mdp2igs
Dim mdp2igs_param

'*************************
'設定-デフォルトインストールであれば変更不要
'igs→mdp
igs2mdp = "C:\HZS\Iges\iges2mdp_exe.exe"
igs2mdp_param = "C:\HZS\Iges\spacee\iges2mdp_param.bat"
'mdp→igs
mdp2igs = "C:\HZS\Iges\mdp2iges_exe.exe"
mdp2igs_param = "C:\HZS\Iges\spacee\mdp2iges_param.bat"
'*************************
Dim FSO 'FileSystemObject
Dim wShell 'WScript.Shell

Call Main
Set FSO = Nothing
WScript.Quit 0

Sub Main()
    'メインルーチン
    Dim sMsg '各種メッセージ
    Dim I
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set wShell = CreateObject("WScript.Shell")
    
    '設定されたファイルがあるかチェック
    sMsg = "設定に誤りがあります。ソースの設定を修正し実行してください"
    
    'D&Dチェック
    Dim objArgs 'D&D

    Set objArgs = WScript.Arguments
    If Drop(objArgs) Then Exit Sub 'クリック時

    'D&D Iges Mdpファイルリスト取得
    'Dim sFilePath '0-フォルダ名+"\",1-ファイル名,2-"."+拡張子 :ReDim Preserve 使用の為逆
    Dim IgesFileList() 'Iges変換ファイルリスト
    Dim MdpFileList() 'space-e変換ファイルリスト
    
    Call CreateDDList(objArgs, IgesFileList, MdpFileList)
    Set objArgs = Nothing
    
    '作業フォルダ（パラメータ保存用フォルダ・削除チェック）取得
    Dim ParaFolderPath '作業用フォルダパス
    
    If UBound(IgesFileList, 2) > 0 Then
        ParaFolderPath = IgesFileList(0, 0) & "心当たりがない場合は削除してください"
    ElseIf UBound(MdpFileList, 2) > 0 Then
        ParaFolderPath = MdpFileList(0, 0) & "心当たりがない場合は削除してください"
    Else
        sMsg = "変換すべきファイルがありません"
        MsgBox (sMsg)
        Exit Sub
    End If
    
    '作業中チェック
    If FSO.FolderExists(ParaFolderPath) Then
        '作業中
        sMsg = "変換の処理中の可能性があります。変換処理が終了してから再度行ってください。" & vbCrLf
        sMsg = sMsg & "万一、変換処理が終了している場合は、手動で" & vbCrLf
        sMsg = sMsg & "「" & ParaFolderPath & "」" & vbCrLf
        sMsg = sMsg & "フォルダを削除してください。"
        MsgBox (sMsg)
        Exit Sub
    End If
    
    'Igesファイルに対しての処理選択
    Dim IgsYN 'レベル・カラー両方変換
    
    If UBound(IgesFileList, 2) > 0 Then
        sMsg = CStr(UBound(IgesFileList, 2)) & "個のIgesファイルがあります。" & vbCrLf
        sMsg = sMsg & "レベル(クラス・レイヤ)とカラーの条件で変換しますか？" & vbCrLf
        sMsg = sMsg & "(はいの場合、1つのIgesファイルに対し2度変換を行うため非常に時間がかかります)"
        IgsYN = MsgBox(sMsg, vbYesNo)
    Else
        IgsYN = vbNo
    End If
    
    '作業フォルダ作成
    FSO.CreateFolder ParaFolderPath
    
    '一時パラメータ作成
    Dim igs2mdp_param_Level 'Iges-Level変換パラメータパス
    Dim igs2mdp_param_Color 'Iges-Color変換パラメータパス
    Dim TempPara 'パラメータ一時ファイル
    Dim Std_Param_Top ' "#"の文字位置
    Dim Std_Param_Count
    Dim IgesParaBase 'パラメータベース
    Dim Std_Param_Head 'パラメータヘッダー
    '****************************
    'Ver0.03より追加-Igesをレベル/カラー2つ変換するときのみ使用している
    Const Std_Param_Txt = "std_param:"
    Std_Param_Head = "conv_type:" & vbCrLf & "type_name = " & Chr(34) & "iges2mdp" & Chr(34) & ";" & vbCrLf
    '****************************
    
    If IgsYN = vbYes Then
        igs2mdp_param_Level = ParaFolderPath & "\iges2mdp_param_Level.bat"
        igs2mdp_param_Color = ParaFolderPath & "\iges2mdp_param_Color.bat"
        TempPara = GetFileTxt(igs2mdp_param)
        Std_Param_Top = GetParaTop(TempPara, Std_Param_Txt, "#")
        Std_Param_Count = Len(Std_Param_Txt)
        IgesParaBase = Mid(TempPara, Std_Param_Top + Std_Param_Count)
        Std_Param_Head = Std_Param_Head & Std_Param_Txt & vbCrLf
        Call WriteParaFileTxt(igs2mdp_param_Level, Std_Param_Head, IgesParaBase, "class = 1;")
        Call WriteParaFileTxt(igs2mdp_param_Color, Std_Param_Head, IgesParaBase, "class = 2;")
    End If
    
    '削除目安の為のファイルカウント数取得
    Dim DelCheck '削除目安カウンタ
    
    DelCheck = FSO.GetFolder(ParaFolderPath).Files.Count
    
    '削除タイミングを調整するダミーファイル作成
    sWord = "このファイルはバッチ確認用のファイルです。心当たりがない場合は削除して結構です。" & vbCrLf
    Call WriteFileTxt(ParaFolderPath & "\" & "temp.txt", sWord) 'ダミーファイル書き出し
    
    '変換バッチ
    Dim BatCount '変換を実行するファイル数
    Dim sWord 'バッチ書き出し用テキスト
    Dim Fname '変換バッチﾌｧｲﾙ用ファイル名
    
    BatCount = 0
    'Mdp2Igs
    If UBound(MdpFileList, 2) > 0 Then
        For I = 0 To UBound(MdpFileList, 2) - 1
            Fname = CheckFname(MdpFileList(0, I) & MdpFileList(1, I), ".igs", 0)
            BatCount = BatCount + 1
            Call CreateBatFile(mdp2igs, MdpFileList(0, I) & MdpFileList(1, I) & MdpFileList(2, I), Fname, ".igs", mdp2igs_param, 

ParaFolderPath, BatCount)
        Next
    End If
    
    'Igs2Mdp
    Dim Fname_Level 'Iges-Level変換バッチﾌｧｲﾙ用ファイル名
    Dim Fname_Color 'Iges-Color変換バッチﾌｧｲﾙ用ファイル名
    
    If UBound(IgesFileList, 2) > 0 Then
        For I = 0 To UBound(IgesFileList, 2) - 1
            If IgsYN = vbYes Then
                'Level
                Fname_Level = CheckFname(IgesFileList(0, I) & IgesFileList(1, I) & "_Level", ".mdp", 0)
                BatCount = BatCount + 1
                Call CreateBatFile(igs2mdp, IgesFileList(0, I) & IgesFileList(1, I) & IgesFileList(2, I), Fname_Level, ".mdp", 

igs2mdp_param_Level, ParaFolderPath, BatCount)
                'Color
                Fname_Color = CheckFname(IgesFileList(0, I) & IgesFileList(1, I) & "_Color", ".mdp", 0)
                BatCount = BatCount + 1
                Call CreateBatFile(igs2mdp, IgesFileList(0, I) & IgesFileList(1, I) & IgesFileList(2, I), Fname_Color, ".mdp", 

igs2mdp_param_Color, ParaFolderPath, BatCount)
            Else
                Fname = CheckFname(IgesFileList(0, I) & IgesFileList(1, I), ".mdp", 0)
                BatCount = BatCount + 1
                Call CreateBatFile(igs2mdp, IgesFileList(0, I) & IgesFileList(1, I) & IgesFileList(2, I), Fname, ".mdp", 

igs2mdp_param, ParaFolderPath, BatCount)
            End If
        Next
    End If
    
    'ダミーファイル削除
    FSO.DeleteFile ParaFolderPath & "\" & "temp.txt"
    
    '終了確認
    Do
        If FSO.GetFolder(ParaFolderPath).Files.Count <= DelCheck Then Exit Do
        WScript.Sleep 100
    Loop
    
    '作業フォルダ削除
    FSO.DeleteFolder ParaFolderPath
    
    MsgBox ("処理が終了しました")
End Sub

Function Drop(DDFiles)
    'ドロップ処理
    If DDFiles.Count = 0 Then
        'ダブルクリック
        MsgBox ("Space-eやIges・SATファイルをD&Dしてください")
        Drop = True
    Else
        Drop = False
    End If
End Function

Function IgesCheck(ExtensionName)
    'Igesファイルか拡張子チェック
    IgesCheck = True
    Select Case LCase(ExtensionName)
        Case ".igs"
            'igesファイル
        Case ".iges"
            'igesファイル
        Case ".ig2"
            'igesファイル
        Case Else
            'Igesファイル以外
            IgesCheck = False
    End Select
End Function

Function MdpCheck(ExtensionName)
    'space-eファイルか拡張子チェック
    MdpCheck = True
    Select Case LCase(ExtensionName)
        Case ".mdp"
            'mdpファイル
        Case ".sat" 'SATファイル対応Ver005
            'satファイル
        Case Else
            'mdpファイル以外
            MdpCheck = False
    End Select
End Function

Function GetFilePathData(sPath)
    'ファイルパス等取得
    Dim Temp()
    ReDim Temp(2)
    With FSO
        Temp(0) = Trim(.GetFile(sPath).ParentFolder & "\")
        Temp(1) = .GetBaseName(sPath)
        Temp(2) = "." & .GetExtensionName(sPath)
    End With
    GetFilePathData = Temp
    Erase Temp
End Function

Sub CreateDDList(ByVal oArgs, ByRef IgesFList, ByRef MdpFList)
    'Iges Mdpファイルリスト取得
    Dim sFPath '0-フォルダ名+"\",1-ファイル名,2-"."+拡張子 :ReDim Preserve 使用の為逆
    Dim I
    Dim IgesListCount 'Iges変換ファイルカウント
    Dim MdpListCount 'Iges変換ファイルカウント

    ReDim IgesFList(2, oArgs.Count)
    ReDim MdpFList(2, oArgs.Count)
    IgesListCount = 0
    MdpListCount = 0
    
    For I = 0 To oArgs.Count - 1
        sFPath = GetFilePathData(oArgs(I))
        If IgesCheck(sFPath(2)) Then
            IgesListCount = IgesListCount + 1
            IgesFList(0, IgesListCount - 1) = sFPath(0)
            IgesFList(1, IgesListCount - 1) = sFPath(1)
            IgesFList(2, IgesListCount - 1) = sFPath(2)
        ElseIf MdpCheck(sFPath(2)) Then
            MdpListCount = MdpListCount + 1
            MdpFList(0, MdpListCount - 1) = sFPath(0)
            MdpFList(1, MdpListCount - 1) = sFPath(1)
            MdpFList(2, MdpListCount - 1) = sFPath(2)
        End If
    Next
    Erase sFPath
    ReDim Preserve IgesFList(2, IgesListCount)
    ReDim Preserve MdpFList(2, MdpListCount)
End Sub

Function CheckFname(ByVal F0, ByVal F1, ByVal CopyCount)
    'ファイル重複チェック-再帰
    If FSO.FileExists(F0 & F1) Then
        CopyCount = CopyCount + 1
        If CopyCount > 1 Then
            CheckFname = CheckFname(Mid(F0, 1, Len(F0) - 4 - Len(CStr(CopyCount - 1))) & "_NEW" & CStr(CopyCount), F1, CopyCount)
        Else
            CheckFname = CheckFname(F0 & "_NEW" & CStr(CopyCount), F1, CopyCount)
        End If
    Else
        CheckFname = F0
    End If
End Function

Sub WriteFileTxt(ByVal Fname, ByVal sTxt)
    'ファイルの書き込み
    With FSO.CreateTextFile(Fname)
        .WriteLine sTxt
        .Close
    End With
End Sub

Function GetFileTxt(ByVal Fname)
    'ファイルの読み込み
    Dim buf
    
    With FSO.GetFile(Fname).OpenAsTextStream
        buf = .ReadAll
        GetFileTxt = buf
        .Close
    End With
End Function

Sub WriteParaFileTxt(ByVal Fname, ByVal sHead, ByVal sBase, ByVal sOp)
    'パラメータファイルの書き込み
    With FSO.CreateTextFile(Fname)
        .WriteLine sHead
        .WriteLine sOp
        .WriteLine sBase
        .WriteLine sOp '恐らく不要だが念のため
        .Close
    End With
End Sub

Function GetParaTop(ByVal sTxt, ByVal sWord, ByVal sNg)
    'パラメータトップ検索
    'コメント文を読み飛ばすため
    'もっとマシな方法あるはず・・・
    Dim TempStart, TempNow, TempNg, TempCrlf
    
    TempStart = 1
    TempNow = 1
    Do
        TempNow = InStr(TempStart, sTxt, sWord)
        If TempNow <> 0 Then
            TempNg = InStrRev(sTxt, sNg, TempNow)
            TempCrlf = InStrRev(sTxt, vbCrLf, TempNow)
            If TempNg < TempCrlf Then
                'ok
                GetParaTop = TempNow
                Exit Do
            Else
                'コメント文
                TempStart = TempNow + 1
            End If
        Else
            Exit Do
        End If
    Loop
End Function

Sub CreateBatFile(ByVal ExeName, ByVal F1, ByVal F2a, ByVal F2b, ByVal ParaPath, ByVal TempPath, ByVal iCount)
    'バッチファイル生成・実行
    Dim sWord
    
    sWord = "rem このファイルはバッチ確認用のファイルです。心当たりがない場合は削除して結構です。" & vbCrLf
    sWord = sWord & ExeName & " -i " & Chr(34) & F1 & Chr(34) & " -o " & Chr(34) & F2a & F2b & Chr(34) & " -b " & Chr(34) & ParaPath 

& Chr(34) & vbCrLf
    sWord = sWord & "del " & Chr(34) & TempPath & "\" & CStr(iCount) & ".bat" & Chr(34)
    Call WriteFileTxt(TempPath & "\" & CStr(iCount) & ".bat", sWord) 'バッチファイル書き出し
    wShell.Run Chr(34) & TempPath & "\" & CStr(iCount) & ".bat" & Chr(34) '即、実行
End Sub
'*************************
'ver0.01 10/**/** とりあえず基本完成
'ver0.02 10/07/13 バグ修正
'ver0.03 10/08/18 Igesファイルのみレベル/カラー2つ変換
'ver0.04 10/09/06 ソース全面改良、全ファイル同時変換化、ルートパススペース文字対応
'ver0.05 13/11/01 SAT→Igesを追加
'ver0.06 16/11/08 Ver5.5対応に修正
'*************************

未だに "HZS" ﾌｫﾙﾀﾞなんですよね、自分たちの会社名に誇りは無いのかと心配になっちゃいます。

元のｺｰﾄﾞは6年ぐらい前のようで、公開するﾚﾍﾞﾙではないぐらい汚いです。
(書き直す意欲なし･･･)

ｺｰﾄﾞをメモ帳にでもｺﾋﾟﾍﾟし、ﾌｧｲﾙ名を "igs2mdp006.vbs" とでもしておいて下さい。
このﾌｧｲﾙに変換したいﾌｧｲﾙをD&Dすれば、元のﾌｧｲﾙと同じﾌｫﾙﾀﾞ内に変換後のﾌｧｲﾙが
作成されます。

・Iges、sat　→　mdp に変換
・mdp　sat　→　Iges　に変換
・複数ﾌｧｲﾙD&Dした際、複数同時変換
・Iges、sat、mdp　ごちゃ混ぜでD&Dしてもそれなりに変換
　(但しIgesmdp、satの変換後ﾌｧｲﾙ名が同じになる場合、後の処理のものが上書きするかも)
・変換後のファイル名が重複する場合は、「○○○_NEW○.○○○」と言う名前で変換
・IgesをD&Dした際に限り、ﾚﾍﾞﾙ(ﾚｲﾔ)とｶﾗｰの両条件で変換するかﾀﾞｲｱﾛｸﾞが出ます。
　両条件で変換した際のﾌｧｲﾙ名は、レベルは「○○○_Level.mdp」カラーは「○○○_Color.mdp」
・変換する際の各種設定条件は、CADで開いた時と同じです
・あんまりｴﾗｰﾁｪｯｸしてないです・・・

利用できるのはSpace-eがｲﾝｽﾄｰﾙされているPCのみです。
恐らくﾃﾞﾌｫﾙﾄでｲﾝｽﾄｰﾙしていれば、このままで利用可能だと思いますが、
上手く動かない場合は、ｺｰﾄﾞ上部の "設定" のﾌｧｲﾙﾊﾟｽを修正すると動くような
気がしてます。
ﾃｽﾄはVer5.5で行っており、Ver5.0以降でないと動かないと思われます。

途中からsatを対応させたのは、CAM側にﾓﾃﾞﾙを取り込んだ際IMのﾌｫﾙﾀﾞ内にsatﾌｧｲﾙが出来ます。
これを変換する事で、他のCAMと併用して作業を行う際に加工原点が一致するからです。
(これが一番手軽だと後々に気が付きました)