Access VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

1982 / 9994

←次へ　｜　前へ→


	【11292】Re:ｺﾏﾝﾄﾞﾎﾞﾀﾝを押下すると、指定ﾌｧﾙﾀﾞ下にあるtxtをインポートしたい。

小僧 - 09/12/11(金) 15:23 -


	引用なし

	パスワード

▼cocoa さん：
こんにちは。
まずは解決されまして何よりです。

> -------------------------------------------------------------------------
> ホスト 'ServerName' の 'application' ログのイベントを一覧表示しています。
> -------------------------------------------------------------------------

この情報が早く欲しかったです（笑）

初めてApplicationログをCSVに落とすプログラムを組んでみましたが
Description内に改行コードがあると
CSVの体裁が崩れてしまったり、
また先頭行と最終行に半角のスペースがあったりと
何か変な仕様なのですね。

cocoa さんの環境ですと Description が

> 内容が、0____userName(_は半角スペース)です。

という事なので、
バッチファイルで何か特殊なアプリケーションのみ
ログを抽出しているという事なのでしょうかね。

Public Function AppLogInsert(Optional ServerName As String _
　　　　　　　　　　　　　 , Optional UserName As String _
　　　　　　　　　　　　　 , Optional PassWord As String _
　　　　　　　　　　　　　 , Optional TargetDate As Date) As Boolean
　　　　　　　　　
Const strFilePath = "C:\applog.log"

Dim strCommand As String
Dim Con As New ADODB.Connection
Dim Rec As New ADODB.Recordset
Dim txtData As String
Dim FNo As Long
Dim Cnt As Long
Dim CommitFLG As Boolean

　　On Error Resume Next
　　　　Kill strFilePath
　　On Error GoTo 0
　
　　strCommand = ""
　
　　If ServerName = "" Then
　　　　strCommand = strCommand & " -S localhost "
　　Else
　　　　strCommand = strCommand & " -S " & ServerName & " "
　　End If
　
　　If UserName <> "" Then
　　　　strCommand = strCommand & " -U " & UserName & " "
　　End If

　　If PassWord <> "" Then
　　　　strCommand = strCommand & " -P " & PassWord & " "
　　End If
　
　　If TargetDate = 0 Then
　　　　TargetDate = Date
　　End If
　
　　strCommand = strCommand & " /fi ""DateTime eq " _
　　　　　　　 & Format(TargetDate - 1, "mm/dd/yyyy") & ",12:00:00PM-" _
　　　　　　　 & Format(TargetDate, "mm/dd/yyyy") & ",11:59:59PM"""
　　
　　strCommand = " cscript //nologo " _
　　　　　　　 & "%systemroot%\system32\eventquery.vbs " _
　　　　　　　 & " -v /l application -fo list" _
　　　　　　　 & strCommand & " > " & strFilePath

　　CreateObject("WScript.Shell").Run "%ComSpec% /c " & strCommand, 0, True

　　Set Con = CurrentProject.Connection
　
　　If DCount("*", "MsysObjects", "Name ='T_ApplicationLog'") = 0 Then
　　　　Con.Execute CreateTableApplog
　　Else
　　　　Con.Execute "DELETE FROM T_ApplicationLog"
　　End If
　　
　　Rec.Open "T_ApplicationLog", Con, adOpenDynamic, adLockOptimistic
　
　　FNo = FreeFile
　
　　On Error GoTo ErrHndl:

　　Open strFilePath For Input As #FNo
　　Line Input #FNo, txtData
　　Cnt = 1
　　Con.BeginTrans
　　Do Until EOF(FNo)
　　　　Line Input #FNo, txtData
　　　　Select Case txtData
　　　　　　Case "情報: 指定の条件に当てはまる 'application' ログのレコードはありません。"
　　　　　　　　Err.Raise 999, , "情報: 指定の条件に当てはまる 'application' ログのレコードはありません。"
　　　　　　Case ""
　　　　　　Case " "
　　　　　　　　Rec.Update
　　　　　　Case Else
　　　　　　　　Select Case Left(txtData, 4)
　　　　　　　　　　Case "Type"
　　　　　　　　　　　　If CommitFLG = True Then
　　　　　　　　　　　　　　Rec.Update
　　　　　　　　　　　　　　Cnt = Cnt + 1
　　　　　　　　　　　　　　CommitFLG = False
　　　　　　　　　　　　End If
　　　　　　　　　　　　Rec.AddNew
　　　　　　　　　　　　Rec![Messege_ID] = Cnt
　　　　　　　　　　　　Rec![Messege_Type] = Mid(txtData, 14)
　　　　　　　　　　Case "Even"
　　　　　　　　　　　　Rec![Messege_Event] = Mid(txtData, 14)
　　　　　　　　　　Case "Date"
　　　　　　　　　　　　Rec![Messege_DateTime] = Mid(txtData, 14)
　　　　　　　　　　Case "Sour"
　　　　　　　　　　　　Rec![Messege_Source] = Mid(txtData, 14)
　　　　　　　　　　Case "ComputerName　"
　　　　　　　　　　　　Rec![Messege_ComputerName] = Mid(txtData, 14)
　　　　　　　　　　Case "Cate"
　　　　　　　　　　　　Rec![Messege_Category] = Mid(txtData, 14)
　　　　　　　　　　Case "User"
　　　　　　　　　　　　Rec![Messege_User] = Mid(txtData, 14)
　　　　　　　　　　Case "Desc"
　　　　　　　　　　　　Rec![Messege_Description] = Mid(txtData, 14)
　　　　　　　　　　　　CommitFLG = True
　　　　　　　　　　Case Else
　　　　　　　　　　　　If CommitFLG = True Then
　　　　　　　　　　　　　　Rec![Messege_Description] = Rec![Messege_Description] & vbCrLf & Mid(txtData, 14)
　　　　　　　　　　　　End If
　　　　　　End Select
　　　　End Select
　　Loop
　
　　Close #FNo
　　Rec.Close
　　Set Rec = Nothing
　
　　Con.CommitTrans
　　Set Con = Nothing
　
　　MsgBox "正常終了"
　　Exit Function

ErrHndl:
　
　　Close #FNo
　　Con.RollbackTrans
　　Set Con = Nothing
　
　　MsgBox Cnt & "行目で以下のエラーが発生したためロールバックしました。" & vbCrLf & _
　　　　　　Err.Description, vbCritical

End Function

Function CreateTableApplog() As String
Dim strSQL As String

　　strSQL = ""
　　strSQL = strSQL & " CREATE TABLE T_ApplicationLog("
　　strSQL = strSQL & "　Messege_ID Long "
　　strSQL = strSQL & " ,messege_Type Text(10) "
　　strSQL = strSQL & " ,messege_Event Long "
　　strSQL = strSQL & " ,Messege_DateTime Date "
　　strSQL = strSQL & " ,messege_Source Text(50) "
　　strSQL = strSQL & " ,Messege_ComputerName Text(50) "
　　strSQL = strSQL & " ,Messege_Category Text(50) "
　　strSQL = strSQL & " ,Messege_USER Text(50)"
　　strSQL = strSQL & " ,Messege_Description Memo "
　　strSQL = strSQL & " ,CONSTRAINT PK PRIMARY KEY (Messege_ID))"
　
　　CreateTableApplog = strSQL
End Function

> インポートするたびにバッチ処理を動かしていると、
> ｻｰﾊﾞｰに負荷がかかりすぎる為、

という事を考慮して日付を指定して１日分のみ
アプリケーションログを取ってくるようなコードです。

全てのアプリケーションログを取ってくる仕様ですし、
DateTime や Description は分割しておりませんが
何かしらの参考になれば幸いです。

　 Call AppLogInsert("192.168.0.100", "Domain\User", "PWD", #12/11/2009#)

の様に呼び出してみて下さい。

1,471 hits

▼

【11255】ｺﾏﾝﾄﾞﾎﾞﾀﾝを押下すると、指定ﾌｧﾙﾀﾞ下にあるtxtをインポートしたい。 cocoa 09/12/4(金) 16:13