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
フォルダのパスが取得できた。
おわりに
職場で使い回すようなマクロを作るときは、〝環境変数〟というものを意識するのもいいかもしれませんね。
参考
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オブジェクトを使うマクロ
かつて、
こんなネタを書いていた。
レイト・バインディング風味に書き換え
この頃はアーリー・バインディング派だったので、当然のようにバリバリ(死語)に参照設定をして、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_Blink
をTrue
にしてあると、(*)
からの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
隠し文字の表示設定を実行前の状態に戻す、という仕様にしたので、その分だけコードが長くなっているが、メインの処理は至って簡単。
隠し文字が非表示だったら表示させた上で、先のリスト1、getNextHiddenTextRange
メソッドを用いて対象の隠し文字を検索し、ヒットしたら選択範囲を後方に潰して((*)
のところ。)、隠し文字の表示設定を元に戻しているだけ。
選択範囲を後方に向けて潰すのは、このFunctionを繰り返して使うときのため。
同じ隠し文字を繰り返し検索するようなとき、選択範囲を前方に潰してしまったらどういうことが起こるか、容易に想像がつくであろう!
使ってみる
次のコードで実験。
リスト3
Private Sub test03() Call SetCursorEndOfHiddenText("@2") End Sub
これだけ。
バッチリ。
おわりに
見出しのところにうまい具合に隠し文字を設定すれば、任意の見出しの配下を簡単に取得することができるようになりますよ。
参考
隠し文字の表示/非表示の切り替え(Word)
隠し文字の表示/非表示の切り替え(Word)
隠し文字の表示/非表示を切り替える
超絶小ネタ。
文字通り、隠し文字の表示/非表示を手軽に切り替えるためのマクロ。
けっこうめんどくさいですからね。(ですよね? 知らんけど。)
では、さっそくコードをお目にかけよう!
リスト1
Public Sub ToggleShowHiddenText() With Application.ActiveWindow.View .ShowHiddenText = Not .ShowHiddenText End With End Sub
たったこんだけ。
View
オブジェクトのShowHiddenText
プロパティのオン/オフを切り替えているだけ。
使ってみる
では、動いているところをお目にかけよう。
なんてお手軽!
ショートカットキーでもあてがっておけば、超絶お手軽になるぜ!
おわりに
つくづく、Wordのマクロというやつは、こういう小ネタがお似合いだぜ……。
見出しの配下にある内容を取得する(Word)
見出しの配下にある内容を取得する(Word)
見出しの配下を取得したい
「見出し」というものは、普通、文書の〝意味のあるカタマリ〟ごとに付けるものだと思う。
「見出し」単位で、文書の内容を取り出せたら便利である。
ただ、〝手作業でコピッペする〟というのも、あまりスマートなやり方ではない。
定義済みブックマークを使う
そこで、「定義済みブックマーク」を使うのである!
コチラのページによると、「定義済みのブックマーク」には、「\HeadingLevel
」というものがある。
挿入ポイントまたは選択範囲、および下位の見出しとテキストを含む見出し。 現在の選択範囲が本文テキストの場合、"\HeadingLevel" ブックマークには、前の見出しと、その見出しの下位にある見出しとテキストが含まれます。
自動翻訳なので、ちょいけったいな日本語になっている。
「挿入ポイント」とは、たぶん〝カーソル位置〟のことなのだろう。「挿入ポイントまたは選択範囲」というのは、要するにVBAのSelection
オブジェクトのことだと思う。(間違っていたら教えろてください。)
つまり、たとえば、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の「ブックマーク」機能は便利です。
もっと使いこなさないと!