OutLookメール自動作成メソッド

メール自動作成ツール~Outlookへの対応

このとき

akashi-keirin.hatenablog.com

akashi-keirin.hatenablog.com

作成したメール自動作成ツール、LotusNotes、Thunderbirdの両方に対応していて非常に便利なので、重宝している。

で、せっかくなのでOutlookにも対応させてみようと思い、ちょっとやってみた。

前に作成したクラスに、Outlookメール作成メソッドを追加する。

参考:今回使用する自作クラスのプロパティ一覧
プロパティ 説明
mailTo String 宛先のメールアドレス
CC String CCアドレス
BCC String BCCアドレス
mailSubject String メールの件名
belongsTo String 名宛て人の所属
jobTitle String 名宛て人の肩書
personName String 名宛て人の名前
returnReceipt String 受信確認の有無
mailBody String メール本文
attFiles String 添付ファイルフルパス
senderData String 送信人のデータ
numOfBody Integer 本文の段落数
numOfAttFiles Integer 添付ファイル数
numOfSenderData Integer 送信人データの行数

今にして思えば、最後の3つとか、クラスの外部に公開する意味ないなー。

Outlookに対応する

createOutlookMailというメソッド名にした。

メソッドのコードを載せる。

Public Sub createOutlookMail()
On Error Resume Next
  Err.Clear
  Dim objOutlook As Outlook.Application
  Set objOutlook = GetObject(, "Outlook.Application")    '……(1)'
  If objOutlook Is Nothing Then _
      makeUserSick "Outlookが起動してないしwww": End    '……(2)'
  '本文文字列の作成'
  '左肩部分の作成'
  Dim strAddressee As String
  strAddressee = belongsTo_ & vbCrLf & " " & _
                 jobTitle_ & " " & _
                 personName_ & " 様" & _
                 vbCrLf & vbCrLf & vbCrLf    '……(3)'
  '本文をstrBodyに連結していく'
  Dim strBody As String
  Dim i As Integer
  For i = 1 To numOfBody    '……(4)'
    strBody = strBody & mailBody_(i) & vbCrLf & vbCrLf
  Next
  Dim objMailItem As MailItem
  Set objMailItem = objOutlook.CreateItem(olMailItem)    '……(5)'
  With objMailItem
    'デフォルトの署名文字列を取得するために一旦RichText形式にする    ……(6)'
    .BodyFormat = olFormatRichText
    .Display
    'この時点ではBodyプロパティには署名文字列しか入っていないので、'
    '署名文字列を変数に入れる。'
    Dim signatureString
    signatureString = .Body
    'ここでHTML形式に変える'
    .BodyFormat = olFormatHTML
    .To = mailTo    '……(7)'
    .CC = CC_
    .BCC = BCC_
    .Subject = mailSubject_
    '左肩、本文、署名の順にBodyプロパティに書き込む'
    .Body = strAddressee & _
            strBody & vbCrLf & vbCrLf & _
            signatureString
    '添付ファイルの設定'
    If numOfAttFiles_ <> 0 Then
      For i = 1 To numOfAttFiles_
        .Attachments.Add attFiles_(i)
      Next
    End If
  End With
  If Err.Number > 0 Then
    Call errorCatch("MailDataクラスのcreateOutlookMailメソッド", _
                    Err.Number, _
                    Err.Description)
    MsgBox "【Main】シートへの入力に不備がなかったか、確認してやり直してください。", _
           vbCritical
  End If
On Error GoTo 0
End Sub

ちょい長くなってしまったけれど、単にメールを作るだけならそんなに難しいとは感じなかった。

まず、(1)の

Set objOutlook = GetObject(, "Outlook.Application")

で現在起動中のOutlookアプリケーションオブジェクトを取得。

(2)の

If objOutlook Is Nothing Then _
    makeUserSick "Outlookが起動してないしwww": End

では、Outlookが起動していなかったらobjOutlookがNothingになるはずなので、ユーザーを煽って処理自体を終了。

makeUserSickは、もちろんこのときのやつですw

いきなりEndで終わるなんて、何か投げやりな対応なので、今後詰めていく必要がありそう。

(3)の

strAddressee = belongsTo_ & vbCrLf & " " & _
                 jobTitle_ & " " & _
                 personName_ & " 様" & _
                 vbCrLf & vbCrLf & vbCrLf

では、本文の宛名の部分の文字列を作成。まあ、別に本文と分離する必要はないかなあとも思ったんだが、一応、別々にしといた。

(4)の

For i = 1 To numOfBody_    '……(4)'
  strBody = strBody & mailBody_(i) & vbCrLf & vbCrLf
Next

では、本文を段落ごとに格納した内部配列mailBody_()から要素を取り出してきて、改行コードとともに連結している。

ここまでで、本文の左肩部分と本文がそれぞれひとかたまりの文字列になっている。

ここからがOutlook側の処理。

まず、(5)の

Set objMailItem = objOutlook.CreateItem(olMailItem)

でMailItemオブジェクトをインスタンス化する。

まだイマイチMailItemオブジェクトって何者なのかよく分かっていない。

MailItems.Add とかだと理解しやすいんだけれど、どうもそういうオブジェクトモデルではないらしい。

んで、(6)からの5行(コメント除く)がちょっとめんどくさい。

'デフォルトの署名文字列を取得するために一旦RichText形式にする'
.BodyFormat = olFormatRichText
.Display
'この時点ではBodyプロパティには署名文字列しか入っていないので、'
'署名文字列を変数に入れる。'
Dim signatureString
signatureString = .Body
'ここでHTML形式に変える'
.BodyFormat = olFormatHTML

手順としては、

RichText形式を指定→新規メールを表示→署名文字列を変数に格納→HTML形式に変換

という形。

なんでこんなに面倒なことをしているのかというと、

はじめからHTML形式を指定するとデフォルトの署名が書き込まれない

から。このあたりの挙動は、そもそもOutlookの設定でなんとかなるかも知れない。Outlookは今まで使ったことがなかったのでよく分かっていないのです。

まあ、ここまででメール本体を作り上げる準備ができたことになるので、あとは(7)からの12行(実質10行。コメント除く)

.To = mailTo
.CC = CC_
.BCC = BCC_
.Subject = mailSubject_
'左肩、本文、署名の順にBodyプロパティに書き込む'
.Body = strAddressee & _
        strBody & vbCrLf & vbCrLf & _
        signatureString
'添付ファイルの設定'
If numOfAttFiles_ <> 0 Then
  For i = 1 To numOfAttFiles_
    .Attachments.Add attFiles_(i)
  Next
End If

で一気に必要事項を書き込んでおしまい。

準備

まず、Outlookの[ファイル]メニューから[オプション]→[メール]へと進み、[署名]ボタンをクリックして、

f:id:akashi_keirin:20171210115452j:plain

こんなふうに署名を作成した。

実行

クラスをインスタンス化してcreateOutlookMailメソッドを実行してみると、

f:id:akashi_keirin:20171210115519j:plain

f:id:akashi_keirin:20171210115502j:plain

f:id:akashi_keirin:20171210115539j:plain

一応、メールは無事に作成された。

おわりに

まだイマイチOutlookのオブジェクトモデルが理解できていないので、全然ダメダメですね。

フォントを変えたり、文字の大きさを変えたり、といったことも盛り込んで行かないと、現状めちゃくちゃ読みづらい見た目のメールになってしまうのが大きな課題です。

しっかし、初心者のころに作ったクラスだけあって、イマイチな設計やなあ……。

@akashi_keirin on Twitter

がんばれ! isKanjiメソッドくん!!!!!!!!

文字列から漢字のみ抽出する

isKanjiメソッドを強引に使う

前回

akashi-keirin.hatenablog.com

作成したisKanjiメソッドの使いどころを無理矢理発明した。

準備

まず、

f:id:akashi_keirin:20171209212736j:plain

f:id:akashi_keirin:20171209212804j:plain

こんな風にシートを作っておいて、A1セルに「TextCell」、C2セルに「BaseCell」と名前を定義しておく。ちなみに、シートには「Main」と名前を付けている。

んで、コマンドボタンを押したら、C2セルから下にずらーっとA1セルの文字列から漢字だけを抽出して1列に並べる。

ついでに、D列にはそれぞれの漢字の読みも書き込んでしまおう。

もちろん、何の役に立つのかは分からない。諸君が自分で考えてくれたまえ。これは役に立つツール類の紹介ではなくて、私自身の勉強なのだ。

コーディング

とりあえず、コードを載っけてしまおう。

リスト1 標準モジュール
Public Sub pickOutAndOrderKanji()
  Dim Sh As Worksheet
  Set Sh = ThisWorkbook.Worksheets("Main")
  Dim textCell As Range
  Set textCell = Sh.Range("TextCell")
  Dim baseCell As Range
  Set baseCell = Sh.Range("BaseCell")
  baseCell.CurrentRegion.ClearContents
  Dim wholeString As String
  wholeString = textCell.Value
  If Len(wholeString) < 1 Then _
      makeUserSick ("文字がないやんけぼけー!"): Exit Sub    '……(1)'
  Dim i As Integer
  Dim n As Integer
  Dim targetChar As String
  Dim tmp As String
  n = 0
  For i = 1 To Len(wholeString)    '……(2)'
    targetChar = Mid(wholeString, i, 1)    '……(3)'
    If isKanji(targetChar) Then    '……(4)'
      With baseCell
        .Offset(n, 0).Value = targetChar    '……(5)'
        tmp = Application.GetPhonetic(targetChar)    '……(6)'
        tmp = StrConv(tmp, vbHiragana)
        .Offset(n, 1).Value = tmp
      End With
      n = n + 1    '……(7)'
    End If
  Next
End Sub

出だしの7行は、「Main」シートやら文字列の入ったセルやら基準になるセルなんかを変数にぶち込んだり、前回の書き込みを削除したり、といった処理。

んで、準備ができたら、まず(1)の

If Len(wholeString) < 1 Then _
    makeUserSick ("文字がないやんけぼけー!"): Exit Sub

で処理対象文字列を調べる。文字数が0だったらそもそも処理する意味がないので、ここで終了。ちなみに、makeUserSickメソッドというのは、このとき作成したもの。

ここからが処理の中心。(2)からのForループでは、

For i = 1 To Len(wholeString)

開始・終了条件をこのように設定。1文字目から最終文字目までをループ処理する。

んで、Forブロックの中身へ。

(3)の

targetChar = Mid(wholeString, i, 1)

では、Mid関数を使って1文字を切り出し、変数targetCharにぶち込む。

(4)の

If isKanji(targetChar) Then

では、このとき作成したisKanjiメソッドでtargetCharの中身が漢字かどうかを判定。True、すなわち漢字だったら以下の処理を行う。

まず(5)。

.Offset(n, 0).Value = targetChar

C列に文字を書き込む。isKanjiメソッドがTrueを返しているのだから、漢字が書き込まれることになる。

で、(6)からの3行。

tmp = Application.GetPhonetic(targetChar)
tmp = StrConv(tmp, vbHiragana)
.Offset(n, 1).Value = tmp

まず、

tmp = Application.GetPhonetic(targetChar)

Application.GetPhoneticメソッドを用いて、読み仮名を変数tmpにぶち込む。ただ、この時点ではtmpの中身はカタカナなので、次の

tmp = StrConv(tmp, vbHiragana)

でStrConv関数を用いて平仮名に変えてtmpにぶち込む。

最後に

.Offset(n, 1).Value = tmp

でD2セルから数えて上から n 番目(開始は0)のセルにtmpの中身を書き込む。

最後に(7)の

n = n + 1

で n をインクリメントする。

実行結果

上掲のpickOutAndOrderKanjiメソッドをコマンドボタンに登録し、ボタンクリックで実行してみる。

ちなみに、A1セルに入っている文字列は、

お前はアホか。アホちゃいまんねん、馬鹿ですねん。競輪は日本の国技です。「C#(シーシャープ)」は、完全にオブジェクト指向プログラミング(OOP)のための言語です。こう書くと何か難しい言語のような感じを受けるかも知れませんが、心配はいりません。オブジェクト指向プログラミングでは、難しいことは全部カプセル化し、プログラマはその恩恵を受けるだけなのです。

というものとする。

f:id:akashi_keirin:20171209212821j:plain

ほい。この通り、うまく行って……

ない!!!!!!!!

orz

よく見ると、11行目、もともと「C」(半角アルファベットの"C")、「#」(半角記号の"#")だったところが、漢字でもないのに出力されてしまっている。これが、このとき申し上げたisKanjiメソッドの致命的な欠陥です。

何がイカンのか

原因は非常にカンタン。

f:id:akashi_keirin:20171209212830j:plain

たとえば、1バイト文字の文字コード「DF」(半角カタカナの半濁点"゚")を調べてみる。

f:id:akashi_keirin:20171209212843j:plain

10進数に直すと「223」、つまり、正の数なんである。

このとき、漢字かどうかの判定をどうしていたか。

Asc(char) >= &H889F

こんな条件式で判定していたのである。

2バイト文字の文字コードは全て負の数だったので、こんな条件式では当然1バイト文字は全てTrueになってしまうのである。

コードの修正

そこで、isKanjiメソッドのコードを以下のように修正する。

スト2 標準モジュール
Public Function isKanji(ByVal targetCharacter As String) As Boolean
  Dim char As String
  char = targetCharacter
  If Len(char) <> 1 Then Err.Raise Number:=10001, _
                                   Description:="引数は1文字のみにしてください。"
  If Asc(char) > 0 Then isKanji = False: Exit Function    '……(*)'
  If Asc(char) >= &H889F Then
    isKanji = True
  Else
    isKanji = False
  End If
End Function

付け加えたのは(*)の

If Asc(char) > 0 Then isKanji = False: Exit Function

だけ。要するに、文字コードが正の数だったら即Falseを返してFunctionを抜けるようにしているだけ。

テスト

生まれ変わったisKanjiメソッドをテストしてみる。

イミディエイト・ウインドウで

?isKanji("F")

を始めいろいろな1バイト文字を引数にしてisKanjiメソッドを実行してみると、

f:id:akashi_keirin:20171209212852j:plain

ほれ、ちゃんと期待したとおりの結果が出ている。

おわりに

これで一件落着、めでたしめでたし……と思いきや、

f:id:akashi_keirin:20171209212901j:plain

orz

わがisKanjiメソッドの運命やいかに!(続きません)

@akashi_keirin on Twitter

文字が漢字かどうかを判定するFunction

文字が漢字かどうかを判定するFunction

漢字かどうかの判定

文字が漢字かどうかを判定するロジックを考えた。

f:id:akashi_keirin:20171209172058j:plain

f:id:akashi_keirin:20171209172119j:plain

画像の出典はコチラのサイトっす。

Shift_JIS文字コード表を見ると、漢字は 889F以降に割り当てられているっぽい。

16進数の889Fってのは、

f:id:akashi_keirin:20171209172142j:plain

この通り、10進数だと-30561

んで、次の88A0

f:id:akashi_keirin:20171209172217j:plain

この通り、10進数だと-30560になる。

ということは、文字コード889F、すなわち-30561以上だったら漢字ということだ。

コーディング

以上を踏まえてコーディングする。

リスト1 標準モジュール
Public Function isKanji(ByVal targetCharacter As String) As Boolean
  Dim char As String
  char = targetCharacter    '……(1)'
  If Len(char) <> 1 Then _
      Err.Raise Number:=10001, _
                Description:="引数は1文字のみにしてください。"    '……(2)'
  If Asc(char) >= &H889F Then    '……(3)'
    isKanji = True
  Else
    isKanji = False
  End If
End Function

(1)の

char = targetCharacter

では、引数targetCharacterで受け取った文字(列)を変数charにぶち込んでいる。別にこんなことしなくても良いのだけれど、引数名を「targetCharacter」と長い名前にしたので、そのまま使ったら1行が長くなるから。ただそれだけのこと。自作関数やメソッドの引数名をなるべく説明的に付けようと最近決心しただけです。

(2)の3行(実質1行)

If Len(char) <> 1 Then _
    Err.Raise Number:=10001, _
              Description:="引数は1文字のみにしてください。"

はガード節。そもそも1文字について漢字かどうか判定したいので、引数に複数文字の文字列を与えられたら困る。だからエラーを吐く仕様にした。

いつも、自作エラーの番号は10001とかテキトーかつ投げやりな番号にしているんだけれど、こういうのもコーディング規約的に決めておいたほうがいいんですかね?

メインの処理は(3)からの5行

If Asc(char) >= &H889F Then
  isKanji = True
Else
  isKanji = False
End If

Asc関数で文字コードの数字が得られるので、それを16進数の889Fと比較して、889F以上だったらTrue、未満だったらFalseを返すようにした。

実行結果

イミディエイト・ウインドウで

?isKanji("亜")

など、文字コード表先頭の漢字「亜」を皮切りにいくつかの2バイト文字を引数にしてisKanjiメソッドを実行してみた結果が

f:id:akashi_keirin:20171209172250j:plain

コチラ。

ちゃんと期待した結果が得られた。

おわりに

ただ、コンピュータに詳しい人なら一瞬で気づいたと思いますけど、このFunctionには少なくとも1つ、重大な欠陥があるのです。そのあたりは次回……。

でも、そんなことはともかく、このFunctionの使いどころって、何なのでしょうねえ……?

@akashi_keirin on Twitter

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

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

Openイベントで接続する

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

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

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

f:id:akashi_keirin:20171202180921j:plain

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

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

そこで、

akashi-keirin.hatenablog.com

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

とりあえず、

f:id:akashi_keirin:20171202181702j:plain

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

差込データ.xlsxには、

f:id:akashi_keirin:20171202180945j:plain

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

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

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

f:id:akashi_keirin:20171202180955j:plain

ここでDocumentを選んで、

f:id:akashi_keirin:20171202181003j:plain

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

リスト1 ThisDocumentモジュール
Private Sub Document_Open()
  Call setMailMergeDataSource(ThisDocument, _
                              "差込データ.xlsx", _
                              "競輪場")
End Sub

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

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

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

スト2 標準モジュール
'差込データソースに指定する'
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を開いてみる。

f:id:akashi_keirin:20171202182153j:plain

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

ついでに

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

f:id:akashi_keirin:20171202181025j:plain

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

f:id:akashi_keirin:20171202181052j:plain

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

f:id:akashi_keirin:20171202181025j:plain

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

そうするとまた

f:id:akashi_keirin:20171202181052j:plain

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

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

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

リスト3 標準モジュール
'差込データソースを切断する'
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モジュールに以下のコードを書く。

今度は

f:id:akashi_keirin:20171202181242j:plain

ココでCloseを選ぶ。

リスト4 ThisDocumentモジュール
Private Sub Document_Close()
  Call disconnectMailMergeDataSource(ThisDocument)
End Sub

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

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

訂正と追記

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

ハッキリ言って、無意味

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

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

リスト5 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が存在しないファイルだったりすると、

f:id:akashi_keirin:20171202180921j:plain

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

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

Call disconnectMailMergeDataSource(ThisDocument)

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

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

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

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

【追記ここまで】

おわりに

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

@akashi_keirin on Twitter

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

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

akashi-keirin.hatenablog.com

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

コード

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

リスト1 標準モジュール
Public Sub タブ位置設定()
  Dim objDoc As Document
  Set objDoc = ActiveDocument
  Dim tmpStr As String
  tmpStr = InputBox( _
             Prompt:="指定したいタブ位置(整数値)を「,」(半角カンマ)区切りで入力せよ。" _
                     & vbCrLf & _
                     "※小数値は、小数部分を丸めて整数値として扱います。", _
             Title:="タブ位置の指定")
'///ガード節その1'
'///何も入力されなかったら処理を抜ける(キャンセルの場合も同じ)。'
  If tmpStr = "" Then Exit Sub
'///ガード節その2'
'///半角カンマが全くないのに、入力された値が数値として評価できない値だったら処理を抜ける。'
  If InStr(tmpStr, ",") = 0 And _
     Not IsNumeric(tmpStr) Then
     Call makeUserSick("数字と半角カンマで入力せんかいぼけー!")
     Exit Sub
  End If
'///ガード節その3'
'///カンマ区切りで入力された値に、数値以外が入っていたら処理を抜ける。'
  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

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

実行

f:id:akashi_keirin:20171126203049j:plain

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

f:id:akashi_keirin:20171126203223j:plain

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

f:id:akashi_keirin:20171126203303j:plain

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

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

f:id:akashi_keirin:20171126203344j:plain

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

f:id:akashi_keirin:20171126203453j:plain

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

f:id:akashi_keirin:20171126203512j:plain

f:id:akashi_keirin:20171126203529j:plain

(゚Д゚)ハァ? 四捨五入と五捨六入が交互に……。

f:id:akashi_keirin:20171126203559j:plain

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

f:id:akashi_keirin:20171126203622j:plain

煽られるw

f:id:akashi_keirin:20171126203645j:plain

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

f:id:akashi_keirin:20171126203705j:plain

煽られるw

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

akashi-keirin.hatenablog.com

このときのものです。

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

@akashi_keirin on Twitter

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

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

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

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

    _________
 /         \ 
/ /・\  /・\  \
|    ̄ ̄    ̄   | ち~んw
|    (_人_)   |
|     \   |      |
\      \_|   /

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

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

対応

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

コーディング

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

リスト1 標準モジュールの宣言セクション
Public Const MAKE_USER_SICK_2013 As String = _
              "       _______" & vbCrLf & _
              "   /       \" & vbCrLf & _
              "/ /・\  /・\ \" & vbCrLf & _
              "|   ̄ ̄    ̄ ̄   |   ち~んw" & vbCrLf & _
              "|    (_人_)   |" & vbCrLf & _
              "|     \  |   |" & vbCrLf & _
              "\     \_|  /"

Public Const MAKE_USER_SICK_2010 As String = _
              "     _______" & vbCrLf & _
              " /               \ " & vbCrLf & _
              "/ /・\  /・\     \" & vbCrLf & _
              "|   ̄ ̄    ̄         | ち~んw" & vbCrLf & _
              "|    (_人_)         |" & vbCrLf & _
              "|     \     |          |" & vbCrLf & _
              "\      \_|       /"

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

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

スト2 標準モジュール
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)

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

ここで受け取ったmsgプラス「ち~んw」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と同じ文字列を呼び出すようにしているけれど、ホントにこれで良いのかは不明w

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

あとは、(4)の

MsgBox msg & vbCrLf & str

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

実行

次のコードで実行する。

リスト3 標準モジュール
Public Sub test()
  Call makeUserSick("ほげほげ")
End Sub

実行結果

f:id:akashi_keirin:20171126201234j:plain

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

やっぱりむかつくw

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

@akashi_keirin on Twitter

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

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

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

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

akashi-keirin.hatenablog.com

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

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

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

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

リスト1 標準モジュール
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)

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

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

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

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

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

(2)の

dataSourceFullName = objDoc.Path & "\" & objFileName

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

んで、(3)からの4行(実質3行)

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

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

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

実行

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

f:id:akashi_keirin:20171125215357j:plain

こんなデータ(w)を用意しておく。

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

スト2 標準モジュール
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 & "ち~んw.docx"    '……(4)'
  Call setMailMergeDataSource(newDoc, "test.xlsx", "競輪選手")    '……(5)'
End Sub

まず、(1)からの2行

Dim orgDoc As Document
Set orgDoc = ActiveDocument

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

(2)からの2行

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

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

(3)からの2行

Dim newDoc As Document
Set newDoc = Documents.Add

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

さらに(4)の

newDoc.SaveAs2 rootPath & "ち~んw.docx"

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

あとは、(5)の

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

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

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

実行結果

まず、

f:id:akashi_keirin:20171125215450j:plain

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

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

f:id:akashi_keirin:20171125215501j:plain

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

f:id:akashi_keirin:20171125215514j:plain

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

f:id:akashi_keirin:20171125215528j:plain

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

おわりに

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

@akashi_keirin on Twitter

こちらもどうぞ

akashi-keirin.hatenablog.com