2018年12月19日

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

タグ:Excel VBA
posted by Hiro at 23:03| Comment(0) | プログラム

2018年12月11日

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
タグ:VBScript
posted by Hiro at 23:13| Comment(2) | プログラム