路面衝立座標確認ツール

GlobalConstants

'座標入力セル削除範囲----------------------
Public Const roData As String = "B10:D59"
Public Const tsuData As String = "F10:H59"
'------------------------------------------

'campara格納フォルダ名-----------------------------
Public Const camParaFolder As String = "campara_and_Image"
'--------------------------------------------------

'bat名---------------------------------------------
Public Const batName As String = "CreateView.bat"
'--------------------------------------------------

'出力bmp名--------------------------------------
Public Const roBmp As String = "View_路面.bmp"
Public Const tsuBmp As String = "View_衝立.bmp"
'-----------------------------------------------

'入力csv名----------------------------------------------
Public Const roCsv As String = "PointSetFile_路面.csv"
Public Const tsuCsv As String = "PointSetFile_衝立.csv"
'-------------------------------------------------------

'共通注意文-------------------------------------------------------------------------------------
Public Const coution As String = "ファイル名またはファイルが格納されているか確認してください｡ "
'-----------------------------------------------------------------------------------------------

Initialize_Cls

Option Explicit

'使い方→http://dirtysexyquery.blogspot.jp/2011/01/Clear_Vars.html
' 変数を初期化します。
' 配列と構造体(Type関数)は受け付けないので、注意。
' 使用例: Clear_Vars db, rs, myName, i, j, ...
Sub Clear_Vars(ParamArray args() As Variant)
    If IsMissing(args) Then Exit Sub
    
    Dim i As Integer
    Dim t As VbVarType
    
    ' For Each だとオブジェクトを初期化できないので、For ループにする
    For i = LBound(args) To UBound(args)
        t = VarType(args(i))
        If t And vbArray Then
            err.Raise 5 ' プロシージャの呼び出し、または引数が不正です。
        Else
            Select Case t
                Case vbObject
                    Set args(i) = Nothing
                Case vbString
                    args(i) = vbNullString
                Case vbBoolean, vbDate, vbByte, vbInteger, vbLong, _
                        vbDouble, vbDouble, vbCurrency, vbDecimal
                    args(i) = 0
                Case vbVariant
                    args(i) = vbEmpty
                Case Else
                    'Err.Raise 5 ' プロシージャの呼び出し、または引数が不正です。
                    On Error Resume Next
            End Select
        End If
    Next
End Sub

PathSeparation_Cls

Option Explicit
Option Base 1  '配列最初の要素番号を１に設定する

'【パス構成要素抽出メソッド】

'「このインスタンスメソッドの使い方」
'宣言方法 → Set PathSeparation = New PathSeparation_Cls
'            hoge = PathSeparation.elemPath(フルパス)
'            hoge(m, n)→引数m,nの値によってファイル名およびパスの取得ができる。
'
'「C:\Folder\Book.xlsx」を例にした概要
'・m → 必ず1か２を指定する。返り値は以下のように設定してある。
'           [1.n] → n番目要素名
'           [2.n] → n番目要素名のパス
'・n  → 必ず1以上の値を指定する。フルパス一番右の要素を１番目とし、ドライブ手前までをn番目として要素を指定する。
'           1番目 Book.xlsx =　[1.1]
'           2番目 Folder    =  [1.2]

Dim n As Long, elemMax As Long
Dim childe As String, pathToChilde As String
Dim parent As String, pathToParent As String

Function elemPath(getPath As String) As Variant
    
    Dim result() As Variant
    Const argMax As Long = 2 '配列 m の最大要素番号を2に指定
        
    elemMax = Len(getPath) - Len(Replace(getPath, "\", ""))
    ReDim result(argMax, elemMax)
    
    For n = 1 To elemMax
        Call elemAllocation(getPath)
         result(1, n) = childe          '要素名取得
         result(2, n) = pathToChilde    'パス取得
    Next n
    
    elemPath = result

End Function

Private Sub elemAllocation(getPath)
    
    If n = 1 Then
        pathToChilde = getPath
        childe = Dir(getPath)
    Else
        pathToChilde = pathToParent
        childe = Dir(pathToParent, vbDirectory)
    End If
    
    If childe = "" Then
        pathToParent = pathToChilde & "\"
    Else
        pathToParent = Replace(pathToChilde, "\" & childe, "")
    End If
    
    If n = elemMax Then  'nが最大要素の時ドライブ名を取得する
        parent = Left(CurDir, 1)
    Else
        parent = Dir(pathToParent, vbDirectory)
    End If
      
End Sub

Sheet1

Option Explicit

Sub zenClr()

    Call roClr
    Call tsuClr
    
End Sub

Sub roClr()

    Call ClearCells(roData)
    
End Sub

Sub tsuClr()

    Call ClearCells(tsuData)
    
End Sub

Sub ClearCells(DATA As String)

    Range(DATA).ClearContents

End Sub

Sub RunToBat()

    Dim StartBat As Object
    Set StartBat = New StartBat_Cls
    Call StartBat.StartBatIni

End Sub

StartBat_Cls

Option Explicit
Option Base 1  '配列最初の要素番号を１に設定する

Dim FSO As Object, PathSeparation As Object, initialize As Object, WSH As Object
Dim batCd As String, parCd As String
Dim myElems() As Variant

Sub StartBatIni()
       
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set PathSeparation = New PathSeparation_Cls
    myElems = PathSeparation.elemPath(ThisWorkbook.FullName)
    batCd = myElems(2, 2)                         'batがあるフォルダまでのパスを取得
    parCd = myElems(2, 3) & "\" & camParaFolder   'parがあるフォルダまでのパスを取得
    ChDir batCd                                    'VBAの標準の作業フォルダは「ドキュメント」フォルダになるため、
                                                  '目的のファイル(今回の場合bat)を操作するためには
                                                  'ChDirでカレントを変更する必要がある
                                            
    
    If Not (FSO.FileExists(batCd & "\" & roCsv) And FSO.FileExists(batCd & "\" & tsuCsv)) Then    'csv確認
        MsgBox roCsv & "または" & tsuCsv & "が存在しません。" & coution, vbExclamation
    ElseIf Not FSO.FileExists(batCd & "\" & batName) Then                                         'bat確認
        MsgBox batCd & "\" & batName & "が存在しません。" & coution, vbExclamation
    ElseIf Not FSO.FileExists(parCd & "\" & Range("L16") & ".par") Then                           'par確認
        MsgBox parCd & "\" & Range("L16") & ".par" & "が存在しません。" & coution, vbExclamation
    Else
        Debug.Print batCd & "\" & roCsv
        Debug.Print batCd & "\" & batName
        Debug.Print parCd & "\" & Range("L16") & ".par"
        Call CreateBAT
        Call CreateCSV
        Call CreateCamView
    End If
    
    Set initialize = New Initialize_Cls
    Call initialize.Clear_Vars(batCd, parCd, FSO, PathSeparation, WSH)
    
End Sub

Private Sub CreateBAT()
        
    Dim i As Long, row As Long
    
    With Sheets(4)
        .Cells(10, "J") = FSO.GetFolder(batCd).Name
        For i = 2 To 3
            row = 1
            Open batCd & "\" & batName For Output As #1
            Do Until .Cells(row, 1).Value = "#"   'Sheet4 A列のセルの値が「#」のところで終了
                Print #1, .Cells(row, 1)
                row = row + 1
            Loop
            Close #1
        Next i
    End With
    
End Sub

Private Sub CreateCSV()
    
    Dim myArr As Variant
    Dim i As Long, row As Long
    
    myArr = Array(, roCsv, tsuCsv)
        
    For i = 2 To 3
        row = 1
        With Sheets(i)
            Open batCd & "\" & myArr(i) For Output As #2
            Do Until .Cells(row, 1).Value = ""     'Sheet2/3 A列のセルの値が空白のところで終了
                Print #2, .Cells(row, 1)
                row = row + 1
            Loop
            Close #2
        End With
    Next i
    
End Sub

Private Sub CreateCamView()
    
    Set WSH = CreateObject("WScript.Shell")
        
'  「rundll32.exe」を使ってDLLの中にある関数を呼び出す
'   rundll32.exe [DLLファイル名], [関数名] [引数]
    With WSH
        .Run """" & batCd & "\" & batName & """", 1, True 'パスに空白が含まれていても大丈夫なよう""""で区切る
        .Exec "rundll32.exe ""C:\Program Files\Windows Photo Viewer\PhotoViewer.dll"" , ImageView_Fullscreen " & batCd & "\" & roBmp
        .Exec "rundll32.exe ""C:\Program Files\Windows Photo Viewer\PhotoViewer.dll"" , ImageView_Fullscreen " & batCd & "\" & tsuBmp
    End With
        
End Sub