Excel 配列を渡してCSV出力するクラス

配列を渡してCSV出力するクラスモジュールです。

'=================================================================
' CSVファイル作成クラス
' CreateCSVクラスモジュール
'=================================================================
Option Explicit

'出力先フォルダ
Private path As String
'出力ファイル名
Private fname As String

'ファイルシステムオブジェクト（参照設定：Microsoft Scripting Runtime）
Private fso As FileSystemObject
'テキストストリーム
Private ts As TextStream

'固定値　ダブルクォート
Const WQ As String = """"
'固定値　カンマ
Const COMMA As String = ","
'固定値　除外文字列
Const IGNORE As String = "<NULL>"

'==================================================
' ◆ 書き込み準備
'
' 引数
' (1)name         出力ファイル名
' (2)dat          出力対象日付
'==================================================
Public Sub ready(ByVal name As String, ByVal dat As Date)
    '例外捕捉開始
    On Error GoTo ERROR_ROUTINE
    
    'ファイル名
    If name = "" Then
        name = "OUTPUTFILE_"
    End If
    
    'デスクトップのパス取得
    Dim WSH As Object
    Set WSH = CreateObject("WScript.Shell")
    path = WSH.SpecialFolders("Desktop") & "\"
      
    'ファイル名決定
    fname = name & "_" & Format(dat, "yyyymmdd") & "_" & Format(Now, "yyyymmddhhnnss") & "000.csv"
        
    'ファイルオープン
    Set fso = New FileSystemObject
    Set ts = fso.OpenTextFile(path & fname, ForWriting, True)
    
    'サブルーチン終了
    Exit Sub

    '例外処理
ERROR_ROUTINE:
    Call MsgBox(Err.Number & ":" & Err.Description, vbCritical + vbOKOnly, "エラー")
    End
End Sub

'==================================================
' ◆ 書き込み実施
'
' 引数
' (1)args         1行分の文字列配列
'==================================================
Public Sub writeDate(ByRef args As Variant)

    'ファイルが準備されてない
    If ts Is Nothing Then
        Call MsgBox("ファイルが準備されていません。", vbOKOnly + vbExclamation, "警告")
        End
    End If
    
    '例外捕捉開始
    On Error GoTo ERROR_ROUTINE
    
    Dim line As String
    Dim index As Integer
    
    '配列の要素を1個ずつ取得
    Dim curCell As String
    For index = LBound(args) To UBound(args)
        curCell = args(index)
        '除外文字列置換
        curCell = Replace(curCell, IGNORE, "")
        'ダブルクォート置換
        curCell = Replace(curCell, WQ, WQ & WQ)
        'セルの結合
        line = line & IIf(Len(line) = 0, "", COMMA) & WQ & curCell & WQ
    Next
    '改行付加
    line = line & vbNewLine
    
    '書き込みの実施
    ts.Write line
    
    'サブルーチン終了
    Exit Sub

    '例外処理
ERROR_ROUTINE:
    Call MsgBox(Err.Number & ":" & Err.Description, vbCritical + vbOKOnly, "エラー")
    End
End Sub

'==================================================
' ◆ 書き込み終了
'==================================================
Public Sub finish()
    'ファイルクローズ
    On Error Resume Next
    ts.Close
    Set ts = Nothing
    On Error GoTo 0
End Sub

' プロパティプロシージャ
Property Get getFName() As String
    getFName = fname
End Property

呼び出し側（シートモジュールで使用）。

Option Explicit

Private Sub btnSAMPLE_Click()

    '確認メッセージ
    Dim res As Integer
    res = MsgBox("CSV出力を開始します。" & vbNewLine & "よろしいですか？", vbQuestion + vbYesNo + vbDefaultButton2, "確認")
    If res = vbNo Then Exit Sub

    'CSV書き込み準備
    Dim curFile As New CreateCSV
    Call curFile.ready("OUTPUT", #12/1/2018#)

    Dim element() As Integer
    Dim x As Integer
    Dim y As Integer

    For y = 1 To 10
        Erase element

        'データの作成
        For x = 1 To 10
            ReDim Preserve element(x - 1)
            element(x - 1) = x * y
        Next

        '書き込み実施
        curFile.writeDate (element)
    Next

    '終了メッセージ
    Call MsgBox("終了しました。" & vbNewLine & curFile.getFName, vbOKOnly + vbInformation, "情報")

    'CSV書き込み終了処理
    curFile.finish
    Set curFile = Nothing

End Sub

VBScript コマンドの実行と標準出力の取得

VBScript内でコマンドを実行し、標準出力の文字列から成功の可否を判定します。

（ERRORLEVELは参照しません。）

'===================================
' コマンドを実行し、標準出力から成功の可否を判定する
' vbs_execcmd.vbs
'===================================
'
'変数宣言の強制
Option Explicit

'関数戻り値定数
Const ISSUCCESS  = 0
Const ISERROR    = 1

'固定文字列
'コマンドが成功時に出力する文字列
Const BATCH_SUCCESS_MSG  = "        1 個のファイルをコピーしました。"

'◆メイン処理呼び出し
Call CheckDualExec()
Call Main()

'◇メイン処理
Sub Main()
    On Error Resume Next

    'コマンドの起動
    Call execCmd("sample1.txt", "sample2.txt")

    'メイン処理終了
    Exit Sub
End Sub

'◇コマンドの起動
Sub execCmd(ByVal arg1, ByVal arg2)
    '変数宣言
    Dim WshShell   'WshShellオブジェクト
    Dim objPgm    'WshScriptExecオブジェクト
    Dim strCmd    '実行コマンド
    
    Set WshShell = CreateObject("WScript.Shell")
    
    'コマンド生成
    strCmd = "cmd /c copy " & arg1 & " " & arg2
    
    WScript.Echo "起動コマンド：" & strCmd
    
    'コマンドを起動
    Set objPgm = WshShell.Exec(strCmd)
    If Err.Number <> 0 Then
        WScript.Echo "コマンド起動時にエラー発生"
        WScript.Quit
    End IF
    
    '取込終了まで待機
    Do while objPgm.Status <> 1
        WScript.Sleep 100
    Loop
    
    'コマンドの起動結果判定
    If AskResult(objPgm) <> ISSUCCESS Then
        WScript.Echo "コマンドが正常終了しませんでした。"
        WScript.Quit
    End IF
    
    Set objPgm = Nothing
End Sub

'◇二重起動抑制
Sub CheckDualExec
    Dim objSWbemLocator
    Dim objServices
    Dim objProcess
    Dim objProcesses
    Dim first
    Set objSWbemLocator = CreateObject("WbemScripting.SWbemLocator")
    Set objServices = objSWbemLocator.ConnectServer(".", "root\cimv2")
    Set objProcesses = objServices.ExecQuery("SELECT * FROM Win32_Process")
    first = False
    For Each objProcess In objProcesses
        If WScript.FullName = objProcess.ExecutablePath Then
            If Instr( objProcess.CommandLIne , WScript.ScriptFullName ) > 0 Then
                If Not first Then
                    first = True
                Else
                    'プロセス終了
                    WScript.Quit
                End If
            End If
        End If
    Next
End Sub

'◇コマンドの処理結果確認
Function AskResult(objArg)
    Dim strCurLine

    '標準出力を取得
    If Not objArg.StdOut.AtEndOfStream Then
        strCurLine = objArg.StdOut.ReadAll
        WScript.Echo strCurLine
    End If
    
    '文字列を判定
    If BATCH_SUCCESS_MSG = Left(strCurLine,Len(BATCH_SUCCESS_MSG)) Then
        '正常終了時
        AskResult = ISSUCCESS
    Else
        '異常終了時
        AskResult = ISERROR
    End If
End Function