ThisWorkbook '===================================================================================================================== Option Explicit '===================================================================================================================== MainSheet '===================================================================================================================== Option Explicit Private Sub btnRun_Click() 連続処理実行 End Sub '===================================================================================================================== MainMod '===================================================================================================================== Option Explicit Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Const DataMax As Long = 20 '連続処理設定最大数 Const Cnf_Col_Value As Long = 4 '設定の値記述列 Const Cnf_Row_TryCutPath As Long = 2 'TRYCUTパス記述行 Const Cnf_Row_WorkDir As Long = 4 '作業ディレクトリ記述行 Const Cnf_Row_TTLFile As Long = 5 '工具定義ファイル記述行 Const Cnf_Row_OutputFile As Long = 7 '出力作業指示書名記述行 Const Cnf_Col_ArborDef As Long = 3 Const Cnf_Col_ArborName As Long = 5 Const Cnf_Row_ArborOrigin As Long = 11 Const Cnf_Col_WorkFile As Long = 3 '各工程の指定ワーク記述列 Const Cnf_Col_NCFile As Long = 4 '各工程のNCファイル記述列 Const Cnf_Col_ResultDmf As Long = 5 '各工程の結果DMFファイル記述列 Const Cnf_Row_ProcOrigin As Long = 16 '各工程設定の記述開始行 '設定構造体 Type CONFIG TRYCUTEXE_Name As String 'TRYCUT.EXE のフルパス Work_Dir As String '作業ディレクトリ TTLFile_Name As String '工具定義ファイル のフルパス OutputFile_Name As String '出力作業指示書名 WorkFile() As String '連続処理時のワークファイル名配列 NCFile() As String '連続処理時のNCファイル名配列 ResultFile() As String '連続処理時の結果DMFファイル名配列 End Type '結果ステータス Type ResultStatus LogStatus As String TNo() As Long TLength() As String End Type Type Magazine ToolName As String ChackName As String End Type Const Magazine_Max As Long = 200 Const Res_Row_Page_Title As Long = 2 Const Res_Row_Table_Title As Long = 4 Private CurrentRow As Long Const Res_Page_Title As String = "加 工 指 示 書" Private Res_Table_Column(1 To 6) As String Const Column_NCFile As Long = 1 Const Column_ToolNo As Long = 2 Const Column_ToolName As Long = 3 Const Column_Chacking As Long = 4 Const Column_Hang As Long = 5 Const Column_Status As Long = 6 '-------------------------------------------------------------------------------------------------------------------- Private Sub Initialize() Res_Table_Column(Column_NCFile) = "NC File" Res_Table_Column(Column_ToolNo) = "工具番号" Res_Table_Column(Column_ToolName) = "工具名称" Res_Table_Column(Column_Chacking) = "チャッキング形式" Res_Table_Column(Column_Hang) = "突出し長" Res_Table_Column(Column_Status) = "シミュレーションステータス" End Sub '-------------------------------------------------------------------------------------------------------------------- Private Sub OutputResult(objSH As Worksheet, NCFile As String, Mag() As Magazine, Status As ResultStatus) '結果を出力する Dim I As Long Dim sTmp As String Dim loFs As New FileSystemObject With objSH For I = LBound(Status.TNo) To UBound(Status.TNo) If I = LBound(Status.TNo) Then .Cells(CurrentRow, Column_NCFile) = Mid(NCFile, InStrRev(NCFile, "\") + 1) .Cells(CurrentRow, Column_ToolNo) = Status.TNo(I) .Cells(CurrentRow, Column_ToolName) = Mag(Status.TNo(I)).ToolName .Cells(CurrentRow, Column_Chacking) = Mag(Status.TNo(I)).ChackName .Cells(CurrentRow, Column_Hang) = Status.TLength(I) '文字列として出力 .Cells(CurrentRow, Column_Status) = "'" & Status.LogStatus Next I End With CurrentRow = CurrentRow + 1 End Sub '-------------------------------------------------------------------------------------------------------------------- Sub 連続処理実行() Dim Conf As CONFIG Dim Mag() As Magazine OpenConfig Conf, Mag() Dim N As Integer Dim objWB As Workbook Dim objSH As Worksheet Dim ExecString As String Dim CurrentDir As String Dim Status As ResultStatus Dim OutputDMF As String Dim WorkDMF As String Dim Fs As New FileSystemObject Dim objFile As File Dim SimFlag As Boolean Call Initialize '設定の読み込み LoadConfig Conf 'TTL 読み込み If Not Fs.FileExists(Conf.TTLFile_Name) Then MsgBox "指定の工具定義ファイル " & Conf.TTLFile_Name & " が見つかりません。" Exit Sub End If LoadTool Conf, Mag() '出力作業指示書用BOOK の作成 Set objWB = Workbooks.Add Set objSH = objWB.ActiveSheet '出力BOOK のヘッダー作成 OutputHeader objSH 'Current Directry ChDrive Left(Conf.Work_Dir, 1) ChDir Conf.Work_Dir CurrentDir = CurDir If Right(CurrentDir, 1) <> "\" Then CurrentDir = CurrentDir & "\" '各工程の加工処理 For N = LBound(Conf.WorkFile) To UBound(Conf.WorkFile) 'NCFile に空文字が見つかったら終了 If Conf.NCFile(N) = "" Then Exit For 'ワークDMFファイル名 WorkDMF = Conf.Work_Dir & Conf.WorkFile(N) '結果出力DMFファイル名 OutputDMF = Conf.Work_Dir & Conf.ResultFile(N) On Error Resume Next '結果出力DMF が存在すれば削除 If Fs.FileExists(OutputDMF) Then Fs.DeleteFile OutputDMF, True '解析簡略のため、Trycut.log を削除 If Fs.FileExists(CurrentDir & "Trycut.log") Then Fs.DeleteFile CurrentDir & "Trycut.log", True '解析簡略のため、突出し長.txt を削除 If Fs.FileExists(CurrentDir & "突出し長.txt") Then Fs.DeleteFile CurrentDir & "Trycut.log", True On Error GoTo 0 'ワークファイルのサイズが0ならシミュレーションしない SimFlag = False If Fs.FileExists(WorkDMF) Then Set objFile = Fs.GetFile(WorkDMF) If objFile.Size > 0 Then SimFlag = True Else 'ステータスの設定 OpenStatus Status, 0 Status.LogStatus = "指定ワークのファイルサイズが異常です。" Status.TNo(0) = 0 Status.TLength(0) = 0 End If Set objFile = Nothing Else 'ステータスの設定 OpenStatus Status, 0 Status.LogStatus = "指定ワークのファイルが見つかりません。" Status.TNo(0) = 0 Status.TLength(0) = 0 End If If SimFlag Then 'TRYCUT 起動コマンドの作成 → 起動 ExecString = Chr(&H22) & Conf.TRYCUTEXE_Name & Chr(&H22) & _ " /x6 /t " & Chr(&H22) & Conf.TTLFile_Name & Chr(&H22) & _ " /d " & Chr(&H22) & WorkDMF & Chr(&H22) & _ " /o " & Chr(&H22) & OutputDMF & Chr(&H22) & _ " " & Chr(&H22) & Conf.Work_Dir & Conf.NCFile(N) & Chr(&H22) '起動 Shell ExecString '処理が終了するまで待機 (OutputDMF を監視) Waiting OutputDMF 'log および 必要突出長 の読み込み GetResult CurrentDir, Status End If '結果を作業指示書に反映 OutputResult objSH, Conf.NCFile(N), Mag(), Status Next N '作業指示書の後処理 SheetAutoFit objSH '作業指示書の保存 objSH.Cells(1, 1).Select On Error Resume Next If Dir(Conf.OutputFile_Name) Then Kill Conf.OutputFile_Name On Error GoTo ERR_SAVE objWB.SaveAs Conf.OutputFile_Name objWB.Close False MsgBox "全ての処理が完了しました", vbInformation Exit Sub ERR_SAVE: MsgBox "ファイルの保存に失敗しました。" & vbCrLf & vbCrLf & Err.Description, vbExclamation End Sub '-------------------------------------------------------------------------------------------------------------------- Private Function ReadCells(lRow As Long, lCol As Long) As String '指定場所のセルを読み込み、値を文字列で返す Dim vTmp As Variant vTmp = Cells(lRow, lCol) If IsEmpty(vTmp) Then ReadCells = "" Else ReadCells = CStr(vTmp) End If End Function '-------------------------------------------------------------------------------------------------------------------- Private Sub LoadConfig(Conf As CONFIG) Dim N As Integer '設定の読み込み Conf.TRYCUTEXE_Name = ReadCells(Cnf_Row_TryCutPath, Cnf_Col_Value) Conf.Work_Dir = ReadCells(Cnf_Row_WorkDir, Cnf_Col_Value) If Right(Conf.Work_Dir, 1) <> "\" Then Conf.Work_Dir = Conf.Work_Dir & "\" Conf.TTLFile_Name = ReadCells(Cnf_Row_TTLFile, Cnf_Col_Value) Conf.OutputFile_Name = ReadCells(Cnf_Row_OutputFile, Cnf_Col_Value) For N = LBound(Conf.WorkFile) To UBound(Conf.WorkFile) Conf.WorkFile(N) = ReadCells(Cnf_Row_ProcOrigin + N, Cnf_Col_WorkFile) Conf.NCFile(N) = ReadCells(Cnf_Row_ProcOrigin + N, Cnf_Col_NCFile) Conf.ResultFile(N) = ReadCells(Cnf_Row_ProcOrigin + N, Cnf_Col_ResultDmf) 'WorkFile に空文字が見つかったら終了 If Conf.WorkFile(N) = "" Then Exit For Next N End Sub '-------------------------------------------------------------------------------------------------------------------- Private Sub OpenConfig(Conf As CONFIG, Mag() As Magazine) '連続処理設定最大数の反映 ReDim Conf.WorkFile(1 To DataMax) As String ReDim Conf.NCFile(1 To DataMax) As String ReDim Conf.ResultFile(1 To DataMax) As String 'マガジン設定最大数の反映 ReDim Mag(1 To Magazine_Max) As Magazine End Sub '-------------------------------------------------------------------------------------------------------------------- Private Sub MakeBorder(objRange As Range, Index As XlBordersIndex, Weight As XlBorderWeight) With objRange.Borders(Index) .LineStyle = xlContinuous .Weight = Weight .ColorIndex = xlAutomatic End With End Sub '-------------------------------------------------------------------------------------------------------------------- Private Sub SheetAutoFit(objSH As Worksheet) Dim objR As Range Dim I As Long With objSH Set objR = .Columns(Chr(&H40 + LBound(Res_Table_Column)) & ":" & Chr(&H40 + UBound(Res_Table_Column))) objR.EntireColumn.AutoFit '罫線 Set objR = .Range(.Cells(Res_Row_Table_Title, LBound(Res_Table_Column)), _ .Cells(CurrentRow - 1, UBound(Res_Table_Column))) MakeBorder objR, xlInsideHorizontal, xlThin MakeBorder objR, xlInsideVertical, xlThin MakeBorder objR, xlEdgeTop, xlMedium MakeBorder objR, xlEdgeBottom, xlMedium MakeBorder objR, xlEdgeLeft, xlMedium Set objR = .Range(.Cells(Res_Row_Table_Title, LBound(Res_Table_Column)), _ .Cells(Res_Row_Table_Title, UBound(Res_Table_Column))) MakeBorder objR, xlEdgeBottom, xlMedium For I = LBound(Res_Table_Column) To UBound(Res_Table_Column) Set objR = .Range(.Cells(Res_Row_Table_Title, I), .Cells(CurrentRow - 1, I)) MakeBorder objR, xlEdgeRight, xlMedium Next I End With End Sub '-------------------------------------------------------------------------------------------------------------------- Private Sub OutputHeader(objSH As Worksheet) Dim objR As Range Dim I As Long '加工指示書ヘッダー部分の出力 With objSH Set objR = .Range(.Cells(Res_Row_Page_Title, LBound(Res_Table_Column)), _ .Cells(Res_Row_Page_Title, UBound(Res_Table_Column))) With objR .MergeCells = True .Font.Size = 16 .Font.Bold = True .HorizontalAlignment = xlCenter .Value = Res_Page_Title End With Set objR = .Range(.Cells(Res_Row_Table_Title, LBound(Res_Table_Column)), _ .Cells(Res_Row_Table_Title, UBound(Res_Table_Column))) With objR .Font.Bold = True .HorizontalAlignment = xlCenter End With For I = LBound(Res_Table_Column) To UBound(Res_Table_Column) .Cells(Res_Row_Table_Title, I) = Res_Table_Column(I) Next I '書式 Set objR = .Cells(1, Column_Hang) objR.EntireColumn.NumberFormatLocal = "0.000_ " Set objR = .Cells(1, Column_ToolNo) objR.EntireColumn.HorizontalAlignment = xlCenter End With CurrentRow = Res_Row_Table_Title + 1 End Sub '-------------------------------------------------------------------------------------------------------------------- Private Sub LoadTool(Conf As CONFIG, Mag() As Magazine) Dim FNo As Integer Dim Rec As String Dim strNo As String Dim Index As Long Dim strArb As String Dim vRec As Variant Dim ChackN() As String Dim I As Long Index = 0 strArb = "" 'TTL 読み込み FNo = FreeFile Open Conf.TTLFile_Name For Input As FNo While Not EOF(FNo) Line Input #FNo, Rec Rec = Trim(Rec) If UCase(Left(Rec, 3)) = "MAG" Then 'マガジン番号 strNo = Mid(SepDelim(Rec, "="), Len("MAGAZINE") + 1) If IsNumeric(strNo) Then Index = CLng(strNo) 'ARBOR 一括設定をセットしておく Mag(Index).ChackName = strArb End If End If If Index = 0 And UCase(Left(Rec, 3)) = "ARB" Then 'ARBOR 一括設定 strArb = Rec End If If Index > 0 Then '工具、チャックの取得 SetTTLValue Rec, Mag(Index) End If Wend Close FNo 'チャック名称の反映 ReDim ChackN(0 To 1, 1 To Magazine_Max) As String I = LBound(ChackN, 2) Do vRec = Cells(I + Cnf_Row_ArborOrigin - LBound(ChackN, 2), Cnf_Col_ArborDef) If IsEmpty(vRec) Then Exit Do ChackN(0, I) = CStr(vRec) vRec = Cells(I + Cnf_Row_ArborOrigin - LBound(ChackN, 2), Cnf_Col_ArborName) If IsEmpty(vRec) Then ChackN(1, I) = "" Else ChackN(1, I) = Trim(UCase(CStr(vRec))) End If I = I + 1 Loop ReDim Preserve ChackN(0 To 1, 1 To I - 1) As String For Index = LBound(Mag) To UBound(Mag) Rec = Trim(UCase(Mag(Index).ChackName)) If Rec <> "" Then For I = LBound(ChackN, 2) To UBound(ChackN, 2) If InStr(ChackN(0, I), Rec) > 0 Then Mag(Index).ChackName = ChackN(1, I) Exit For End If Next I End If Next Index End Sub '-------------------------------------------------------------------------------------------------------------------- Private Sub SetTTLValue(Rec As String, Mag As Magazine) Select Case UCase(Left(Rec, 3)) Case "CUT" '工具 CUTTER文 Mag.ToolName = GetToolName(Rec, 7, "一般形状工具") Case "BAL" '工具 BALL文 Mag.ToolName = GetToolName(Rec, 2, "ボールエンド") Case "TAP" '工具 TAPERBALL文 Mag.ToolName = GetToolName(Rec, 3, "テーパーボール") Case "FLA" '工具 FLAT文 Mag.ToolName = GetToolName(Rec, 2, "フラットエンド") Case "BUL" '工具 BULL文 Mag.ToolName = GetToolName(Rec, 3, "ブルノーズミル") Case "RAD" '工具 RADIUS文 Mag.ToolName = GetToolName(Rec, 3, "ラジアスミル") Case "VER" '工具 VARTICAL文 Mag.ToolName = GetToolName(Rec, 3, "バーチカルミル") Case "OVA" '工具 OVAL,OVALR文 If UCase(Left(Rec, 5)) = "OVALR" Then Mag.ToolName = GetToolName(Rec, 5, "複合楕円工具") Else Mag.ToolName = GetToolName(Rec, 4, "楕円工具") End If Case "KEG" '工具 KEGAKI文 Mag.ToolName = GetToolName(Rec, 2, "罫書き工具") Case "ARB" 'ARBOR 文 Mag.ChackName = Rec Case Else 'その他の定義は読み込み不要 End Select End Sub '-------------------------------------------------------------------------------------------------------------------- Private Function GetToolName(Rec As String, Index As Long, Default As String) As String Dim I As Long Dim Source As String Source = Rec For I = 1 To Index SepDelim Source, "," Next I If Source = "" Then Source = Default GetToolName = Source End Function '-------------------------------------------------------------------------------------------------------------------- Private Function SepDelim(Source As String, Delim As String) As String Dim D As Long D = InStr(Source, Delim) If D <= 0 Then '無し SepDelim = Source Source = "" Exit Function End If SepDelim = Trim(Left(Source, D - 1)) Source = Trim(Mid(Source, D + Len(Delim))) End Function '-------------------------------------------------------------------------------------------------------------------- Private Sub Waiting(WatchFile As String) '出力DMFのアクセスに成功するまで待機 Dim FNo As Integer Dim Cnt As Long Do On Error Resume Next FNo = FreeFile Open WatchFile For Input As FNo If Err.Number = 0 Then 'アクセス成功 Close FNo On Error GoTo 0 Exit Do End If On Error GoTo 0 'アクセス失敗 DoEvents Sleep 1000 '1秒間停止 Loop DoEvents Sleep 1000 '確実性確保のための待機 DoEvents End Sub '-------------------------------------------------------------------------------------------------------------------- Private Sub GetResult(CurrentDir As String, Status As ResultStatus) 'Log,突出し長ファイルを読み込んで結果をStatusにセットする Dim FName As String Dim FNo As Integer Dim Rec As String Dim Count As Long Dim sTmp As String If Right(CurrentDir, 1) <> "\" Then CurrentDir = CurrentDir & "\" '突出し長 FName = CurrentDir & "突出し長.txt" On Error Resume Next FNo = FreeFile Open FName For Input As FNo If Err.Number = 0 Then On Error GoTo 0 'アクセス成功 OpenStatus Status, Magazine_Max '最初の行は無視 If Not EOF(FNo) Then Line Input #FNo, Rec Count = 0 While Not EOF(FNo) 'ツール番号 Line Input #FNo, Rec sTmp = Mid(SepDelim(Rec, ":"), 2) If IsNumeric(sTmp) Then Status.TNo(Count) = CLng(sTmp) End If SepDelim Rec, "突出=" Status.TLength(Count) = NumPickup(Rec) Count = Count + 1 Wend If Count = 0 Then OpenStatus Status, 0 Status.TNo(0) = 0 Status.TLength(0) = "工具が見つかりません" Else OpenStatus Status, Count, True End If Close FNo Else On Error GoTo 0 OpenStatus Status, 0 Status.TNo(0) = 0 Status.TLength(0) = "ファイルが見つかりません" End If 'Log FName = CurrentDir & "trycut.log" On Error Resume Next FNo = FreeFile Open FName For Input As FNo If Err.Number = 0 Then On Error GoTo 0 'アクセス成功→最後の行を読んで解析 While Not EOF(FNo) Line Input #FNo, Rec Wend Status.LogStatus = SepDelim(Rec, ":") 'ステータス SepDelim Rec, " - " If Rec = "" Then Rec = "正常終了" Status.LogStatus = Status.LogStatus & " - " & Rec Close FNo Else On Error GoTo 0 Status.LogStatus = "ログファイルを読み込めません" End If End Sub '-------------------------------------------------------------------------------------------------------------------- Private Sub OpenStatus(Status As ResultStatus, TCount As Long, Optional PreserveFlaf As Boolean = False) Dim UB As Long If TCount > 0 Then UB = TCount - 1 Else UB = 0 If PreserveFlaf Then ReDim Preserve Status.TNo(0 To UB) As Long ReDim Preserve Status.TLength(0 To UB) As String Else ReDim Status.TNo(0 To UB) As Long ReDim Status.TLength(0 To UB) As String End If End Sub '-------------------------------------------------------------------------------------------------------------------- Private Function NumPickup(strValue As String) As Double '先頭から数値として判断できる部分のみを取り出す Dim S As String Dim Result As String Dim N As Long N = 1 Do S = Left(strValue, N) If Not IsNumeric(S) Or N > Len(strValue) Then Exit Do Result = S N = N + 1 Loop NumPickup = CDbl(Result) End Function '=====================================================================================================================