【覚書】[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のように使えば、はかどるのではないでしょうか。

隠し文字を検索してカーソルを移動する(Word)

隠し文字を検索してカーソルを移動する(Word)

隠し文字は表示しないと検索に引っかからない

隠し文字は、編集画面上で非表示になっていると、Findオブジェクトを用いた検索に引っかからない。(もちろん、ふつうに検索ダイアログボックスを用いて検索しても引っかからない。)

だから、隠し文字のところを目印に、カーソルを移動させるには、ひと工夫が要る。

  • 一旦、非表示の隠し文字を表示する。
  • 検索する。
  • 選択状態のカーソルを潰す。
  • 隠し文字を非表示に戻す。

とまあ、こんな具合。

隠し文字を検索してRangeを返すFunction

まず、任意の隠し文字を検索して、ヒットしたらその箇所のRangeを返し、ヒットしなかったらNothingを返すFunctionを作る。

リスト1
Private Function getNextHiddenTextRange( _
                 ByVal a_Text As String) As Range
  Dim ret As Range
  With Selection.Find
    Call .ClearFormatting
    Call .Replacement.ClearFormatting
  End With
  With Selection.Find
    .Format = True    '……(*)'
    .Font.Hidden = True    '……(**)'
    .Text = a_Text
    .Replacement.Text = ""
    .Wrap = wdFindStop
    .MatchFuzzy = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchByte = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = False
  End With
  Call Selection.Find.Execute
  If Not Selection.Find.Found Then GoTo ReturnObject
  Set ret = Selection.Range
ReturnObject:
  With Selection.Find
    .Format = False
    .Font.Hidden = False
    Call .ClearFormatting
    Call .Replacement.ClearFormatting
  End With
  Set getNextHiddenTextRange = ret
End Function

例によって異様にタテ長になってしまうのは、Findオブジェクトの宿命。

ポイントは、(*)(**)のところ。

Find.FormatプロパティをTrueにすることで、書式情報をも検索対象に入れることができる。

そうしておいた上で、Find.HiddenプロパティをTrueにする。

このようにすることで、隠し文字になっている文字列のみ、検索対象とすることができる。

これで、検索でヒットしたらその箇所のRangeが返るし、ヒットしなければNothinが返ることになる。

ただし、気をつけねばならんことが一つ。

ヒットした場合は、当該の箇所が選択された状態になっている、ということである。

任意の隠し文字のある箇所にカーソルを置くFunction

たとえば、隠し文字を表示した状態で、次のようになっている文書があるとする。

隠し文字を非表示にすると、

こうなる。

この状態で、「競輪用自転車」という見出しの先頭にカーソルを移動させたいのである。

スト2
Public Function SetCursorEndOfHiddenText( _
                ByVal a_HiddenText As String) As Boolean
  SetCursorEndOfHiddenText = False
  Dim tgtRng As Range
  Dim isHidden As Boolean '最初の表示・非表示を記録するフラグ'
  With Application.ActiveWindow.View
    If .ShowAll Then GoTo ExitHere1
    If Not .ShowHiddenText Then
      '隠し文字非表示の場合、一旦表示にして元の状態を覚えておく'
      .ShowHiddenText = True
      isHidden = True
    End If
  End With
ExitHere1:
  Set tgtRng = getNextHiddenTextRange(a_HiddenText)
  If tgtRng Is Nothing Then GoTo ExitHere2
  Call tgtRng.Select
  Call Selection.Collapse(wdCollapseEnd)    '……(*)'
  SetCursorEndOfHiddenText = True
ExitHere2:
  With Application.ActiveWindow.View
    If Not .ShowAll Then
      'もともと非表示だった場合は非表示に戻す'
      If isHidden Then .ShowHiddenText = False
    End If
  End With
End Function

隠し文字の表示設定を実行前の状態に戻す、という仕様にしたので、その分だけコードが長くなっているが、メインの処理は至って簡単。

隠し文字が非表示だったら表示させた上で、先のリスト1getNextHiddenTextRangeメソッドを用いて対象の隠し文字を検索し、ヒットしたら選択範囲を後方に潰して((*)のところ。)、隠し文字の表示設定を元に戻しているだけ。

選択範囲を後方に向けて潰すのは、このFunctionを繰り返して使うときのため。

同じ隠し文字を繰り返し検索するようなとき、選択範囲を前方に潰してしまったらどういうことが起こるか、容易に想像がつくであろう!

使ってみる

次のコードで実験。

リスト3
Private Sub test03()
  Call SetCursorEndOfHiddenText("@2")
End Sub

これだけ。

バッチリ。

おわりに

見出しのところにうまい具合に隠し文字を設定すれば、任意の見出しの配下を簡単に取得することができるようになりますよ。

参考

 

akashi-keirin.hatenablog.com

akashi-keirin.hatenablog.com

隠し文字の表示/非表示の切り替え(Word)

隠し文字の表示/非表示の切り替え(Word)

隠し文字の表示/非表示を切り替える

超絶小ネタ。

文字通り、隠し文字の表示/非表示を手軽に切り替えるためのマクロ。

けっこうめんどくさいですからね。(ですよね? 知らんけど。)

では、さっそくコードをお目にかけよう!

リスト1
Public Sub ToggleShowHiddenText()
  With Application.ActiveWindow.View
    .ShowHiddenText = Not .ShowHiddenText
  End With
End Sub

たったこんだけ。

ViewオブジェクトのShowHiddenTextプロパティのオン/オフを切り替えているだけ。

使ってみる

では、動いているところをお目にかけよう。

なんてお手軽!

ショートカットキーでもあてがっておけば、超絶お手軽になるぜ!

おわりに

つくづく、Wordのマクロというやつは、こういう小ネタがお似合いだぜ……。

見出しの配下にある内容を取得する(Word)

見出しの配下にある内容を取得する(Word)

見出しの配下を取得したい

「見出し」というものは、普通、文書の〝意味のあるカタマリ〟ごとに付けるものだと思う。

「見出し」単位で、文書の内容を取り出せたら便利である。

ただ、〝手作業でコピッペする〟というのも、あまりスマートなやり方ではない。

定義済みブックマークを使う

そこで、「定義済みブックマーク」を使うのである!

コチラのページによると、「定義済みのブックマーク」には、「\HeadingLevel」というものがある。

挿入ポイントまたは選択範囲、および下位の見出しとテキストを含む見出し。 現在の選択範囲が本文テキストの場合、"\HeadingLevel" ブックマークには、前の見出しと、その見出しの下位にある見出しとテキストが含まれます。

自動翻訳なので、ちょいけったいな日本語になっている。

「挿入ポイント」とは、たぶん〝カーソル位置〟のことなのだろう。「挿入ポイントまたは選択範囲」というのは、要するにVBASelectionオブジェクトのことだと思う。(間違っていたら教えてください。)

つまり、たとえば、Selection.Bookmarks.Item("\HeadingLevel").Rangeとしてやれば、カーソル位置直前の見出し(見出しの中にカーソルがある場合は、その見出し)と、その配下にある見出し・本文をまるごと指し示すRangeオブジェクトが取得できるのである!

カーソルのある見出しの配下にある内容をクリップボードにコピーするマクロ

では、標題のマクロを作成してみよう。

リスト1
Private Sub copyHeadingLevel()
  Dim tgtRng As Range
  Set tgtRng = Selection.Bookmarks.Item("\HeadingLevel").Range
  Call tgtRng.Copy
End Sub

たったこれだけである!

使ってみる

まず、こんな文書を用意する。

「ナビゲーション」を見たらわかるように、見出しは2階層である。

「ナビゲーション」で見出しをクリックすると、カーソルはその見出しの先頭にジャンプする。

そこで、まず「開催・運営」という見出しをクリックする。

当然、「開催・運営」という見出しの先頭にカーソルが移動する。

この状態でリスト1を実行する。

見かけ上何も起きないが、この状態で、新しい文書にカーソルを置いて、

[Ctrl]+[ V ]をポチッ!

このように、見出し単位で貼り付けることができるのである!

ちなみに、

この状態(見出し「競輪用自転車」の配下には、さらに下位の見出し「部品全般」、「フレーム」、「ギア(ギヤ)」が設定されている。)で先ほどと同じことをすると、



こんなふうになる。

おわりに

Wordの「ブックマーク」機能は便利です。

もっと使いこなさないと!

サブフォルダも含め配下のフォルダパス全てを返すFunction

サブフォルダも含め配下のフォルダパス全てを返すFunction

作ってみた

いや、FileSystemObject使えよ、って話なんですけどね。

Dir関数使って作ったらどうなんのかな、と思って。

ソースコードを晒す

場当たり的に作ったやつなので、だいぶ恥ずかしいのですが、晒します。

リスト1
Public Function GetFolderPathAll( _
            ByVal a_FolderPath As String) As String
'配下の全てのフォルダのパスを、「&gt」で区切った文字列にして返す。 '
  Dim ret As String
  ret = ""
  '対象のフォルダがなかったらReturn'
  If Dir(a_FolderPath, vbDirectory) = "" Then GoTo ReturnValues
  Dim tmp As String
  tmp = Dir(a_FolderPath & "\*", vbDirectory)
  Do
    'Dirが文字列を返さなかったらループを抜ける。'
    If tmp = "" Then Exit Do
    'Dirの返り値が「.」、「..」だったらContinue'
    If tmp = "." Then GoTo Continue
    If tmp = ".." Then GoTo Continue
    tmp = a_FolderPath & "\" & tmp                  '"
    'フォルダパスじゃなかったらContinue'
    If GetAttr(tmp) <> vbDirectory Then GoTo Continue
    'ここまでたどり着いたらフォルダパスのはず。'
    'あとでSplitするときのために、区切り文字をファイルパスに'
    '使えない文字にする'
    ret = ret & tmp & ">"
Continue:
    tmp = Dir()
  Loop
  Dim arr() As String
  arr = Split(ret, ">")
  Dim i As Long
  'この段階では右端に「>」があるので、配列の最後の要素は空。'
  For i = LBound(arr) To UBound(arr) - 1
    'GetFolderPathAllメソッドに投げるときには右端が「>」で'
    'でないといけない。'
    If Right(ret, 1) <> ">" Then
    '一番底のフォルダまで行ったときは、右端に「>」が付いてい'
    'ない文字列が「arr()」に入っている。'
      ret = ret & ">"
    End If
    'サブフォルダを調べる。(再帰呼び出し)'
    ret = ret & GetFolderPathAll(arr(i))
  Next
ReturnValues:
  If ret <> "" Then
    If Right(ret, 1) = ">" Then
    '最後は右端の「>」をトル。'
      ret = Left(ret, Len(ret) - 1)
    End If
  End If
  GetFolderPathAll = ret
End Function

ルートのフォルダのフルパスを渡して実行すると、配下のフォルダ全てのフルパスを「>」で区切って一列棒状にした長~い文字列を返す、というもの。

地味に再帰を使っています。

使ってみる

とりあえずフォルダの準備

こんなフォルダ構成を、マクロを書いたDocumentのあるフォルダに作りました。

WordでVBAを書いているところにはツッコミなしで!

こんなコードで実行

次のコードを実行します。

スト2
Private Sub test03()
  Dim tgtDir As String
  tgtDir = ThisDocument.Path
  Dim arr() As String
  arr = Split(GetFolderPathAll(tgtDir), ">")
  Dim i As Long
  For i = LBound(arr) To UBound(arr)
    Debug.Print arr(i)
  Next
End Sub

GetFolderPathAllメソッドの返り値は、配下の各フォルダパスが「>」によって数珠つなぎにされた長~い文字列なので、Splitで区切って配列化し、それを一つづつ取り出してイミディエイトに書き出します。

実行結果

ほれ、この通り。

バッチリ!

おわりに

長らくDir関数なんて使いませんでしたが、良い復習になりました。

今回作成したFunction、作った自分でも理解が追いついていないところがあるので、誰か解説よろしくお願いします。

組み込み定数(列挙体)を自作(?)しておく

組み込み定数(列挙体)を自作(?)しておく

CreateObject派への転向

実は、だいぶ前からCreateObject派に転向しておりました。

やっぱり、参照設定せずに使えるってのはいいよね、ということで。

CreateObject派になって困ること

いろいろあると思いますが、やはり

組み込み定数(列挙体)が使えねえ!

これに尽きるのではないでしょうか。(異論は認めます。)

なかったら、作ればいいじゃない

そこで、私は、よく使う組み込み定数(列挙体)を自作し(というか、パクッ)ています。

これまでにパクッ完コピした組み込み定数(列挙体)

代表的なものをいくつか紹介します。

基本的に、クラスモジュールとかの中に封印してしまうことが多いのでPrivate指定ですが、Publicメソッドなんかの引数にするときには、適宜Public指定に変えてやればいいと思います。

ADODB関係

ADODB.Streamオブジェクトを扱うときによく使うやつです。

StreamTypeEnum列挙体
Private Enum StreamTypeEnum
  adTypeBinary = 1
  adTypeText = 2
End Enum
SaveOptionsEnum列挙体
Private Enum SaveOptionsEnum
  adSaveCreateNotExist = 1  'ファイルがあるとき上書きしない'
  adSaveCreateOverWrite = 2 'ファイルがあるとき上書きする'
End Enum
StreamReadEnum列挙体
Private Enum StreamReadEnum
  adReadAll = -1
  adReadLine = -2
End Enum
StreamWriteEnum列挙体
Private Enum StreamWriteEnum
  adWriteChar = 0
  adWriteLine = 1
End Enum

Scripting.FileSystemObject関係

IOMode列挙体
Private Enum IOMode
  ForReading = 1
  ForWriting = 2
  ForAppending = 8
End Enum
Tristate列挙体
Private Enum Tristate
  TristateFalse = 0
  TristateTrue = -1
  TristateUseDefault = 2
End Enum

おわりに

こんなふうに、代表的な組み込み定数(列挙体)を自作(?)しておけば、たとえばScripting.FileSystemObjectオブジェクトを利用するコードを書いたときに、参照設定していなくても、たとえば次のように読んで意味がわかるように書くことができます。

Set m_TextStream = m_FSO.OpenTextFile(FileName:=a_Path, _
                                      IOMode:=ForReading, _
                                      Create:=True, _
                                      Format:=a_CharCode)

OpenTextFileメソッドの引数「IOMode」のところ、IOMode:=1とか書かれていても、何のことかわからんでしょう?

完コピ自体は、オブジェクト ブラウザー様を見たら誰でもできるので、CreateObject派の人は、Enum集を作っておけばいいのではないでしょうか。