差込データソースとの接続をVBAで行う(2)

差込印刷のデータソースとの接続をVBAで行う

Openイベントで接続する

差込印刷機能というのは非常に便利なので、Wordスキルがど素人のレベルでも使っている人は非常に多いと思う。私もそのクチ。ただ、データソースとの接続回りが非常に素人には分かりづらくて、面倒な思いをしている人も多いと思う。

たとえば、差込印刷を設定したWordドキュメントとデータソースのExcelファイルが同じフォルダに入っているとき、フォルダごと移動したり、フォルダ名を変えたりするだけでデータソースと接続できなくなってしまう。

データソースのフルパスが変わってしまうんだから、当たり前なんだけれど、仕組みのよく分かっていない初心者なんかは、いきなり

こんなダイアログ出されてもなんのことやら分からなくて困る。

また、事情が分かっていたとしても、たかがフォルダごと移動したぐらいでいちいちフォルダ階層をたどってデータソースファイルを指定し直すのはメンドクサイ。

そこで、

akashi-keirin.hatenablog.com

このときに作成したマクロをドキュメントのOpenイベント発生時に実行するようにしたら良いと考えた。

とりあえず、

こんなふうに、差込印刷テストフォルダ内に、メイン文書.docmと差込データ.xlsxを準備する。

差込データ.xlsxには、

このように、「競輪場」シートにデータ（ｗ）を準備しておく。

で、メイン文書.docmのThisDocumentモジュールに以下のコードを書く。

プロジェクトエクスプローラのThisDocumentをダブルクリックしたらコード・ウインドウが開くので、

ここでDocumentを選んで、

ここでOpenを選んだらPrivate Sub Document_Open()～End Subが自動で挿入される。

リスト１　ThisDocumentモジュール

Private Sub Document_Open()
  Call setMailMergeDataSource(ThisDocument, _
                              "差込データ.xlsx", _
                              "競輪場")
End Sub

setMailMergeDataSourceに引数を３つ渡して実行しているだけ。

setMailMergeDataSourceというのは、自作のプロシージャで、このときにご紹介したやつです。

短いコードなので再掲しておく。

リスト２　標準モジュール

'差込データソースに指定する'
Public Sub setMailMergeDataSource(ByVal objDoc As Document, _
                                  ByVal objFileName As String, _
                                  ByVal objSheetName As String)
'///objDoc：差込対象文書'
'///objFileName：データソースExcelファイルのファイル名（拡張子付き）'
'///objSheetName：データソースのあるシート名'
'///※差込対象文書とデータソースファイルが同じフォルダにあることが'
'///　前提。'
On Error GoTo errorHandler
  Dim dataSourceFullName As String
  dataSourceFullName = objDoc.Path & "\" & objFileName  '"
  With objDoc.MailMerge
    .OpenDataSource _
      Name:=dataSourceFullName, _
      SQLStatement:="SELECT * FROM `" & objSheetName & "$`"
  End With
  Exit Sub
errorHandler:
  Debug.Print Err.Number
  Debug.Print Err.Description
End Sub

これで、ドキュメントOpen時にsetMailMergeDataSourceが実行されるので、差込データ.xlsxがメイン文書.docmと同じフォルダ内にあって、シート名を変更でもしない限り、フォルダごとどこのディレクトリに持って行っても大丈夫、ということになる。

実行結果

フォルダごと別のディレクトリに移動してメイン文書.docmを開いてみる。

開いたときには既にデータソースにつながっている。快適。

ついでに

使用環境によっては、マクロ入りのファイルを開くときに毎回

が出る場合がある（ウチの職場では、マクロ入りファイルを開くときは毎回出てくる）。そんな場合、データソースをつなぎっぱなしにしていると、ファイルを開くたんびに

まずコイツがでてきて、[はい(Y)]をクリック。で、その後、

コイツが出てくるので「コンテンツの有効化」をクリック。

そうするとまた

コイツが出てくるので[はい(Y)]をクリック、とひと手間余分にかかってしまう。わづか一手といえど、毎回毎回となるとさすがにうっとうしい。

よって、ドキュメントをCloseするたびに接続を切ってしまおうと思った。

まずは、接続を切断するためのプロシージャを作る。

リスト３　標準モジュール

'差込データソースを切断する'
Public Sub disconnectMailMergeDataSource(ByVal objDoc As Document)
On Error GoTo errorHandler
  objDoc.MailMerge.DataSource.Close    '……(1)'
errorHandler:
  Set objDoc = Nothing
End Sub

引数としてDocumentを受け取って処理する。

(1)の

objDoc.MailMerge.DataSource.Close

Document.MailMerge.DataSourceオブジェクトのCloseメソッドを使っているだけ。

んで、ThisDocumentモジュールに以下のコードを書く。

今度は

ココでCloseを選ぶ。

リスト４　ThisDocumentモジュール

Private Sub Document_Close()
  Call disconnectMailMergeDataSource(ThisDocument)
End Sub

ほい。たったのコレだけ。

実にカンタンに差込印刷用セットを使えるようになる。

訂正と追記

上で、得意げにドキュメントをCloseするたびに接続を切ってしまおうと思ったでんでんうんぬん書いてますけど、

ハッキリ言って、無意味

だよね。なんぼドキュメントのClose時にデータソースとの接続を切っても、別に上書き保存するわけじゃないんだからさ。

てなわけで、コードを修正する。

リスト５　ThisDocumentモジュール

Private Sub Document_Open()
  If ThisDocument.MailMerge.DataSource.Name <> "" Then _
     Call disconnectMailMergeDataSource(ThisDocument)
  Call setMailMergeDataSource(ThisDocument, _
                              "差込データ.xlsx", _
                              "競輪場")
End Sub

Closeイベントに書いてもムダなので、データソースの切断と接続をOpenイベントにまとめたわけです。

まず、条件判定

If ThisDocument.MailMerge.DataSource.Name <> "" Then

ですが、差込データ未接続だったら、Document.MailMerge.DataSourceオブジェクトのNameプロパティが""なので、

ThisDocument.MailMerge.DataSource.Name <> ""

がTrueということは、何らかのデータソースが設定されているということになる。

で、そのときにDataSourceが存在しないファイルだったりすると、

こいつが出てきて大混乱してしまう。

だから、Document.MailMerge.DataSourceオブジェクトのNameプロパティに何らかの文字列が入っている場合には、

Call disconnectMailMergeDataSource(ThisDocument)

でデータソースを切断してしまう。

これで、晴れてこのDocumentはデータソース未接続状態になっているので、あとは

Call setMailMergeDataSource(ThisDocument, _
                              "差込データ.xlsx", _
                              "競輪場")

で同一フォルダ内にあるデータソースに接続しておしまい。

【追記ここまで】

さらに追記

実は、上記のOpenイベントで一旦切断する方法もダメですｗ

どうもOpenイベント発生前に差込データソースを探しに行っているっぽい。

akashi-keirin.hatenablog.com

コチラをどうぞ。

おわりに

もちろん、差込データのファイル名が変わったり、シート名を変更したりした場合にはコードを書き換えなければならず、それなりに面倒ではあるので、そこらへんが課題かな。

タブ位置をお手軽に設定するアドイン（Word用）

タブ位置を気軽に設定するアドイン

akashi-keirin.hatenablog.com

これをもとに、アドイン化してみた。

コード

ごちゃごちゃなしでコードを全部載せる。

リスト１　標準モジュール

Public Sub タブ位置設定()
  Dim objDoc As Document
  Set objDoc = ActiveDocument
  Dim tmpStr As String
  tmpStr = InputBox( _
             Prompt:="指定したいタブ位置(整数値)を｢,｣(半角カンマ)区切りで入力せよ。" _
                     & vbCrLf & _
                     "※小数値は、小数部分を丸めて整数値として扱います。", _
             Title:="タブ位置の指定")
'///ガード節その１'
'///何も入力されなかったら処理を抜ける（キャンセルの場合も同じ）。'
  If tmpStr = "" Then Exit Sub
'///ガード節その２'
'///半角カンマが全くないのに、入力された値が数値として評価できない値だったら処理を抜ける。'
  If InStr(tmpStr, ",") = 0 And _
     Not IsNumeric(tmpStr) Then
     Call makeUserSick("数字と半角カンマで入力せんかいぼけー！")
     Exit Sub
  End If
'///ガード節その３'
'///カンマ区切りで入力された値に、数値以外が入っていたら処理を抜ける。'
  Dim positionsArray As Variant
  positionsArray = Split(tmpStr, ",")
  Dim maxPositions As Integer
  maxPositions = UBound(positionsArray) + 1
  Dim i As Integer
  For i = 1 To maxPositions
    If Not IsNumeric(positionsArray(i - 1)) Then
      Call makeUserSick("数字以外入れんなぼけー！")
      Exit Sub
    End If
  Next
'///ここから処理の本体'
'///一旦選択位置のタブをクリア。'
  Selection.ParagraphFormat.TabStops.ClearAll
'///選択位置のフォントサイズを取得'
  Dim p As Single
  p = Selection.Font.Size
'///タブを設定'
  For i = 1 To maxPositions
    With Selection.ParagraphFormat.TabStops
      .Add CInt(positionsArray(i - 1)) * p
    End With
  Next
End Sub

説明はコード中にコメントとして入れたので、今回は説明は省略。

実行

こんなふうにタブを設定して実行する。

見づらいけど、インプットボックスに「5,10,15,20,25,30」と入力した。

このように、５文字区切りでタブ位置が設定された。

「段落」メニューから「タブ設定」を見ると、

バッチリ設定されている。

今度は、「5.5,10.5,15.5,20.5,25.5,30.5」と入力してみた。

(ﾟДﾟ)ﾊｧ?　四捨五入と五捨六入が交互に……。

「あ」とだけ入力すると、

煽られるｗ

今度は、「5,10,15,20,ち～んｗ,30」と入力してみる。

煽られるｗ

ちなみに、煽り用プログラムは、

akashi-keirin.hatenablog.com

このときのものです。

コード見たら分かると思いますが、何も入力せずに[ＯＫ]をクリックしたり、[キャンセル]をクリックしたりすると、何事もなかったかのように処理を終了します。

@akashi_keirin on Twitter

Officeのヴァージョンによって処理を切り替える

Officeのヴァージョンに合わせて煽る

私は、別に玄人でも何でもないので、自作のツールに煽りAAを入れる。

中でも気に入っているのが、有名な「ち～んｗ」のやつｗ

    ＿＿＿＿＿＿＿＿_
　／　　　　　　　　 ＼ 
／　／・＼　　／・＼　 ＼
|　　　￣￣　　　￣　　 |　ち～んｗ
|　　　　（＿人＿）　　 |
|　　　　　＼ 　 |      |
＼　　　　 　＼＿|　　 ／

ただ、こいつをメッセージボックスで表示しようとすると、Officeのヴァージョンによってフォントの種類が違うので、表示が崩れる。

この問題に真剣に取り組んだ。

対応

簡単なことで、ApplicationオブジェクトのVersionプロパティで判定すりゃいい。

コーディング

まずは、宣言セクションでAAの部分を定数にしておく。

リスト１　標準モジュールの宣言セクション

Public Const MAKE_USER_SICK_2013 As String = _
              "       ＿＿＿＿＿＿＿" & vbCrLf & _
              "   ／　　　　　　　＼" & vbCrLf & _
              "／　／・＼　　／・＼　＼" & vbCrLf & _
              "|　　￣￣　 　￣￣　　 |　　　ち～んｗ" & vbCrLf & _
              "|　　　　（＿人＿）　  |" & vbCrLf & _
              "|　　　　　＼　 |　　　|" & vbCrLf & _
              "＼　　　　　＼_|　　／"

Public Const MAKE_USER_SICK_2010 As String = _
              "    　＿＿＿＿＿＿＿" & vbCrLf & _
              "　／　　　　　　　        ＼ " & vbCrLf & _
              "／　／・＼　　／・＼  　  ＼" & vbCrLf & _
              "|　　￣￣　　　￣　　　      |　ち～んｗ" & vbCrLf & _
              "|　　　　（＿人＿）　　       |" & vbCrLf & _
              "|　　　　　＼ 　   |      　   |" & vbCrLf & _
              "＼　　　　 　＼＿|　      ／"

ちなみに、上が2013以降用で、下が2010用。2007とか2003でやったらどうなるのかは不明。だって、そんなヴァージョンのOfficeが身近にないんだもの。

んで、本体のコードが次のリスト２。

リスト２　標準モジュール

Public Sub makeUserSick(ByVal msg As String)    '……(1)'
  Dim ver As String
  ver = Application.Version    '……(2)'
  Dim str As String
  Select Case ver    '……(3)'
    Case "14.0"
      str = MAKE_USER_SICK_2010
    Case "15.0"
      str = MAKE_USER_SICK_2013
    Case "16.0"
      str = MAKE_USER_SICK_2013
    Case Else    '……(*)'
      str = MAKE_USER_SICK_2010
  End Select
  MsgBox msg & vbCrLf & str    '……(4)'
End Sub

簡単なコードなので説明不要と思うけれど、一応。

まず、(1)の

Public Sub makeUserSick(ByVal msg As String)

で、引数を１つ受け取るようにしている。

ここで受け取ったmsgプラス「ち～んｗ」AAで煽る、というわけ。

で、(2)の

ver = Application.Version

では、ApplicationオブジェクトのVersionプロパティを取得して変数verにぶち込んでいる。

例えば、Office2013なら、「15.0」が返ってくる。

従って、(3)からの10行

Select Case ver
  Case "14.0"
    str = MAKE_USER_SICK_2010
  Case "15.0"
    str = MAKE_USER_SICK_2013
  Case "16.0"
    str = MAKE_USER_SICK_2013
  Case Else    '……(*)'
    str = MAKE_USER_SICK_2010
End Select

では、変数verに格納された値に応じて呼び出す定数を変えている。

2016とか使ったことがないから、2013と同じ文字列を呼び出すようにしているけれど、ホントにこれで良いのかは不明ｗ

また、(*)のところでは、2010でも2013でも2016でもなければ2010と同じ文字列を呼び出すようにしているけれど、これまたホントにこれで良いのかは不明ｗ

あとは、(4)の

MsgBox msg & vbCrLf & str

で、引数で受け取った文字列と煽りAAをつなげ、メッセージボックスに表示する。

実行

次のコードで実行する。

リスト３　標準モジュール

Public Sub test()
  Call makeUserSick("ほげほげ")
End Sub

実行結果

Word2013上で実行したのでこうなる。

やっぱりむかつくｗ

私は、これらのコードをWdCommonと名付けた標準モジュールに書いて、いろんなWordドキュメントにインポートして使い回しているので、ユーザーがわけの分からん操作をしたときに煽る機能をカンタンに実装することができます。ははは。

@akashi_keirin on Twitter

差込データソースとの接続をVBAで行う

VBAで差込印刷のデータソースに接続する

差込印刷データソースの指定

以前、差込印刷のレコードごとにWordファイルを生成するということをやったことがあった。

akashi-keirin.hatenablog.com

これはこれで、メチャクチャ便利で、重宝しているんだが、フォルダを移動したり、ネットワークドライブでドライブレターが異なる人が使う場合に、いちいち
差込文書→宛先の選択
でExcelファイルを指定し直さないといけなかったり、ファイルを指定するときのデフォルトのフォルダが変なところになっていたりするので、非常にフラストレーションが溜まる。

で、「差込データソースとの接続をマクロでやっちゃえ！」と思って、やってみた。

同じフォルダ内にある指定したブックの指定したシートをデータソースに指定するマクロ

標準モジュールに次のようなコードを書いた。

リスト１　標準モジュール

Public Sub setMailMergeDataSource(ByVal objDoc As Document, _
                                  ByVal objFileName As String, _
                                  ByVal objSheetName As String)    '……(1)'
On Error GoTo errorHandler
  Dim dataSourceFullName As String
  dataSourceFullName = objDoc.Path & "\" & objFileName    '……(2)'"
  With objDoc.MailMerge    '……(3)'
    .OpenDataSource Name:=dataSourceFullName, _
                    SQLStatement:="SELECT * FROM `" & objSheetName & "$`"
  End With
  Exit Sub
errorHandler:
End Sub

引数を受け取って処理をする。(1)の

Public Sub setMailMergeDataSource(ByVal objDoc As Document, _
                                  ByVal objFileName As String, _
                                  ByVal objSheetName As String)

では、引数を３つ設定している。

第１引数のobjDocは、差込先のWordドキュメント。

第２引数のobjFileNameは、差込データソースに指定するExcelファイルのファイル名（拡張子付き）。

第３引数のobjSheetNameは、データソースのあるシート名。

とりあえずこの３つを受け取って処理をすることにしている。

(2)の

dataSourceFullName = objDoc.Path & "\" & objFileName

では、変数dataSourceFullNameに差込データソースのExcekファイルのフルパスをぶち込んでいる。

んで、(3)からの４行（実質３行）

With objDoc.MailMerge
  .OpenDataSource Name:=dataSourceFullName, _
                  SQLStatement:="SELECT * FROM `" & objSheetName & "$`"
End With

では、Document.MailMergeオブジェクトのOpenDataSourceメソッドを使って、差込データソースを接続している。

OpenDataSourceメソッドにはたくさん引数があるが、とりあえずNameとSQLStatementを指定しておけば大丈夫っぽい。

実行

実行元のWordドキュメントのあるフォルダ内に「test.xlsx」というExcelブックを用意しておき、その「競輪選手」シートに

こんなデータ（ｗ）を用意しておく。

で、次のコードで実行してみる。

リスト２　標準モジュール

Public Sub connectingDataSourceTest()
  Dim orgDoc As Document    '……(1)'
  Set orgDoc = ActiveDocument
  Dim rootPath As String    '……(2)'
  rootPath = orgDoc.Path & "\"    '"
  Dim newDoc As Document    '……(3)'
  Set newDoc = Documents.Add
  newDoc.SaveAs2 rootPath & "ち～んｗ.docx"    '……(4)'
  Call setMailMergeDataSource(newDoc, "test.xlsx", "競輪選手")    '……(5)'
End Sub

まず、(1)からの２行

Dim orgDoc As Document
Set orgDoc = ActiveDocument

で変数orgDocに実行元ドキュメントをぶち込んでおく。

(2)からの２行

Dim rootPath As String
rootPath = orgDoc.Path & "\"

で、変数rootPathに実行元ドキュメントのあるフォルダのパスをぶち込んでおく。

(3)からの２行

Dim newDoc As Document
Set newDoc = Documents.Add

で、DocumentsコレクションのAddメソッドを用いて新しいドキュメントを生成し、即座に変数newDocにぶち込む。

さらに(4)の

newDoc.SaveAs2 rootPath & "ち～んｗ.docx"

で、実行元ドキュメントと同じフォルダに「ち～んｗ.docx」という名で保存する。

あとは、(5)の

Call setMailMergeDataSource(newDoc, "test.xlsx", "競輪選手")

でリスト１のsetMailMergeDataSourceメソッドを呼び出したらおしまい。

「ち～んｗ.docx」の差込文書に、同じフォルダ内の「test.xlsx」を設定する。

実行結果

まず、

このように「ち～んｗ.docx」が生成される。

で、「差込フィールドの挿入」をクリックしてみると、

ちゃんと設定されている。

こんなふうに差込フィールドを挿入して、「結果のプレビュー」をクリックしてみると……

ほれ、ちゃんとデータが差し込まれる。

おわりに

なんでこんな簡単なことを今までやってなかったんだろ？？？

こちらもどうぞ

akashi-keirin.hatenablog.com

VBAでテキストボックスのレイアウト設定を操作する

ことごとく「背面」になっているテキストボックスェ……

業務で引き継いだWordドキュメントがカオス……

業務でWordドキュメントを引き継いだ。

で、そのWordドキュメントってのがひどいやつで、

40個ぐらい配置されているテキストボックスのレイアウトがことごとく「背面」

なのだった……。

しかも、そのテキストボックスの中身を書き換えたり、位置を動かしたりしないといけないんだが、

「背面」になっているテキストボックスって、そもそもマウスで選択することすら難しい。

画面右上の「選択」から「オブジェクトの選択」ってのを選ばないと、なかなか選択できなくていらいらする。

こんなのが何十個もあるとか、軽い拷問ですよね。

テキストボックスの「折り返しの種類」をVBAで操作する

「テキストボックスの書式設定」の「レイアウト」タブにある「行内」とか「前面」とかは「折り返しの種類」っていうのね。知らんかった。まあ、Word初心者だしな。

この「折り返しの種類」は、 WrapFormatプロパティというらしい。

オブジェクトの階層をたどると、

Documentオブジェクト→Shapesコレクション→Shapeオブジェクト→WrapFormatオブジェクト→Typeプロパティ

となるのかな。

要するに、コーディング的には、テキストボックスオブジェクトを取得して、そのWrapFormat.Typeプロパティが「前面」になっていなかったら「前面」に変える、というだけで良い。

コーディング

標準モジュールに次のコードを書く。

リスト１　標準モジュール

Public Sub frontizeTextBox()
  Dim objDoc As Document
  Set objDoc = ActiveDocument
  Dim shp As Word.Shape
  For Each shp In objDoc.Shapes    '……(1)'
    With shp.WrapFormat    '……(2)'
      If shp.Type = msoTextBox Then    '……(3)'
        If .Type <> wdWrapFront Then .Type = wdWrapFront    '……(4)'
      End If
    End With
  Next
End Sub

プロシージャ名の「frontize」ってのはたぶん存在しない英単語だろうねえ。メンドクサイからテキトーに書いたｗ

それはさておき、まずは、(1)の

For Each shp In objDoc.Shapes

「shp」ってのはShape型のオブジェクト変数で、オートシェイプ（今はそんな呼び方しないんだっけ？）をぶち込むための変数。Shapesコレクションの要素をぶち込んでFor Eachで回していくわけだ。

(2)の

With shp.WrapFormat

では、WrapFormatオブジェクトへの参照や操作が多いのでWithでまとめている。

(3)の

If shp.Type = msoTextBox Then

でshpの中身を調べ、テキストボックスである場合だけ次の処理に進む。

で、shpがテキストボックスだった場合は、(4)の

If .Type <> wdWrapFront Then .Type = wdWrapFront

に進む。

WrapFormatオブジェクトのTypeプロパティがwdWrapFrontでなかったら、wdWrapFrontにする。

ちなみに、wdWrapFrontの正体は

この通り、「3」です。

実行結果

実行前

「折り返しの種類」は「背面」。

実行後

「折り返しの種類」が「前面」になった。

おわりに

たまに、図形の類をベタベタ貼り付けたドキュメントに出くわす。で、それらの設定がことごとくデタラメ、という場面もちょいちょいあるような気がする。そんなとき、VBAで図形を操作する方法を知っていれば便利かも。

まあ、それ以前にもう少しマトモなOfficeの使い方してくれよ……とは思いますが。

ついでに……

オブジェクトブラウザーを使うと、組み込み定数（っていうか、列挙体のメンバ）を調べることができて便利。

コチラは、WdWrapType列挙体のメンバ。名前を見たらだいたい何を意味するのか見当がつくと思います。

直近○回分のイベント発生日時を配列化するFunctionの修正

直近のイベント発生日時を配列化するFunctionの修正

このとき

akashi-keirin.hatenablog.com

作成したFunctionについて、対応できるイベントを増やそうとして、いろいろ不具合に気づいたので修正する。

コードへのリンクはコチラ。

１．無意味な判定をやめる

イベントのデータが取得できているかどうかを、

If Not colLoggedEvents.itemIndex(i) Is Nothing Then

で判定しようとしていたが、そもそも該当するイベントがなかったときは、

colLoggedEvents.itemIndex(i)

ここを評価した時点でエラーが出る。

要するに、この判定はまるで無意味だったということになる。

２．イベントのデータが指定した数よりも少なかった場合の対応

たとえば、直近10回分のデータを取得しようとしたのに、データが２個しかなかった、という場合に、

colLoggedEvents.ItemIndex(i)

のところで、

「インデックスが有効範囲にありません。」てやつ。コレクションの要素数を超えているんだから当然だ。

コードの修正

上記１．、２．を踏まえて修正する。

修正前

まず、

  Dim i As Integer
  Dim tmpDateValues() As Date
  ReDim tmpDateValues(0 To eventIndex - 1)
  For i = 0 To eventIndex - 1
    If Not colLoggedEvents.itemIndex(i) Is Nothing Then
      Set objEvent = colLoggedEvents.itemIndex(i)
      retTimeWritten = convUTCtoJST(parseTimeWritten(objEvent.TimeWritten))
      tmpDateValues(i) = retTimeWritten
    End If
    DoEvents
  Next
  getAnyEventDateTime = tmpDateValues
errorHandler:
  Set objWMIService = Nothing
  Set colLoggedEvents = Nothing
  Set objEvent = Nothing
End Function

ここの部分のみ取り上げる。

修正後

  Dim i As Integer
  Dim tmpDateValues() As Date
  Dim n As Integer    '……(1)'
  n = colLoggedEvents.Count
  If n = 0 Then    '……(2)'
    ReDim tmpDateValues(n)
    getAnyEventDateTime = tmpDateValues
    Exit Function
  End If
  If n < eventIndex Then eventIndex = n    '……(3)'
  ReDim tmpDateValues(0 To eventIndex - 1)
  For i = 0 To eventIndex - 1    '……(4)'
    Set objEvent = colLoggedEvents.ItemIndex(i)
    retTimeWritten = convUTCtoJST(parseTimeWritten(objEvent.timeWritten))
    tmpDateValues(i) = retTimeWritten
    DoEvents
  Next
errorHandler:    '……(5)'
  getAnyEventDateTime = tmpDateValues
  Set objWMIService = Nothing
  Set colLoggedEvents = Nothing
  Set objEvent = Nothing
End Function

１．への対応

まず、(1)からの２行

Dim n As Integer
n = colLoggedEvents.Count

で、変数 n にcolLoggedEventsのCountプロパティの値をぶち込む。

んで、(2)からの５行

If n = 0 Then
  ReDim tmpDateValues(n)
  getAnyEventDateTime = tmpDateValues
  Exit Function
End If

で、n が0のとき、すなわち、該当するイベントがなかった場合の対応をする。

要素数１の配列を返り値にしている。特に何も書き込まなくても、1900年1月0日（1899年12月30日）の0時0分0秒がセットされているみたい。

これで、(1)の問題はクリア。

２．への対応

まず、(3)からの２行

If n < eventIndex Then eventIndex = n
ReDim tmpDateValues(0 To eventIndex - 1)

で、取得したデータの数が要求した数よりも少ない場合に対応。

「10回分のデータを寄こせ！」と呼び出しても、n すなわちcolLoggedEventsのCountプロパティの値が、たとえば「2」だったら、eventIndexの値を「2」に書き換えてしまうことでエラーの芽を摘む。

そして、即座にReDim。まあ、ここまでムキになってReDimすることもないのでしょうが。

ここまで来たら、(4)からの６行

For i = 0 To eventIndex - 1
  Set objEvent = colLoggedEvents.ItemIndex(i)
  retTimeWritten = convUTCtoJST(parseTimeWritten(objEvent.timeWritten))
  tmpDateValues(i) = retTimeWritten
  DoEvents
Next

のForループでは、余計な条件判定は不要。

仮にエラーが出たとしても、(5)の

errorHandler:    '……(5)'
  getAnyEventDateTime = tmpDateValues
  Set objWMIService = Nothing
  Set colLoggedEvents = Nothing
  Set objEvent = Nothing

で、その時点でのtmpDateValuesを返り値として呼び出し元に返すので無問題。

実験

次のコードで呼び出してみる。

Public Sub run()
  Call eraseData
  Call writeEventDateTime(10, 6008)    '……(1)'
End Sub

Public Sub writeEventDateTime(ByVal cnt As Integer, _
                              ByVal ec As WindowsEventCode)
  If cnt > 30 Then cnt = 30
  Dim Sh As Worksheet
  Set Sh = ThisWorkbook.Worksheets("Main")
  Dim baseCell As Range
  Dim dateValues As Variant
  dateValues = getAnyEventDateTime(cnt, ec)
  If dateValues(0) = CDate(0) Then _    '……(2)'
    MsgBox "該当するデータがありません。": Exit Sub
  Dim i As Integer
  With Sh
    Set baseCell = .Range("A1")
    For i = 1 To UBound(dateValues) + 1    '……(3)'
      baseCell.Offset(i, 0).Value = dateValues(i - 1)
    Next
  End With
End Sub

変えたのは３箇所。

(1)の

Call writeEventDateTime(10, 6008)

では、対象のイベントIDとして6008を指定。

正常にシャットダウンせずに終了、ということらしい。

(2)からの２行（正味１行）

If dateValues(0) = CDate(0) Then _
    MsgBox "該当するデータがありません。": Exit Sub

は、該当するイベントデータがなかった場合の対応。

イベントデータが存在しなかった場合、受け取った配列の１番目の要素（インデックス番号「0」の要素）は、日付の初期値のはずなので、この場合はメッセージを表示して終了する。

後は(3)からの３行

For i = 1 To UBound(dateValues) + 1
  baseCell.Offset(i, 0).Value = dateValues(i - 1)
Next

をこう変えた。Function内部で配列の要素数を変えることがあるので、Uboundで要素数をこの段階で調べる必要がある。

実行結果

10回分要求したが、データは２つしかなかったみたいだ。

ちなみに、第２引数を「7005」にして、

Call writeEventDateTime(10, 6008)

呼び出してみると、

ちゃんとメッセージが表示された。

おわりに

取り扱っているオブジェクトがイメージしにくいものばかりなので、どんなエラーが起こるのか予想しづらいなあ。

今回使用したコード

いちおう、全部載っけときます。

リスト1-1

Public Sub run()
  Call eraseData
  Call writeEventDateTime(10, 6008)
'///↑第１引数と第２引数を変えれば、いろんなデータを取得して書き込むことができます。'
End Sub

リスト1-2

Public Sub writeEventDateTime(ByVal cnt As Integer, _
                              ByVal ec As WindowsEventCode)
  If cnt > 30 Then cnt = 30
  Dim Sh As Worksheet
  Set Sh = ThisWorkbook.Worksheets("Main")
  '///対象のワークシート名を「Main」にしています。'
  Dim baseCell As Range
  Dim dateValues As Variant
  dateValues = getAnyEventDateTime(cnt, ec)
  If dateValues(0) = CDate(0) Then _
    MsgBox "該当するデータがありません。": Exit Sub
  Dim i As Integer
  With Sh
    Set baseCell = .Range("A1")
    For i = 1 To UBound(dateValues) + 1
      baseCell.Offset(i, 0).Value = dateValues(i - 1)
    Next
  End With
End Sub

リスト1-3

Public Sub eraseData()
  Dim Sh As Worksheet
  Set Sh = ThisWorkbook.Worksheets("Main")
  Sh.Range("WriteInArea").Value = ""
  '///データ書き込みセル範囲に「WriteInArea」と名前を付けています。'
End Sub

リスト2-1

'///直近○回分のイベント日時を配列化する'
Public Function getAnyEventDateTime( _
                  ByVal eventIndex As Integer, _
                  ByVal eventCode As WindowsEventCode) As Date()
On Error GoTo errorHandler
  Dim strComputer As String
  Dim objWMIService As SWbemServices
  Dim colLoggedEvents As SWbemObjectSet
  Dim objEvent As SWbemObject
  Dim retTimeWritten As Date
  strComputer = "."
  Set objWMIService = GetObject("winmgmts:" & _
                                "{impersonationLevel=impersonate}!\\" & _
                                strComputer & _
                                "\root\cimv2")
  Set colLoggedEvents = _
    objWMIService.ExecQuery("SELECT * FROM Win32_NTLogEvent " & _
                            "WHERE Logfile = 'System' " & _
                            "AND EventCode = '" & eventCode & "'")
  Dim i As Integer
  Dim tmpDateValues() As Date
  Dim n As Integer
  n = colLoggedEvents.Count
  ReDim tmpDateValues(0 To eventIndex - 1)
  If n = 0 Then
    ReDim tmpDateValues(n)
    getAnyEventDateTime = tmpDateValues
    Exit Function
  End If
  If n < eventIndex Then eventIndex = n
  ReDim tmpDateValues(0 To eventIndex - 1)
  For i = 0 To eventIndex - 1
    Set objEvent = colLoggedEvents.ItemIndex(i)
    retTimeWritten = convUTCtoJST(parseTimeWritten(objEvent.timeWritten))
    tmpDateValues(i) = retTimeWritten
    DoEvents
  Next
errorHandler:
  getAnyEventDateTime = tmpDateValues
  Set objWMIService = Nothing
  Set colLoggedEvents = Nothing
  Set objEvent = Nothing
End Function

リスト2-2

Private Function parseTimeWritten(ByVal receiveData As Variant) As Date
  parseTimeWritten = _
        CDate(Mid(receiveData, 1, 4) & "/" & _
              Mid(receiveData, 5, 2) & "/" & _
              Mid(receiveData, 7, 2) & _
              " " & _
              Mid(receiveData, 9, 2) & ":" & _
              Mid(receiveData, 11, 2) & ":" & _
              Mid(receiveData, 13, 2))
End Function

リスト2-3

Private Function convUTCtoJST(ByVal timeData As Date) As Date
  convUTCtoJST = DateAdd("h", 9, timeData)
End Function

@akashi_keirin on Twitter

「直近○回分のシャットダウン日時」の配列を返すFunction

直近のイベント発生日時を配列化するFunction

このとき

akashi-keirin.hatenablog.com

作成したFunctionは、

直近のイベント日時を取得するFunction

だったが、これをちょいと改造して、

直近○回分のイベント日時を取得して配列化するFunction

にする。

改造するポイント

前回のリスト２を再掲する。

前回のリスト２

Public Function getLastEventDateTime( _
                  ByVal eventCode As WindowsEventCode) As Date    '……(1.)'
On Error GoTo errorHandler
  Dim strComputer As String
  Dim objWMIService As Object
  Dim colLoggedEvents As Object
  Dim objEvent As Object
  Dim retTimeWritten As Date
  strComputer = "."
  Set objWMIService = GetObject("winmgmts:" & _
                                "{impersonationLevel=impersonate}!\\" & _
                                strComputer & _
                                "\root\cimv2")
  Set colLoggedEvents = _
    objWMIService.ExecQuery("SELECT * FROM Win32_NTLogEvent " & _
                            "WHERE Logfile = 'System' " & _
                            "AND EventCode = '" & eventCode & "'")
  If Not colLoggedEvents.itemIndex(0) Is Nothing Then    '……(2.)'
    Set objEvent = colLoggedEvents.itemIndex(0)
    retTimeWritten = convUTCtoJST(parseTimeWritten(objEvent.timeWritten))
    getLastEventDateTime = retTimeWritten
  End If
errorHandler:
  Set objWMIService = Nothing
  Set colLoggedEvents = Nothing
  Set objEvent = Nothing
End Function

Private Function parseTimeWritten(ByVal receiveData As Variant) As Date
  parseTimeWritten = _
        CDate(Mid(receiveData, 1, 4) & "/" & _
              Mid(receiveData, 5, 2) & "/" & _
              Mid(receiveData, 7, 2) & _
              " " & _
              Mid(receiveData, 9, 2) & ":" & _
              Mid(receiveData, 11, 2) & ":" & _
              Mid(receiveData, 13, 2))
End Function

Private Function convUTCtoJST(ByVal timeData As Date) As Date
  convUTCtoJST = DateAdd("h", 9, timeData)
End Function

改造ポイントは２つ。すなわち、

1. 「○回分」を表す引数を追加する
2. 必要な数だけループしてイベント日時を取得し、配列にぶち込む

である。

改造したコード

まずは改造後のコードを載せる。

リスト１　標準モジュール

'///宣言セクション'
Public Enum WindowsEventCode
  osStartUp = 12
  osShutDown = 13
  winStartUp = 6005
  winShutDown = 6006
End Enum
'///直近○回分のイベント日時を配列化する'
Public Function getAnyEventDateTime( _
                  ByVal eventIndex As Integer, _
                  ByVal eventCode As WindowsEventCode) _
                    As Date()    '……(1)'
On Error GoTo errorHandler
  Dim strComputer As String
  Dim objWMIService As SWbemServices
  Dim colLoggedEvents As SWbemObjectSet
  Dim objEvent As SWbemObject
  Dim retTimeWritten As Date
  strComputer = "."
  Set objWMIService = GetObject("winmgmts:" & _
                                "{impersonationLevel=impersonate}!\\" & _
                                strComputer & _
                                "\root\cimv2")
  Set colLoggedEvents = _
    objWMIService.ExecQuery("SELECT * FROM Win32_NTLogEvent " & _
                            "WHERE Logfile = 'System' " & _
                            "AND EventCode = '" & eventCode & "'")
  Dim i As Integer
  Dim tmpDateValues() As Date    '……(2)'
  ReDim tmpDateValues(0 To eventIndex - 1)
  For i = 0 To eventIndex - 1
    If Not colLoggedEvents.itemIndex(i) Is Nothing Then    '……(3)'
      Set objEvent = colLoggedEvents.itemIndex(i)    '……(4)'
      retTimeWritten = convUTCtoJST(parseTimeWritten(objEvent.TimeWritten))
      tmpDateValues(i) = retTimeWritten    '……(5)'
    End If
    DoEvents
  Next
  getAnyEventDateTime = tmpDateValues    '……(6)'
errorHandler:
  Set objWMIService = Nothing
  Set colLoggedEvents = Nothing
  Set objEvent = Nothing
End Function
'///日付時刻文字列変換用'
Private Function parseTimeWritten(ByVal receiveData As Variant) As Date
  parseTimeWritten = _
        CDate(Mid(receiveData, 1, 4) & "/" & _
              Mid(receiveData, 5, 2) & "/" & _
              Mid(receiveData, 7, 2) & _
              " " & _
              Mid(receiveData, 9, 2) & ":" & _
              Mid(receiveData, 11, 2) & ":" & _
              Mid(receiveData, 13, 2))
End Function
'///UTC→JST変換用'
Private Function convUTCtoJST(ByVal timeData As Date) As Date
  convUTCtoJST = DateAdd("h", 9, timeData)
End Function

変更箇所についてのみ説明する。

まずは、(1)の

Public Function getAnyEventDateTime( _
                  ByVal eventIndex As Integer, _
                  ByVal eventCode As WindowsEventCode) _
                    As Date()

引数が２つになった。

第１引数のeventIndexで配列に格納する要素数を受け取る。eventIndexという名前にしてしまったが、実際に受け取る数字は要素数なので、インデックス番号最大値＋１。ちょっと分かりにくいかもなあ。

第２引数は前回のまま。WindowsEventCodeという自作列挙体型にしている。列挙体については、現行

Public Enum WindowsEventCode
  osStartUp = 12
  osShutDown = 13
  winStartUp = 6005
  winShutDown = 6006
End Enum

の４つだけだが、今後随時必要なものを追加していったら良いと思う。

(2)からの２行

Dim tmpDateValues() As Date
ReDim tmpDateValues(0 To eventIndex - 1)

では、取得したイベント日時をぶち込むための配列変数tmpDateValueを準備し、すかさず「eventIndex - 1」でReDim。

一旦配列を作成しておいて、最後にこの配列を返り値にする、というおなじみの段取り。

(3)の

If Not colLoggedEvents.itemIndex(i) Is Nothing Then

では、一応取得したコレクションの要素一つ一つについて確認するようにした。別に一つ一つ確認する必要はないようにも思うが……。

(4)の

Set objEvent = colLoggedEvents.itemIndex(i)

で、コレクションの要素を変数objEventにぶち込み、日時をVBAの日付型の形に変換し、JSTに変換したら、(5)の

tmpDateValues(i) = retTimeWritten

で、一旦配列変数tmpDateValuesに格納していく。

このForループを抜けたら、配列は完成しているので、最後に(6)の

getAnyEventDateTime = tmpDateValues

で配列を返り値にしたらおしまい。

使用例

次のような準備をして使ってみる。

こんなふうに、

シートを準備して、セル範囲に「WriteInArea」と名前を付ける。

で、下記のコードで実行してみる。

リスト２　標準モジュール

'///エントリポイント'
Public Sub run()
  Call eraseData
  Call writeEventDateTime(30, winShutDown)
End Sub
'///データを取得して書き込む'
Public Sub writeEventDateTime(ByVal cnt As Integer, _
                              ByVal ec As WindowsEventCode)    '……(1)'
  If cnt > 30 Then cnt = 30    '……(2)'
  Dim Sh As Worksheet
  Set Sh = ThisWorkbook.Worksheets("Main")
  Dim baseCell As Range
  Dim dateValues As Variant    '……(3)'
  dateValues = getAnyEventDateTime(cnt, ec)
  Dim i As Integer
  With Sh
    Set baseCell = .Range("A1")
    For i = 1 To cnt    '……(4)'
      baseCell.Offset(i, 0).Value = dateValues(i - 1)
    Next
  End With
End Sub
'///書き込みエリアをクリアする'
Public Sub eraseData()
  Dim Sh As Worksheet
  Set Sh = ThisWorkbook.Worksheets("Main")
  Sh.Range("WriteInArea").Value = ""
End Sub

writeEventDateTimeプロシージャが、データ書き込みのメインの処理。

(1)の

Public Sub writeEventDateTime(ByVal cnt As Integer, _
                              ByVal ec As WindowsEventCode)

で、２つの引数を設定。

cntは、「○回分のイベント」の「○」の部分。ecは「イベント」の部分。

直近cnt回分のecイベントの日時をセルに書き込んでいくマクロ、ということになる。

(2)の

If cnt > 30 Then cnt = 30

では、第１引数に30を超える数値が渡されたときにcntを「30」にするようにしている。単独のイベントログは30個までっぽいので（真相は知りませんｗ）。

(3)からの２行

Dim dateValues As Variant
dateValues = getAnyEventDateTime(cnt, ec)

では、getAnyEventDateTimeの返り値を受け取るためのVariant型変数を準備して、返り値を受け取っている。

あとは、(4)からの３行

For i = 1 To cnt
  baseCell.Offset(i, 0).Value = dateValues(i - 1)
Next

のForループで、一つづつ下へ下へと配列dateValuesの要素を書き込んで行く。

実行結果

エントリポイントのrunプロシージャを実行すると、

この通り、日時が書き込まれた。

おわりに

もし、

職場のPCをシャットダウンする時刻＝職場から出る時刻

みたいな人だったら、

本当の退社時刻

を記録するのに使えるかも。

職場のPCでこのプログラムを実行すると、「へえ、この日はこんなに遅くまで残ってたのか……」とか、「この時期は結構順調だったんだな……」ということが分かって面白かったっす。

@akashi_keirin on Twitter

追記

あ、今回のリスト１の中で、getAnyEventDateTimeプロシージャの冒頭、変数宣言のところで、しれーっと

Dim strComputer As String
Dim objWMIService As SWbemServices
Dim colLoggedEvents As SWbemObjectSet
Dim objEvent As SWbemObject
Dim retTimeWritten As Date

なんて書いちゃってますね。

SWbemServices型とか、SWbemObjectSet型とか、SWbemObject型とか。

これは、

akashi-keirin.hatenablog.com

このとき、 id:imihito さんからいただいたコメント、すなわち

ItemIndex の出所は「Microsoft WMI Scripting V 1.2 Library」を参照して、オブジェクトブラウザから「WbemScripting.SWbemObjectSet」を見て貰えれば

に従って、オブジェクトブラウザで調べてみて発見しました。

こいつらがSWbemServicesクラスのメンバ。確かにExecQueryメソッドってのがある。

SWbemObjectSetクラスのメンバ。ItemIndexプロパティがある。

んで、コチラがSWbemObjectクラスのメンバ……って、TimeWrittenプロパティなんてねえぞ！？

でも、フツーに取得できているということは、親クラスから継承しているんでしょうね。たぶん。

ちなみに、（当たり前ですが）参照設定で「Microsoft WMI Scripting Vx.x Library」をオンにしておかないと派手にエラーが出ます。