pgbigorokuのブログ

プログラムの再利用できそうなコードをアップ

EXCEL 実行ファイルを指定フォルダで起動するクラス、起動ソフトの終了タイミング取得可能＜clsShell＞

EXCEL VBA

実行ファイルを指定フォルダで起動するクラス。

クラスの取り込み方は、
pgbigoroku.hatenablog.com
を参照してください。

サンプル。ファイル名を指定して、ファイルへ書き込み、読み込みを行う。

Sub sample()
    Dim cShell As New clsShell
    Debug.Print cShell.ShellX("C:\Program Files\7-Zip\7zFM.exe", "2022_08_17_14_21_39_1.zip", "C:\")
End Sub

下記のクラスもワークブックに入れて下さい。
●pgbigoroku.hatenablog.com


ソースコード

'オブジェクト名は「clsShell」にしてください。
'
'   クラス機能　　　:  実行ファイルを指定フォルダで起動するクラス
'
'
'プロパティ
'   -
'関数
'　　ShellX　　　　　　ファイル実行
'
'URL https://pgbigoroku.hatenablog.com/entry/2022/08/17/222859
'2022/8/17

Option Explicit

Dim mbln実行中 As Boolean

'
'   機能　　　:  実行ファイルを指定フォルダで起動する
'
'    返り値　　:     TRUE   現在の所固定
'
'    引き数　　:    ByVal 実行するファイル As String　　　　　　　　　　実行するファイル名（前後に"で囲むため"は不要）
'                   Optional ByVal 実行するオプション As String = ""　　実行するファイル名の後に付けるオプション
'                   Optional ByVal 実行するフォルダ As String = "" = "" 実行するフォルダ（指定なしの場合はWorkbook.path）
'                   Optional ByVal 終了後に表示するメッセージ As String 実行後に表示するメッセージ（LEN(0)は表示しない
'
'    機能説明　:　　実行中の場合はプロパティ「実行中」にTRUEを返す
'
'
'    備考　　　:     -
'
'    この関数のURL　　：https://pgbigoroku.hatenablog.com/entry/2022/08/17/222859
'
'    この関数を利用するために必要なクラス：https://pgbigoroku.hatenablog.com/entry/2022/08/17/142503
'
'    バージョン　　：2022/8/16
Public Function ShellX(ByVal 実行するファイル As String, _
                        Optional ByVal 実行するオプション As String = "", _
                        Optional ByVal 実行するフォルダ As String = "", _
                        Optional ByVal 終了後に表示するメッセージ As String = "", _
                        Optional ByVal 終了後の待機時間 As Integer = 1000) As Boolean
    Dim str修了確認ファイル As String
    Dim strBat As String
    Dim cTxtFile As New clsTxtFile
    Dim lngShell As Long
    If 実行するフォルダ = "" Then
        実行するフォルダ = ActiveWorkbook.Path
    End If
    Call cTxtFile.指定フォルダにユニークなファイルを作成する(実行するフォルダ, ".bat")
    str修了確認ファイル = nstr利用していないファイル名を取得(実行するフォルダ, "txt")
    strBat = "cd " & """" & 実行するフォルダ & """"
'    strBat = strBat & vbCrLf & "start  ""shell"" " & """" & 実行するファイル & """" & " " & 実行するオプション '終了タイミングを計りたいので、 shartの代わりにcallを使う
    strBat = strBat & vbCrLf & "call  " & """" & 実行するファイル & """" & " " & 実行するオプション
    strBat = strBat & vbCrLf & "ECHO A > " & """" & str修了確認ファイル & """"
    cTxtFile.情報 = strBat
    mbln実行中 = True
    lngShell = Shell(cTxtFile.ファイル名フルパス, vbMinimizedNoFocus)
    Do While Dir(str修了確認ファイル) = ""
        DoEvents
    Loop
    Application.Wait [Now()] + 500 / 86400000
    Kill cTxtFile.ファイル名フルパス
    Kill str修了確認ファイル
    If 終了後に表示するメッセージ = "" Then
    Else
        Call MsgBox(終了後に表示するメッセージ)
    End If
    
    ShellX = True
End Function

Property Get 実行中() As Boolean
    実行中 = mbln実行中
End Property


'
'   機能　　　:  利用していないファイル名を取得
'
'    返り値　　:     存在していないファイル名（フルパス）
'
'    引き数　　:    ByVal pstrこのフォルダ名配下に作る As String 使用していないファイルを作るフォルダ
'                   ByRef pstr拡張子 As String　　　　　　　　　　新しく作るファイルの拡張子（.があっても無くてもOK）
'    機能説明　:     ワイルドカードは使えません
'
'
'    備考　　　:     -
'
'    この関数のURL　　：https://pgbigoroku.hatenablog.com/entry/2022/08/17/094450
'
'    この関数を利用するために必要な関数：https://pgbigoroku.hatenablog.com/entry/2022/08/17/005434
'
'    バージョン　　：2022/8/16
'
Private Function nstr利用していないファイル名を取得(ByVal pstrこのフォルダ名配下に作る As String, _
                                                    ByRef pstr拡張子 As String) As String
    Dim intFor As Integer
    Dim strDate As String
    Dim strtempFilename As String
    Dim str拡張子 As String
    If Left(pstr拡張子, 1) = "." Then
        pstr拡張子 = pstr拡張子
    Else
        pstr拡張子 = "." & pstr拡張子
    End If
    strDate = Format(Now, "yyyy_mm_dd_hh_mm_ss_")
    For intFor = 1 To 9999
        strtempFilename = nstrフルパスにする(pstrこのフォルダ名配下に作る, strDate & CStr(intFor) & pstr拡張子)
        If nblnファイル存在確認(strtempFilename) = True Then
        Else
            nstr利用していないファイル名を取得 = strtempFilename
            Exit Function
        End If
    Next
    nstr利用していないファイル名を取得 = ""
End Function




'
'   機能　　　:  ファイルの存在確認
'
'    返り値　　:     TRUE:ファイルがあるとき
'                   　FALSE:ファイルがないとき
'    引き数　　:    ByVal pstrファイル名 As String　確認するファイル名（フルパス推奨）
'
'    機能説明　:     ワイルドカードは使えません
'
'
'    備考　　　:     -
'
'    この関数のURL　　：https://pgbigoroku.hatenablog.com/entry/2022/08/17/005434
'
'    この関数を利用するために必要な関数：
'
'    バージョン　　：2022/8/15
'
Private Function nblnファイル存在確認(ByVal pstrファイル名 As String) As Boolean
    Dim FSO As Object ' Scripting.FileSystemObject
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FileExists(pstrファイル名) = True Then
        nblnファイル存在確認 = True
    Else
        nblnファイル存在確認 = False
    End If
    Set FSO = Nothing
End Function

'フォルダの存在確認
'
'バージョン　2022/8/17
'URL    https://pgbigoroku.hatenablog.com/entry/2022/08/17/005046

Private Function nblnフォルダの存在確認(ByVal pstr検索フォルダ名 As String) As Boolean
    Dim objFso
    Set objFso = CreateObject("Scripting.FileSystemObject")
    nblnフォルダの存在確認 = objFso.FolderExists(pstr検索フォルダ名)
 End Function

'   機能　　　:  フォルダ名とファイル名からフルパスにする
'
'    返り値　　:     -
'
'    引き数　　:    ByVal pstrフォルダ名 As String
'                   ByVal pstrファイル名 As String
'    機能説明　:　  フォルダ名の最後に\をついているか判定し　　-
'　　　　　　　　　フルパスにする。
'
'    備考　　　:     -
'
'    この関数のURL　　：　https://pgbigoroku.hatenablog.com/entry/2022/08/17/093728
'
'    この関数を利用するために必要な関数：
'
'    バージョン　　：2022/8/17
'
Private Function nstrフルパスにする(ByVal pstrフォルダ名 As String, ByVal pstrファイル名 As String) As String
    If Right(pstrフォルダ名, 1) = "\" Then
        nstrフルパスにする = pstrフォルダ名 & pstrファイル名
    Else
        nstrフルパスにする = pstrフォルダ名 & "\" & pstrファイル名
    End If
End Function