任意の文字列に対して擬似的にワードラップを適用する

任意の文字列に対して擬似的にワードラップを適用する

総務省の通知文書

きみは、これを見て何も感じないのか?

この画像を見て、何も感じないだろうか。

何も感じなかった、という人は、では、次の画像はどうだろうか。

どうだろうか。

私は、こわかった

二つ目の画像でマーカを施した箇所は、〝全角の2けた以上の数字〟である。

全部行内におさまっていて、数字が行分かれしていないのは単なる偶然なのだろうか……?

この画像は、同じ文書の別の箇所である。これまた、2けた以上の数字がどれ一つとして行分かれしていないのである。

もちろん、(勝手にWordで作成していると決めつけるが、)Wordに全角2桁以上の数字を行折り返しのときにうまい具合に行内におさめてくれるような気の利いた機能はない。(……でいいんですよね? もし間違えていたら教えてください)

だから、行またぎのところに数字があると、

フツーに行分かれしてしまう。無慈悲である。

ま、まさか……。

それにしても、できあがった通知文書を見ると、2けた以上の数字が行分かれしているところがない。不自然なぐらい。

もしかして……。


めちゃくちゃ入念にチェックしている

のだろうか……。

擬似的にワードラップっぽくしてみる

〝ZERO WIDTH NO BREAK SPACE〟を使う

文字と文字の間に〝ZERO WIDTH NO BREAK SPACE〟が挟まっていると、その部分で行分かれすることを自動で防いでくれるらしい。

「3」と「1」の間に挟まっているへんなやつが〝ZERO WIDTH NO BREAK SPACE〟というやつ。すべての編集記号を表示しているから見えているだけで、印刷すると非表示になる。

〝ZERO WIDTH NO BREAK SPACE〟は入力しにくい

ところが、〝ZERO WIDTH NO BREAK SPACE〟というやつは非常に入力しにくい。

何せ、〝UNICODE文字コードFEFF〟である。

自分でも何を言っているのかわからないぐいらである。

単語登録してみようとしたが、できなかった。(やり方次第でできるのかもしれない。やり方を知っている人がいたら教えてください。)

そこで、マクロですよ!

そうなると、マクロの出番である。

得に、Wordのマクロは、こういう〝めんどくさい作業を1クリックでできるようにする〟ところに真価があると思う一人である。

選択した文字列のカンチャンに〝ZERO WIDTH NO BREAK SPACE〟を入れるマクロ

リスト1
Public Sub SetCustomWordwrap()
  Dim ZWNBSP As String
  ZWNBSP = ChrW(&HFEFF)
  Dim rng As Range
  Set rng = Selection.Range
  '文字が選択されていない、1文字だけのときはExit'
  Dim cnt As Long
  cnt = rng.End - rng.Start
  If cnt < 2 Then Exit Sub
  Debug.Print rng.Characters.Count
  Dim tmpText As String
  tmpText = rng.Text
  Dim c As String
  Dim result As String
  Dim i As Long
  For i = 1 To Len(tmpText) - 1
    c = Mid(tmpText, i, 1)
    If c <> ZWNBSP Then
      result = result & c & ZWNBSP
    End If
  Next
  result = result & Mid(tmpText, Len(tmpText), 1)
  rng.Text = result
End Sub

とりあえず作ってみただけなので、検証は不十分であることをおことわりしておく。

動作確認

マクロをクイック アクセス ツール バーに登録し、文字列を選択して実行してみる。

こんな感じ。

ワードラップっぽい挙動になる。

1行の文字数を超えるような範囲とか、ページ全体なんかを選択したときの動作は、怖くて確認していない。追い追い検証して制限をかけていくことにする。

ついでに

選択範囲から〝ZERO WIDTH NO BREAK SPACE〟を取り除くマクロも掲載しておく。

Public Sub RemoveZWNBSP()
  Dim ZWNBSP As String
  ZWNBSP = ChrW(&HFEFF)
  Dim rng As Range
  Set rng = Selection.Range
  Dim tmpText As String
  tmpText = rng.Text
  tmpText = Replace(tmpText, ZWNBSP, "")
  rng.Text = tmpText
End Sub

おわりに

これで書類作成がちょっとでも楽になったらいいですね。

カーソル位置にインライン画像を挿入するマクロ(Word)

 

カーソル位置にインライン画像を挿入するマクロ

もちろん、ただ単にインライン画像を挿入するだけではありません。

仕様

  • ダイアログボックスで画像を選択する。
  • カーソル位置に挿入する。
  • 画像用のスタイルを当てる
  • 四方に枠線を施す
  • 図表番号を付ける

実にこれだけのことが1クリックでできます。

ソースコード

リスト1
Option Explicit

'ファイルフィルタ用文字列'
Private Const FILE_FILTER_TYPE As String = "すべての図"
Private Const FILE_FILTER_EXTENTION As String = "*.emf;*.wmf;*.jpg;*.jpeg;*.jfif;*.jpe;*.png;*.bmp;*.dib;*.rle;*.gif;*.emz;*.wmz;*.pcz;*.tif;*.tiff;*.eps;*.pct;*.pict;*.wpg"

Private m_FSO As Object

'エントリポイント'
Public Sub InsertInlineShapeWithSettings()
  If Not InsertInlineShape(Selection.Range) Then Exit Sub
  Call ApplyInlineShapeSettingsMain
End Sub

'///インライン画像の四方を囲む'
Private Sub SetBordersAround(ByVal a_InlineShape As InlineShape, _
                    Optional ByVal a_LineStyle As MsoLineStyle _
                                              = msoLineSingle, _
                    Optional ByVal a_LineWeight As Single = 1#)
  Dim tgtLnFormat As LineFormat
  Set tgtLnFormat = a_InlineShape.Line
  With tgtLnFormat
    .Visible = msoTrue
    .Style = a_LineStyle
    .Weight = a_LineWeight
  End With
End Sub

'インライン画像を挿入する'
Private Function InsertInlineShape( _
                  ByVal a_Range As Range) As Boolean
  InsertInlineShape = False
  'ファイル名の取得。'
  Dim tgtFilePath As String
  tgtFilePath = getInlineShapeFilePath
  'ファイル名が取得出来なかったらFalse'
  If tgtFilePath = "" Then Exit Function
  Dim ilShp As InlineShape
  Set ilShp = a_Range.InlineShapes.AddPicture(tgtFilePath)
  ilShp.LockAspectRatio = msoTrue
  Call ilShp.Select
  InsertInlineShape = True
End Function

'画像を一つだけ選ばせ、ファイル名を取得する'
Private Function getInlineShapeFilePath() As String
  Dim ret As String
  ret = ""
  Dim exDir As String
  If Not HasDocumentProperty("ExDirectory") Then
    Call AddDocumentProperty(a_PropName:="ExDirectory", _
                             a_PropType:=msoPropertyTypeString, _
                             a_DefaultValue:=ThisDocument.Path)
  End If
  If m_FSO Is Nothing Then Set m_FSO = CreateObject("Scripting.FileSystemObject")
  If Not m_FSO.FolderExists(exDir) Then
    exDir = ActiveDocument.Path
  End If
  exDir = ThisDocument.CustomDocumentProperties("ExDirectory").Value
  Dim fpDialog As FileDialog
  Set fpDialog = Application.FileDialog(msoFileDialogFilePicker)
  Dim hasSelected As Boolean
  With fpDialog
    'ダイアログボックスのタイトルを設定'
    .Title = "画像を選択せよ"
    '複数選択の設定'
    .AllowMultiSelect = False
    'デフォルト表示フォルダの設定'
    .InitialFileName = exDir
    '一旦ファイルフィルタをクリア'
    Call .Filters.Clear
    'ファイルフィルタを作成'
    Call .Filters.Add(FILE_FILTER_TYPE, FILE_FILTER_EXTENTION)
    'ボックスを表示して、選択が為されたかどうかを取得'
    hasSelected = .Show
    'ファイル選択されていたら、ファイル名を取得'
    If hasSelected Then
      ret = .SelectedItems(1)
      '一つ目のファイルパスからフォルダパスを取得する'
      exDir = Left(ret, InStrRev(ret, "\")) '"
      '自作ドキュメントプロパティに、選択したファイルのあるフォルダのディレク'
      'トリを書き込む'
      ThisDocument.CustomDocumentProperties("ExDirectory").Value = exDir
    End If
    '再度ファイルフィルタをクリア'
    Call .Filters.Clear
  End With
  '値の返却'
  getInlineShapeFilePath = ret
End Function

'新しい自作ドキュメントプロパティを追加する '
Private Function AddDocumentProperty( _
             ByVal a_PropName As String, _
             ByVal a_PropType As MsoDocProperties, _
             ByVal a_DefaultValue As Variant) As Boolean
  AddDocumentProperty = True
  On Error GoTo HandleError
  'すでに存在するドキュメントプロパティ名を使用すると、Falseを返す'
  'つまり、上書きはしない。'
  Call ThisDocument.CustomDocumentProperties.Add(Name:=a_PropName, _
                                                 LinkToContent:=False, _
                                                 Type:=a_PropType, _
                                                 Value:=a_DefaultValue)
  Exit Function
HandleError:
  AddDocumentProperty = False
End Function

'/// 自作ドキュメントプロパティを削除する '
Private Function DeleteDocumentProperty( _
            ByVal a_PropName As String) As Boolean
  DeleteDocumentProperty = True
  On Error GoTo HandleError
  Call ThisDocument.CustomDocumentProperties.Item(a_PropName).Delete
  Exit Function
HandleError:
  DeleteDocumentProperty = False
End Function

'指定した名前のドキュメントプロパティがあるかどうか'
Private Function HasDocumentProperty( _
            ByVal a_PropName As String) As Boolean
  HasDocumentProperty = True
  Dim cdp As DocumentProperty
  For Each cdp In ThisDocument.CustomDocumentProperties
    If cdp.Name = a_PropName Then Exit Function
  Next
  HasDocumentProperty = False
End Function

'選択中の画像に枠線を施す'
Private Sub setBordersForFigure( _
        Optional ByVal a_LineStyle As MsoLineStyle = msoLineSingle, _
        Optional ByVal a_LineWeight As Single = 1#)
  Dim ilShp As InlineShape
  If Selection.Type = wdSelectionInlineShape Then
    If Selection.InlineShapes.Count = 0 Then Exit Sub
    Set ilShp = Selection.InlineShapes(1)
  Else
    Exit Sub
  End If
  Dim tgtLnFormat As LineFormat
  Set tgtLnFormat = ilShp.Line
  With tgtLnFormat
    .Visible = msoTrue
    .Style = a_LineStyle
    .Weight = a_LineWeight
  End With
End Sub

'ドキュメントが、指定した名前のスタイルを持っているか判定する'
Private Function HasStyle( _
            ByVal a_Document As Document, _
            ByVal a_StyleName As String) As Boolean
  HasStyle = True
  Dim st As Style
  For Each st In a_Document.Styles
    If st.NameLocal = a_StyleName Then Exit Function
  Next
  HasStyle = False
End Function

Private Sub CreateStyleForFigure1(ByVal a_Document As Document)
'///「Cst図1」スタイルを作成するためだけのメソッド ///'
  Dim st As Style
  Set st = a_Document.Styles.Add("Cst図1")
  With st
    .Visibility = True
    .UnhideWhenUsed = True
    .QuickStyle = True
    .Priority = 1
    .BaseStyle = "標準"
    .NextParagraphStyle = "図表番号"
    With .ParagraphFormat
      .Alignment = wdAlignParagraphCenter
      .LineUnitBefore = 0.5
    End With
  End With
End Sub

'選択中の画像にスタイルを当てて枠線を施し、キャプションも付ける'
Private Sub ApplyInlineShapeSettingsMain()
  Const STYLE_FOR_FIGURE_1 As String = "Cst図1"
  Dim tgtDoc As Document
  Set tgtDoc = ActiveDocument
  Dim ilShp As InlineShape
  If Selection.Type = wdSelectionInlineShape Then
    Set ilShp = Selection.InlineShapes(1)
  Else
    Exit Sub
  End If
  '`Cst図1`スタイルがなかったら作る。'
  If Not HasStyle(tgtDoc, STYLE_FOR_FIGURE_1) Then
    Call CreateStyleForFigure1(tgtDoc)
  End If
  Call applyInlineShapeSettings(STYLE_FOR_FIGURE_1, "図")
End Sub

'インライン画像に枠線・スタイル・図表番号をセットする'
Private Sub applyInlineShapeSettings( _
            ByVal a_ParagraphStyleName As String, _
            Optional ByVal a_LabelName As String, _
            Optional ByVal a_CaptionPosition As WdCaptionPosition _
                                        = wdCaptionPositionBelow, _
            Optional ByVal a_LineStyle As MsoLineStyle _
                                          = msoLineSingle, _
            Optional ByVal a_LineWeight As Single = 1#)
'### 行内の画像に段落スタイルと枠線と図表番号をセットする         ###'
'### 引数 a_ParagraphStyleName:段落スタイルの名前                ###'
'### 引数 a_LabelName:ラベルの名前                               ###'
'### 引数 a_CaptionPosition:図表番号の位置                       ###'
'### 引数 a_LineStyle:枠線の種類                                 ###'
'### 引数 a_LineWeight:枠線の太さ                                ###'

  '画像に枠線をセットする'
  Call setBordersForFigure(msoLineSingle)
  '段落スタイルを適用する'
  Selection.Style = a_ParagraphStyleName
  If a_LabelName = "" Then GoTo ComeHere
  '図表番号のラベルをセットする'
  Dim lblIndex As Long
  lblIndex = getCaptionLabelIndex(a_LabelName)
  Dim captLabels As CaptionLabels
  Set captLabels = Application.CaptionLabels
  '図表番号を挿入する'
  Call Selection.InsertCaption(Label:=captLabels(lblIndex), _
                               Position:=a_CaptionPosition)
ComeHere:
End Sub

Private Sub SetCaption(Optional ByVal a_LabelName As String = "図", _
                       Optional ByVal a_Position As WdCaptionPosition = wdCaptionPositionBelow)
  '図表番号のラベルをセットする'
  Dim lblIndex As Long
  lblIndex = getCaptionLabelIndex(a_LabelName)
  Dim captLabels As CaptionLabels
  Set captLabels = Application.CaptionLabels
  '図表番号を挿入する'
  Call Selection.InsertCaption(Label:=captLabels(lblIndex), _
                               Position:=a_Position)

End Sub

'図表番号のインデックスを取得する'
Private Function getCaptionLabelIndex( _
                 ByVal a_TgtLabelName As String) As Long
  '### 受けとったラベル名が CaptionLabelsコレクションの何番目にあ  ###'
  '### るかを返す。コレクション内になかったら、新規追加してその番  ###'
  '### を返す。                                                    ###'
  Dim ret As Long
  Dim captLabels As CaptionLabels
  Set captLabels = Application.CaptionLabels
  Dim i As Long
  For i = 1 To captLabels.Count
    If captLabels(i) = a_TgtLabelName Then
      ret = i
      GoTo ReturnValue
    End If
  Next
  Call captLabels.Add(a_TgtLabelName)
  ret = captLabels.Count
ReturnValue:
  getCaptionLabelIndex = ret
End Function

上記コードをまるごとNormal.dotmの標準モジュールに貼り付けて、InsertInlineShapeWithSettingsをクイック アクセス ツール バーに登録します。

図に当てるスタイルについては、Cst図1という名前で決め打ちにしてあります。(めんどくさいので。)

おわりに

画像を挿入して、枠線を施して、図表番号を入れて……という作業は、地味にめんどくさいので、1クリックで画像選択ダイアログが出てきて、画像を選択(ダブルクリック)したらあとは勝手に枠線、スタイル当て、図表番号挿入までやってくれるので、めんどくさい作業が最短3クリックでできるようになります。

ずいぶん前に作ったマクロなので、もしかしたら動きが変なところがあるかも知れません。テキトーに直して使ってください。

アクティブドキュメントをPDF化するマクロ(Word)

アクティブドキュメントをPDF化するマクロ(Word)

アクティブドキュメントをPDF化するマクロ

もう表題そのままのマクロです。

Normal.dotmに置いておいて、クイック アクセス ツール バーに登録しておくとメチャクチャ便利です。

仕様

  • ファイル名はそのまま。拡張子だけ.pdfにする。
  • アクティブドキュメントと同じフォルダに保存する。
  • 「見出し」スタイルをブックマークにする。

シンプルにこれだけです。

今まさに編集中のWordドキュメントと同じフォルダに保存、ということなら書き込み権限とか気にしなくても良さそうですし。

あと、「見出し」がどうたら言うのは、Adobe Readerで言うところの「しおり」になる、ということです。

地味に便利です。そもそも知らない人が多そうですが。

ソースコード

リスト1
Public Sub ConvToPDF()
  Dim tgtDoc As Document
  Set tgtDoc = ActiveDocument
  Dim flBase As String  'ファイルのベース名(拡張子を除く名前)'
  flBase = tgtDoc.Name
  flBase = Left(flBase, InStrRev(flBase, ".") - 1)
  Call tgtDoc.ExportAsFixedFormat( _
                OutputFileName:=tgtDoc.Path & "\" & flBase & ".pdf", _
                ExportFormat:=wdExportFormatPDF, _
                CreateBookmarks:=wdExportCreateHeadingBookmarks)
End Sub

たったこれだけです。

Public指定にしていますが、クイック アクセス ツール バーに登録したあとはPrivateに変えておくのをオススメします。

[Alt]+[F8]を押したときの候補に出てこなくなるので。

おわりに

WordのドキュメントをPDFに変換するのって、地味に面倒ですよね。見出しをブックマークにする作業まで含めたらなおのこと。

このマクロをNormal.dotmの標準モジュールに書いておいてクイック アクセス ツール バーに登録しておいたら、1クリックでできるので地味に便利です。

Environメソッドというものがある

Environメソッドというものがある

Wordの〝標準テンプレート〟ファイル(Normal.dotm)を、VBAでゴニョゴニョしたい、ということがあったとする。

その場合、当然ながら標準テンプレートファイルのあるディレクトリのパスを取得する必要がある。

自分一人しか使わないマクロだったら、単純にパスをジカ打ちすりゃいい。

たとえば、私の環境なら、

C:\Users\admin\AppData\Roaming\Microsoft\Templates

これでいい。

問題は、いろいろな端末で使い回すマクロの場合である。

何せ、上記のパスのうち、「admin」の部分は、ユーザによって異なるからである!

環境変数を使おう!

そういうときは、〝環境変数〟の出番ですよ!

たとえば、上記パスのうち、

C:\Users\admin\AppData\Roaming

の部分は、環境変数 %AppData% に格納されている。

だから、エクスプローラーのアドレス バーに

%AppData%\\Microsoft\Templates

と打ち込んで、

[Enter]を押してやれば、

ほれ。この通り、無事にTemplatesフォルダに移動できる。

環境変数をそのままVBAに渡してもダメ

ただし、環境変数をそのままVBAに渡しても、VBAはそれをパスとして解読してはくれない。

こうなる。

Environメソッドを使う

環境変数に格納された値を取得するには、VBA.InteractionクラスのEnvironメソッドを用いれば良いのである。(参考

このように、

C:\Users\admin\AppData\Roaming

という文字列を取得できるのである。

この通り、無事にTemplatesフォルダのパスが取得できた。

おわりに

職場で使い回すようなマクロを作るときは、〝環境変数〟というものを意識するのもいいかもしれませんね。

参考

「分かりそう」で「分からない」でも「分かった」気になれるIT用語辞典

ChatGPTにコードをレビューしてもらう

ChatGPTにコードレビューをしてもらう

自作MakeUserSickメソッドを改良(?)する

今話題のChatGPTにコードを投げると、コードレビューしてもらえる。

孤独なVBAマンには実にありがたい。

そこで、わが最高傑作(?)、MakeUserSickメソッドを少し改良(?)して、ChatGPT先生に見てもらうことにした。

……と、ここまでフツーに「ChatGPT」などと表記してきたが、実は「GPT」だったか「GPI」だったか、思い出せなくなっていたので、先に尋ねておいたのである。

MakeUserSickメソッドの改良

元のMakeUserSickメソッドはコチラ

早速、改良(?)後のコードをお目に掛けよう。

リスト1
Public Enum MsgBoxStyle
  mbsOkOnly = vbOKOnly
  mbsOkCancel = vbOKCancel
  mbsCritical = vbCritical
  mbsExclamation = vbExclamation
  mbsInformation = vbInformation
  mbsQuestion = vbQuestion
  mbsYesNo = vbYesNo
  mbsYesNoCancel = vbYesNoCancel
End Enum

'///ち~んw用'
Private Const MAKE_USER_SICK_2013 As String = _
              "       _______" & vbCrLf & _
              "   /       \" & vbCrLf & _
              "/ /・\  /・\ \" & vbCrLf & _
              "|   ̄ ̄    ̄ ̄   |   ち~んw" & vbCrLf & _
              "|    (_人_)   |" & vbCrLf & _
              "|     \  |   |" & vbCrLf & _
              "\     \_|  /"

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

'///ユーザーを煽るAAを表示する'
Public Function MakeUserSick( _
               Optional ByVal a_Message As String, _
               Optional ByVal a_Style As MsgBoxStyle, _
               Optional ByVal a_Title As String) As VbMsgBoxResult
  Dim ret As VbMsgBoxResult
  ret = vbCancel
  If a_Message = "" Then a_Message = "涙拭けよwww"
  Dim ver As String
  ver = Application.Version
  Dim tmp As String
  Select Case ver
    Case "14.0"
      tmp = MAKE_USER_SICK_2010
    Case "15.0"
      tmp = MAKE_USER_SICK_2013
    Case "16.0"
      tmp = MAKE_USER_SICK_2013
    Case Else
      tmp = MAKE_USER_SICK_2010
  End Select
  ret = MsgBox(prompt:=a_Message & vbCrLf & tmp, _
               Buttons:=a_Style, _
               Title:=a_Title)
  MakeUserSick = ret
End Function

旧ヴァージョンは、Subだったが、今度のやつはFunctionである!

ユーザーを軽く煽った上で、ユーザーの意思を確認することまでできるニクいやつになったのである!

まあ、そんなことはどうでもよろしい。

さっそくChatGPT先生にレビューしてもらおう。

ChatGPT先生にレビューをお願いする

これは実に簡単。

コードを丸ごと貼り付けて、最後に「このコードをレビューしてください。」と付け加えるだけ。

まっ たく 簡 単 だ。

ChatGPT先生のお答え

テキストでも引用しておく。

このコードは、VB.NETで書かれたMsgBox関数を使用したカスタムのメッセージボックス機能を実装しています。以下は、このコードのレビューです。


  • 列挙型(Enum)MsgBoxStyleが定義されており、MsgBoxで使用できる定数を指定しています。これにより、MsgBoxの呼び出し時に可読性が向上し、コードの意図を明確にすることができます。
  • メッセージボックスに表示するAAアートを定数として定義し、MakeUserSick関数で使用されています。これにより、ユーザーに強烈な印象を与えることができますが、実際のアプリケーションで使用する場合は注意が必要です。ユーザーに不快感を与える可能性があります。
  • メッセージ、スタイル、タイトルを引数として取り、MsgBoxを呼び出します。MsgBoxの戻り値は、MakeUserSick関数の戻り値として使用されます。
  • MakeUserSick関数の戻り値の型は、VbMsgBoxResultとして指定されています。これは、MsgBox関数の戻り値と同じ型です。
  • ユーザーが何も入力しなかった場合に備えて、デフォルトのメッセージが設定されています。
  • アプリケーションのバージョンに応じて、異なるAAアートが使用されます。アプリケーションのバージョンが14.0の場合は、2010年のAAアートが使用されます。15.0と16.0の場合は、2013年のAAアートが使用されます。これは、AAアートがバージョンによって異なる可能性があるためです。

このコードは、カスタムのメッセージボックス機能を実装するための簡潔で効果的な方法です。ただし、ユーザーに不快感を与える可能性があるAAアートを使用する場合は、注意が必要です。また、アプリケーションのバージョンに依存する処理が含まれているため、将来的にバージョンアップする場合は、注意してコードを修正する必要があります。

ところどころトンチキなことも言っているが、まあまあ正確なレビューなんではなかろうか。

特に、「ユーザーに不快感を与える」というところなんか、正直すげえなあ、と思う。

おわりに

自作のコードをいろいろ投げてみたら、おもしろいですよ。

【覚書】[Shell32.Shell].Namespaceメソッドの引数でハマった話

【覚書】Shell32.Shell.Namespaceメソッドの引数でハマった話

結論だけ手っ取り早く知りたい方はコチラ

何があったのか

事の発端:Shell32.Shellオブジェクトを使うマクロ

かつて、

akashi-keirin.hatenablog.com

こんなネタを書いていた。

レイト・バインディング風味に書き換え

この頃はアーリー・バインディング派だったので、当然のようにバリバリ(死語)に参照設定をして、Newしまくってイキっていた。

しかし、時は巡り、また夏が来て……を繰り返しているうち、すっかり考え方も変わり、今ではバリバリ(死語)のレイト・バインディング派になったのである!

そこで、参照設定を外して、レイト・バインディング風にコードを書き換えたのである。

リスト1 書き換え前
'宣言セクション'
'Microsoft Scripting Runtime参照設定'
'Microsoft Shell Controls And Automation参照設定'
Private m_FSO As New Scripting.FileSystemObject
Private m_Shell As New Shell32.Shell

Public Function SetLastModifiedDateTime( _
            ByVal a_Path As String, _
            ByVal a_DateTime As Date) As Boolean
  SetLastModifiedDateTime = False
  On Error GoTo HandleError
  'Scripting.Fileオブジェクトを取得'
  Dim tgtFile As Scripting.File
  Set tgtFile = m_FSO.GetFile(a_Path)
  'フォルダパスを取得'
  Dim tgtDir As String
  tgtDir = tgtFile.ParentFolder.Path
  'フォルダを取得'
  Dim tgtFolder As Shell32.Folder
  Set tgtFolder = m_Shell.Namespace(tgtDir)
  'ファイルを取得'
  Dim tgtItem As Shell32.FolderItem
  Set tgtItem = tgtFolder.ParseName(tgtFile.Name)
  '更新日時をセット'
  tgtItem.ModifyDate = a_DateTime
  setLastModifiedDateTime = True
  Exit Function
HandleError:
  Call Err.Clear
End Function

ブログを書いた頃に比べると、少しコーディング・スタイルが変わっているぞ。

スト2 書き換え後
'宣言セクション'
Private m_FSO As Object
Private m_Shell As Object

Public Function SetLastModifiedDateTime( _
                ByVal a_Path As String, _
                ByVal a_DateTime As Date) As Boolean
  SetLastModifiedDateTime = False
  On Error GoTo HandleError
  If m_FSO Is Nothing Then
    Set m_FSO = CreateObject("Scripting.FileSystemObject")
  End If
  If m_Shell Is Nothing Then
    Set m_Shell = CreateObject("Shell.Application")
  End If
  'Scripting.Fileオブジェクトを取得'
  Dim tgtFile As Object
  Set tgtFile = m_FSO.GetFile(a_Path)
  'フォルダパスを取得'
  Dim tgtDir As String
  tgtDir = tgtFile.ParentFolder.Path
  'フォルダを取得'
  Dim tgtFolder As Object
  Set tgtFolder = m_Shell.Namespace(tgtDir)
  'ファイルを取得'
  Dim tgtItem As Object
  Set tgtItem = tgtFolder.ParseName(tgtFile.Name)
  '更新日時をセット'
  tgtItem.ModifyDate = a_DateTime
  SetLastModifiedDateTime = True: Exit Function
HandleError:
  Call Err.Clear
End Function

悲劇:なぜかエラーが出る

これで万全! ……のはずである。

しかし、標題の通り、なぜかエラーに見舞われるのである。

この通り、

Set tgtFolder = m_Shell.Namespace(tgtDir)

で、[Shell32.Shell].NamespaceメソッドがNothingを返すために、次の

Set tgtItem = tgtFolder.ParseName(tgtFile.Name)

がエラーになってしまうのである!

これは全然意味がわからんぞ!

救いの神現る

……てなことを、Twitterでぼやいていたら、来ましたよ。

まさか、引数の型が原因だったとは。

さらに書き換え

そこで、コードを書き換える……といっても、書き換えるのは1行だけですが!

リスト3 さらに書き換え後
'宣言セクション'
Private m_FSO As Object
Private m_Shell As Object

Public Function SetLastModifiedDateTime( _
                ByVal a_Path As String, _
                ByVal a_DateTime As Date) As Boolean
  SetLastModifiedDateTime = False
  On Error GoTo HandleError
  If m_FSO Is Nothing Then
    Set m_FSO = CreateObject("Scripting.FileSystemObject")
  End If
  If m_Shell Is Nothing Then
    Set m_Shell = CreateObject("Shell.Application")
  End If
  'Scripting.Fileオブジェクトを取得'
  Dim tgtFile As Object
  Set tgtFile = m_FSO.GetFile(a_Path)
  'フォルダパスを取得'
  Dim tgtDir As String
  tgtDir = tgtFile.ParentFolder.Path
  'フォルダを取得'
  Dim tgtFolder As Object
  Set tgtFolder = m_Shell.Namespace(CVar(tgtDir)) '……(*)'
  'ファイルを取得'
  Dim tgtItem As Object
  Set tgtItem = tgtFolder.ParseName(tgtFile.Name)
  '更新日時をセット'
  tgtItem.ModifyDate = a_DateTime
  SetLastModifiedDateTime = True: Exit Function
HandleError:
  Call Err.Clear
End Function

変えたのは、(*)のところだけ。

要するに、フォルダパスの文字列をVariant型にキャストして[Shell32.Shell].Namespaceメソッドに渡しただけ。

これでエラーが出なくなった。

おわりに

レイト・バインディング方式で、[Shell32.Shell].Namespaceメソッドを使うときには、引数をVariant型で渡しましょう!

ちなみに、コチラのページでも、

Shell.NameSpace( _
  ByVal vDir As Variant _
) As Folder

と書いてある(「vDir」)ので、引数はVariant型、ということなのでしょう。

久々に小ハマリした報告でした。

Rangeオブジェクトの場所を目立たせるマクロ(Word)

Rangeオブジェクトの場所を目立たせるマクロ(Word)

WordのRangeオブジェクトの場所はわかりにくい

WordのVBAでマクロを作っているとき、地味に困るのが、

Rangeオブジェクトがどこを指し示しているのかわからん問題

である!

Steven Romanさん、ありがとう!

Writing Word Macros』(Steven Roman・1999年・O'REILLY)という書籍がある。

その中で、実に面白いマクロが紹介されていたので、お目にかけよう!

Rangeオブジェクトの箇所を目立たせるマクロ

上掲書に載っていたコードを、一部改変。

リスト1
Public Sub BlinkRange(ByVal a_Range As Range, _
                      ByVal a_Time As Single, _
                      ByVal a_Blink As Boolean)
  Dim startTime As Variant
  Dim tickTime As Variant
  'Safety net'
  If a_Range Is Nothing Then Exit Sub
  If a_Time < 0.1 Or a_Time > 60 Then
    a_Time = 2
  End If
  'Emboss range'
  a_Range.Font.Emboss = True
  'Wait a_Time seconds, blinking  '
  'every 0.25 seconds if requested'
  startTime = Timer()
  tickTime = startTime
  Do
    DoEvents
    If a_Blink Then
      If Timer() - tickTime > 0.25 Then '……(*)'
        With a_Range.Font
          .Emboss = Not .Emboss
          tickTime = Timer()
        End With
      End If
    End If
  Loop Until Timer() - startTime >= a_Time
  'Kill emboss'
  a_Range.Font.Emboss = False
End Sub

見ての通り、RangeオブジェクトのFontプロパティから当該箇所のFontオブジェクトを取得し、そのEmbossプロパティをTrueにすることによって、第2引数a_Timeで指定した時間、当該箇所を目立たせる、というもの。

ちなみに、第3引数のa_BlinkTrueにしてあると、(*)からの6行、

If Timer() - tickTime > 0.25 Then '……(*)'
  With a_Range.Font
    .Emboss = Not .Emboss
    tickTime = Timer()
  End With
End If

が発動することにより、あたかも当該箇所が点滅しているかのごとく、派手な演出となる。

動かしてみる

このような文書を用意する。カーソルは、「開催・運営」という段落の先頭にある。

この状態で、次のリスト2を実行する。

スト2
Private Sub test02()
  Dim tgtRng As Range
  Set tgtRng = Selection.Range.Next(wdParagraph, 1)
  Call BlinkRange(tgtRng, 3, True)
End Sub

(プロシージャ名「test02」の「02」に深い意味はありません。)

[Range].Nextメソッドで、カーソル位置のある場所(Selection.Range)の次の段落の部分をRangeオブジェクトとして取得し、そのRangeオブジェクトをBlinkRangeメソッドに渡す。

第2引数が「3」なので3秒間、第3引数が「True」なので当該箇所を点滅させることになる。

すると、

こうなる。

Selectメソッドを使ったわけではないので、カーソル位置は当然

元のまま。

おわりに

マクロ作成中の動作確認時とか、デバッグ時に、Debug.Printのように使えば、はかどるのではないでしょうか。