HTMLのtable要素を作るFunction

HTMLのtable要素を作る

HTMLで表を作るのはメンドクサイ

Excelでちゃちゃっと表を作って、それをHTMLタグで囲って構造化するマクロを作った。

リスト１　標準モジュール

Public Function createHTMLTable( _
                  ByVal targetRange As Range, _
                  Optional ByVal hasHeader As Boolean = True, _
                  Optional ByVal hasBorder As Boolean) As String    '……(1)'
  Dim rowCount As Long    '……(2)'
  rowCount = targetRange.Rows.Count
  Dim columnCount As Long
  columnCount = targetRange.Columns.Count
  Dim i As Long
  Dim j As Long
  Dim stringOfCell() As String    '……(3)'
  ReDim stringOfCell(0 To rowCount - 1, 0 To columnCount - 1)
  For i = 0 To rowCount - 1
    For j = 0 To columnCount - 1
      stringOfCell(i, j) = targetRange.Cells(i + 1, j + 1).Value
    Next
  Next
  Dim str As String
  If hasBorder Then    '……(4)'
    str = "<table border=""1"">"
  Else
    str = "<table border="""">"
  End If
  For i = 1 To rowCount    '……(5)'
    str = str & "<tr>"    '……(6)'
    For j = 1 To columnCount    '……(7)'
      If hasHeader And i = 1 Then    '……(8)'
        str = str & "<th>" & stringOfCell(i - 1, j - 1) & "</th>"
      Else
        str = str & "<td>" & stringOfCell(i - 1, j - 1) & "</td>"
      End If
    Next
    str = str & "</tr>"    '……(9)'
  Next
  str = str & "</table>"    '……(10)'
  str = Replace(str, vbLf, "<br>")    '……(11)'
  createHTMLTable = str
End Function

(1)の

Public Function createHTMLTable( _
                  ByVal targetRange As Range, _
                  Optional ByVal hasHeader As Boolean = True, _
                  Optional ByVal hasBorder As Boolean) As String

では、引数３つと返り値の型を設定。

第１引数では、対象のセル範囲を指定。

第２引数は、表が項目ラベルを持っているかどうか。持っているならTrue。

第３引数は、境界線をどうするか。Trueだったらborder属性に"1"をセットする。Falseなら""。

で、返り値はString型。

(2)からの４行

Dim rowCount As Long
rowCount = targetRange.Rows.Count
Dim columnCount As Long
columnCount = targetRange.Columns.Count

では、表の行数・列数を変数にぶち込んでおく。

(3)からの７行

Dim stringOfCell() As String
ReDim stringOfCell(0 To rowCount - 1, 0 To columnCount - 1)
For i = 0 To rowCount - 1
  For j = 0 To columnCount - 1
    stringOfCell(i, j) = targetRange.Cells(i + 1, j + 1).Value
  Next
Next

では、String型の２次元配列stringOfCell()に表の各セルの値をぶち込んでいる。

もっと簡単にできたと思うけれど、調べるのがめんどくさいんで（←コラ！）、とりあえずこういう原始的なやり方で。

(4)からの５行

If hasBorder Then
  str = "<table border=""1"">"
Else
  str = "<table border="""">"
End If

では、引数hasBorderの値に応じて、tableの開始タグを書き分けている。

で、(5)からの11行

For i = 1 To rowCount
  str = str & "<tr>"    '……(6)'
  For j = 1 To columnCount    '……(7)'
    If hasHeader And i = 1 Then    '……(8)'
      str = str & "<th>" & stringOfCell(i - 1, j - 1) & "</th>"
    Else
      str = str & "<td>" & stringOfCell(i - 1, j - 1) & "</td>"
    End If
  Next
  str = str & "</tr>"    '……(9)'
Next

二重のForループで一気にtableタグの中身を作っていく。

まず、外側のForループでは、表の各行を作っていくので、ループの最初に(6)の

str = str & "<tr>"

で<tr>タグを付け足し、次のループに移る直前に(9)の

str = str & "</tr>"

で</tr>タグを付け足すようにしている。

また、内側のForループ、すなわち(7)からの７行

For j = 1 To columnCount
  If hasHeader And i = 1 Then    '……(8)'
    str = str & "<th>" & stringOfCell(i - 1, j - 1) & "</th>"
  Else
    str = str & "<td>" & stringOfCell(i - 1, j - 1) & "</td>"
  End If
Next

では、引数hasHeaderの状態に応じて分岐。(8)の

If hasHeader And i = 1 Then

でhasHeaderがTrueで、かつ i = 1 のとき、つまり表の１行目が各列のラベルである場合は、セルの値を<th></th>で囲まないといけないので、このような条件分岐にしている。

hasHeader And i = 1

がTrueのときは、

str = str & "<th>" & stringOfCell(i - 1, j - 1) & "</th>"

によって、セルの値を<th></th>でくくった文字列をstrに追加し、

hasHeader And i = 1

がFalseのときは、

str = str & "<td>" & stringOfCell(i - 1, j - 1) & "</td>"

によって、セルの値を<td></td>でくくる、という仕掛け。

二重のForループから抜けると、表の中身は全てタグ打ちができているはずなので、(10)の

str = str & "</table>"

でtableタグを閉じる。

ついでに、(11)の

str = Replace(str, vbLf, "<br>")

では、Replace関数を用いて、セル内改行（vbLf）を<br>に置き換えておく。

使ってみる

シート（Sheet2です）にこんなふうに表を用意して、次のコードで実験してみる。

リスト２　標準モジュール

Public Sub testHTMLTable()
  Dim Sh As Worksheet
  Set Sh = ThisWorkbook.Worksheets("Sheet2")
  Debug.Print createHTMLTable(Sh.Range("A1").CurrentRegion, True, True)
End Sub

イミディエイトに、タグ打ちした文字列が表示されるので、それをHTMLソースにコピペしてブラウザで開いてみた。

セル内改行した表でも実験してみたが、

こんなふうに、うまく表示された。

おわりに

Excelでちょこちょこっと表を作って、table要素にできたらいいなーと思っただけです。

「ちょｗｗｗ　もっと簡単にできるじゃねーかよｗｗｗ」とか、笑われるかもしれませんが、HTMLなんてつい最近までろくに知らなかったし、Webページを触るようなこともしたことがなかったので、ホームページビルダー（っていうの？）なんかも触ったことのない素人の思いつきですから、笑って許してくだされ。

しっかし、これ、セルの結合とかに対応しようとしたら、途端に激ムズになるんじゃね？？？

@akashi_keirin on Twitter

Application.Intersectメソッドを使う

セルが指定した範囲内にあるかどうかを判定するFunction

Application.Intersectメソッドを使う

何気なく日経ソフトウエアの１月号を読んでいたら、武藤玄氏の連載記事「実務ですぐに役立つExcel VBA」の中に、次のような記述があった。

Intersectメソッドは、第1引数のセル範囲が、第2引数のセル範囲に含まれるとき、共有するセル範囲を返します。また、含まれないときは「Nothing」を返します。

ほおぉ～！　知らなかった。当該記事では、このIntersectメソッドを用いて、選択したセルが表の内側にあるか、外側にあるのかの判定に使っていた。

今まで、同じことをWorksheet_SelectionChangeの中で、引数Target(As Range)のRowプロパティやColumnプロパティで条件分岐してやっていたけれど、Intersectメソッドの挙動を利用すれば、もっとスマートにできるということだ。

Function化

ひとまず、簡単に、第１引数で指定したセルが、第２引数で指定した範囲内にあればTrue、なければFalseを返すFunctionにしてみた。

リスト１　標準モジュール

'宣言セクション'
Public Const ERROR_MESSAGE_10007 As String = _
  "isWithinTheRangeメソッドの引数targetCellは、単一のセルとしてください。"
'宣言セクションここまで'

Public Function isWithinTheRange(ByVal targetCell As Range, _
                                 ByVal serchFor As Range) As Boolean    '……(1)'
  With targetCell    '……(2)'
    If .Rows.Count > 1 Or _
       .Columns.Count > 1 Then _
        Err.Raise Number:=10007, _
                  Description:=ERROR_MESSAGE_10007
  End With
  Dim tmpRange As Range
  Set tmpRange = Application.Intersect(targetCell, serchFor)    '……(3)'
  If tmpRange Is Nothing Then    '……(4)'
    'tmpRangeがNothingだったら、範囲内にない。'
    isWithinTheRange = False
  Else
    'tmpRangeにセルが格納されていたら、範囲内にある。'
    isWithinTheRange = True
  End If
  Set tmpRange = Nothing
End Function

まず、(1)の

Public Function isWithinTheRange(ByVal targetCell As Range, _
                                 ByVal serchFor As Range) As Boolean

で引数と返り値の設定。

第１引数には範囲内にあるかどうかを調べたいセル、第２引数には調べる対象のセル範囲を指定する。んで、範囲内にあったらTrue、範囲外だったらFalseを返す。

(2)からの６行（実質３行）

With targetCell    '……(2)'
  If .Rows.Count > 1 Or _
     .Columns.Count > 1 Then _
      Err.Raise Number:=10007, _
                Description:=ERROR_MESSAGE_10007
End With

では、第１引数をチェックし、複数セルになっていたらエラーを吐く。

ここからがメインの処理。

(3)の

Set tmpRange = Application.Intersect(targetCell, serchFor)

でIntersectメソッドを使う。変数tmpRangeには、targetCellがserchForの範囲内にあればtargetCellが格納され、範囲外だったらNothingが格納されることになる。

あとは、(4)からの５行（コメント行除く）

If tmpRange Is Nothing Then    '……(4)'
  'tmpRangeがNothingだったら、範囲内にない。'
  isWithinTheRange = False
Else
  'tmpRangeにセルが格納されていたら、範囲内にある。'
  isWithinTheRange = True
End If

で、tmpRangeの中身に応じて返り値を設定する。

使用例

こんなシートを準備して、そのシートモジュールに次のコードを書いてみる。

リスト２　シートモジュール

下記は修正前のものです。修正後のコードはコチラをどうぞ！

'宣言セクション'
Private Const START_ROW As Long = 1    '……(1)'
Private Const START_COLUMN As Long = 1
'宣言セクションここまで'

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Dim Sh As Worksheet
  Set Sh = Target.Parent
  Dim lastRow As Long    '……(2)'
  lastRow = Sh.Cells(Rows.Count, START_COLUMN).End(xlUp).Row
  Dim lastColumn As Long
  lastColumn = Sh.Cells(START_ROW, Columns.Count).End(xlToLeft).Column
  Dim tableRange As Range    '……(3)'
  With Sh
    Set tableRange = .Range(.Cells(START_ROW, START_COLUMN), _
                            .Cells(lastRow, lastColumn))
  End With
  If Not isWithinTheRange(Target, tableRange) Then _
    Call makeUserSick("表の範囲外を選ぶなボケ！")    '……(4)'
End Sub

(1)からの２行

Private Const START_ROW As Long = 1
Private Const START_COLUMN As Long = 1

は、表の開始位置（Ａ１セル、すなわち１行１列目）を定数にしている。表の開始位置が変わったら、定数の定義だけを変更すればよい。

(2)からの４行

Dim lastRow As Long
lastRow = Sh.Cells(Rows.Count, START_COLUMN).End(xlUp).Row
Dim lastColumn As Long
lastColumn = Sh.Cells(START_ROW, Columns.Count).End(xlToLeft).Column

では、表の終端の行・列番号を、おなじみのEndプロパティを使うやり方で求めている。

(3)からの５行（実質４行）

Dim tableRange As Range
With Sh
  Set tableRange = .Range(.Cells(START_ROW, START_COLUMN), _
                          .Cells(lastRow, lastColumn))
End With

では、表全体を一つのRangeオブジェクトとして変数tableRangeにぶち込んだ。別にここまでする必要はないのだけれど……。

あとは、(4)の

If Not isWithinTheRange(Target, tableRange) Then _
    Call makeUserSick("表の範囲外を選ぶなボケ！")

で先ほどのリスト１のisWithinTheRangeメソッドを用いて条件判定し、選んだセル（Target）が表の範囲（tableRange）外にあったら、当ブログではおなじみのmakeUserSickメソッドを呼び出してちょっとむかつくメッセージを表示する、という仕掛けにした。

実行結果

表の範囲外を選択すると、

煽られるｗｗｗ

おわりに

まあ、この程度の使い方なら、「わざわざIntersectメソッドをラップせんでも、そのまま使やいーじゃん」でしょうなあ。

追記

リスト２のコードだと、複数セルを選んだだけでエラーを吐いてしまうので、ちょっと修正する。

リスト２改　シートモジュール

'宣言セクション'
Private Const START_ROW As Long = 1
Private Const START_COLUMN As Long = 1
'宣言セクションここまで'
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Dim Sh As Worksheet
  Set Sh = Target.Parent
  Dim lastRow As Long
  lastRow = Sh.Cells(Rows.Count, START_COLUMN).End(xlUp).Row
  Dim lastColumn As Long
  lastColumn = Sh.Cells(START_ROW, Columns.Count).End(xlToLeft).Column
  Dim tableRange As Range
  With Sh
    Set tableRange = .Range(.Cells(START_ROW, START_COLUMN), _
                            .Cells(lastRow, lastColumn))
  End With
  Dim targetCell As Range
  For Each targetCell In Target
    If Not isWithinTheRange(targetCell, tableRange) Then _
      Call makeUserSick("表の範囲外を選ぶなボケ！"): Exit For
  Next
End Sub

これで大丈夫だと思います。

参考

私は、以下のコードをXlCommonと名付けた標準モジュールに入れておいて、インポートしていろんなマクロで使い回していますｗ

makeUserSickメソッド　標準モジュール

'宣言セクション'
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 & _
              "＼　　　　 　＼＿|　      ／"
'宣言セクションここまで'

Public Sub makeUserSick(Optional ByVal msg As String)
  Dim ver As String
  ver = Application.Version
  Dim str As String
  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
  If msg = "" Then msg = "涙拭けよｗｗｗ"
  MsgBox msg & vbCrLf & str
End Sub

WshScriptのSendKeysメソッドを使う

ち～んｗ珍現象は続く

WshScriptのSendKeysメソッド

前回の

akashi-keirin.hatenablog.com

コチラの記事にid:imihito さんからコメントをいただいた。

そこでご紹介いただいたのは、コチラの方法。このうち、「WshShellのSendKeysをラップする」というやつを使わせていただくことにした。

要するに、バグがあることが分かっている方法を使うのを避けて、同じような機能を持つバグのないメソッドを使おうということ。極めて健全な対処法だと思う。

面白いなと思ったのが、

毎回CreateObjectすると負荷が大きくなるので、Static宣言+存在判定をしています。

という考え方。なるほど。Static変数をそういうふうに使うのか！　VBAのStatic変数って、プロシージャ内でしか使えなくて、イマイチ使いどころが分からなかったんだよな。クラス変数みたいに使えたらいいのに。

ただ、ちょっと気になる記述が。

代わりにオブジェクトを破棄する方法が無くなるので、wshShellオブジェクトがメモリに残り続けます。

むむむ。イマイチVBAのガベージコレクションの動作がよく分からないし、素人の悲しさ、メモリ関係もよく分かっとらんので、あまり気にしたこともないのだが、こうはっきり書いてあると、「メモリに残り続けるってのもマズいのかなあ」とかビビってしまう。

まあ、オブジェクトの破棄については、素人の浅知恵を後ほど披露するとして、ちょっとやってみた。

WshScriptのSendKeysメソッド呼び出し用プロシージャ

コチラのコードをちょっとだけ改造する。

リスト１　標準モジュール

Public Sub callWshScriptSendKeys(ByVal wsKeys As String, _
                                 Optional ByVal wsWait As Boolean, _
                                 Optional ByVal isFinal As Boolean)    '……(1)'
  Static objWshShell As Object
  If isFinal Then Set objWshShell = Nothing: Exit Sub    '……(2)'
  If objWshShell Is Nothing Then Set objWshShell = CreateObject("Wscript.Shell")
  Call objWshShell.SendKeys(wsKeys, wsWait)
End Sub

元のコードに付け加えたのは(1)の引数リストと(2)のコードだけ。

(1)の

Public Sub callWshScriptSendKeys(ByVal wsKeys As String, _
                                 Optional ByVal wsWait As Boolean, _
                                 Optional ByVal isFinal As Boolean)

では、省略可能な第３引数isFinalを設定している。

(2)の

If isFinal Then Set objWshShell = Nothing: Exit Sub

では、第３引数のisFinalがTrueだったら、objWshShellをNothingにしてそのままプロシージャを抜けるようにした。

全体の処理の最後に、第３引数isFinalをTrueにしてこのプロシージャを呼び出すことで、オブジェクトを破棄できると考えた。これが、素人の浅知恵の部分ｗ

まあ、そのために第１引数wsKeysにアテ馬のように文字列を与えないと呼び出せない（もちろん、""でいいんだけれど）ので、ブサイクといえばブサイクですけどｗ

SendKeysメソッド呼び出し回りの改造

VBAのApplication.SendKeysメソッドの使用をやめ、全面的にWshScriptのSendKeysメソッドに置き換える。

具体的には、

akashi-keirin.hatenablog.com

このときのリスト１を、リスト１で作成したプロシージャを呼び出す形に書き換える。

リスト２　標準モジュール

Public Sub cutText()
  Call callWshScriptSendKeys("^X")
  DoEvents
End Sub
Public Sub copyText()
  Call callWshScriptSendKeys("^C")
  DoEvents
End Sub
Public Sub pasteText()
  Call callWshScriptSendKeys("^V")
  DoEvents
End Sub
Public Sub selectAll()
  Call callWshScriptSendKeys("^A")
  DoEvents
End Sub

これで準備万端のはず。

実行結果

伝わりにくいと思いますが、NumLockがオンになっているので、数字の入力ができることを表現した画像ですｗ

この状態で、

右クリックして、「貼り付け」をクリック。

おおっ！　無事に貼り付けできたぞ！

今度は、「全て選択」だっ！

ガッ……！？

ど、どういうことやねん？？？

今度は「切り取り」をクリック！

ガッ……！？

な、何が起こっているんだーーーーッ！？

んで、気色悪いのが、

OSDにNumLockオン、オフの表示が出るのが不規則

だということ。右クリックメニューを使ったときに、出たり出なかったりする。んで、「NUM LOCK OFF」ばっかり連続で出るかと思ったら、急に「NUM LOCK ON」に変わったり、わけが分からない。

で、途方に暮れかけているときに気づいたのが、

OSDのオン、オフ表示に関係なく、NumLockの状態は変化していない

という、さらにわけの分からない事実。

OSDに「NUM LOCK OFF」と表示された後でも、こんなふうに普通にテンキーで数字が入力できる。

私のノートPCに限った現象だと思う（デスクトップはキーボードのLEDの点灯でNumLockの状態を知らせる仕組み）けれど、気色悪いなあ。

おわりに

id:imihito さん、ありがとうございました。

Application.SendKeysメソッドの不具合への素人的対応

ち～んｗ珍現象を解決する

SendKeysメソッドで勝手に[Num Lock]キーが押されたみたいになる現象への対応

前回、

akashi-keirin.hatenablog.com

コチラで、SendKeysメソッドを実行すると、なぜか[Num Lock]が切り替わってしまうという珍現象をご紹介した。

コチラによると、どうもバグっぽい。

ただ、別にそんなに複雑なキーストロークを指示しているわけでもないのになあ。

とはいえ、いちいち右クリックメニューを選択するたびに[Num Lock]が切り替わったんではうっとうしいことこの上ない。

[Num Lock]の状態を調べて実行するごとに[Num Lock]を切り替え直すという対応がまず思いついたが、

SendKeys が実行される前に NumLock キーの設定を行います。次に、NumLock キーを SendKeys の実行前にオフにします。
SendKeys が実行されたら、NumLock キーの設定を SendKeys の実行前の状態に戻します。
この手順を実行するには、GetKeyboardState、keybd_event、および SetKeyboardState の各 API 関数を使用します。

ということで、どうもWindowsAPIとか使わないといけないっぽいので、パス（←コラ！）。

あくまでもSendKeysメソッドでどうにかする

よく考えたら、今までApplication.SendKeysメソッドなんて使ったことがなかった。

んで、SendKeysメソッドについて調べてみた。

コチラによると、

Enter キーや Tab キーのように、押しても画面に文字が表示されないキーを指定するときは、次に示すコードを使います。各コードは、キーボードの 1 つのキーに対応します。

キー	コード
NumLock	{NUMLOCK}

……って、オイ！

SendKeysメソッドで[Num Lock]押しゃあいーじゃん!!!!!!!!

……。

やってみた

前回のリスト１に、次のように付け加える。

リスト１　フォームモジュール

Private Sub TextBoxMain_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, _
                                  ByVal X As Single, ByVal Y As Single)
  Static flg As Boolean
  If Button = xlSecondaryButton Then
    flg = Not flg
    If flg Then contextMenu.ShowPopup
    Application.SendKeys "{NUMLOCK}"    '……(*)'
    DoEvents
  End If
End Sub

見たら分かると思うけれど、(*)を追加。

たったコレだけ。

実行結果

テキストボックス上で右クリック。

この状態で、「貼り付け」をクリック。

無事、コマンドが実行され、[Num Lock]の状態もキープされている。画像では全く伝わらないがｗ

おわりに

コマンド実行時に[Num Lock]のランプが一瞬点滅するのが悲しい。

右クリック→左クリックでメニューが「逃げる」問題や、今回の「勝手に[Num Lock]が切り替わる」問題に、その場しのぎの対応をしているので、コードがどんどん不細工になっていくのがちょっとね……。

WindowsAPIに挑戦するチャンスかも知れないので、そのあたりは宿題ということで……。

VBAのち～んｗ現象

ち～んｗ珍現象あれこれ

右クリックメニューが逃げる問題

前回の

akashi-keirin.hatenablog.com

でご紹介した珍現象。TextBoxコントロールのMouseDownイベントを用いて、ショートカットキー押下と同じ現象を引き起こすプロシージャを呼び出しているのに、なぜか処理を呼び出す前にもう１回クリックイベントが起こったみたいになって、まるで１度右クリックメニューが逃げたみたいになっていた。

この文章では何のことか分からないので整理すると、

コードに書いた（はずの）処理

1. テキストボックス上で右クリック。
2. MouseDownイベント発生。
3. 右クリックなので、「Button = 2」がTrueになり、ShowPopupメソッドが実行される。
4. 右クリックメニューが表示される。
5. メニューのどれかを左クリック
6. 左クリックした（CommandBarオブジェクト配下の）ControlオブジェクトのOnActionプロパティに登録されたプロシージャが呼び出される。

実際に起こっていること

1. テキストボックス上で右クリック。
2. MouseDownイベント発生。
3. 右クリックなので、「Button = 2」がTrueになり、ShowPopupメソッドが実行される。
4. 右クリックメニューが表示される。
5. メニューのどれかを左クリック
6. なぜか再度ShowPopupメソッドが発動。
7. 5.でクリックした位置を基準として右クリックメニューが表示される。
8. 以下省略（意図した通りの動きになる）。

何でこうなるのか、サッパリ分かりまへん。

とりあえずの対応

id:imihito さんからのアドヴァイスに沿って、MouseDownイベントのコードに少し記述を追加した。

前回のリスト３を、次のように変える。

リスト１　フォームモジュール

Private Sub TextBoxMain_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, _
                                  ByVal X As Single, ByVal Y As Single)
  Static flg As Boolean
  If Button = xlSecondaryButton Then
    flg = Not flg
    If flg Then contextMenu.ShowPopup
  End If
End Sub

コメント欄で id:imihito さんが教えてくださった通りなので、説明はごく簡潔に。

このプロシージャが終了しただけでは死なないStatic変数 flg を用意して、右クリックされるたびにNot演算することにより、TrueとFalseを１回ごとに切り替えている。これによって２回に１回だけShowPopupが起こるようにしている。

もちろん、これは単なる対症療法に過ぎなくて、全然根本的な解決ではない。

しかし、なんであんなわけの分からないことが起こるのかが分からない以上、どうしようもないとも言える。

実行

右クリックで出てきたメニューを左クリック！

ウホッ！　無事一発で貼り付けができ……

って、コラ!!!!!!!!

何でNum Lockが勝手にOffになるねん!!!!!!!!

ちなみに、ちょっとggってみると、これはSendKeysメソッドのバグ（？）らしく、従ってSendKeysメソッドを使わない

「煽る」メニュー（なんちゅう名前やねん）

をクリックしても、NumLockのOn、Off切り替えは起こらない。

う～ん……。何ともはや……。

おわりに

VBAの闇は深うおますなあ。

@akashi_keirin on Twitter

自作右クリックメニューが逃げる・・・？

コンテキストメニューが逃げる

「ユーザーフォーム上のテキストボックスで右クリックメニューが使えない」問題

ユーザーフォームに設置したテキストボックス（いや、テキストボックスに限りませんけど）にテキスト入力しているときに右クリックが効かない、というのはわりかし有名なんじゃないかと思う。

普通に考えたら、これは不便な話。もちろん、ショートカットキーは生きているから、クリップボードの内容をペーストしたけりゃ[Ctrl]+[V]でおｋなんだけれど、普段とことん慣れ親しんだ動作だけに、やはり右クリックメニューは出てきてほしい。

どうにかならないものなのか、とggっていて発見したのがコチラおよびコチラ。大いに参考にさせていただいた。

右クリックメニュー実現のための要点

要するに、

1. 呼び出される処理を標準モジュールに準備しておく。
2. フォームのインスタンス化時にCommandBarオブジェクトを追加する。
3. テキストボックスのMouseDownイベントでCommandBarオブジェクトのShowPopupメソッドを実行してCommandBarオブジェクト（右クリックメニュー）を表示する。

ということらしい。

やってみた

まずは、標準モジュールに次のコードを書いて、テキスト編集用の処理を準備する。

リスト１　標準モジュール

Public Sub cutText()
  Application.SendKeys "^X"
End Sub
Public Sub copyText()
  Application.SendKeys "^C"
End Sub
Public Sub pasteText()
  Application.SendKeys "^V"
End Sub
Public Sub selectAll()
  Application.SendKeys "^A"
End Sub

何のことはない。Application.SendKeysメソッドを用いて、おなじみのショートカットキー押下を再現しているだけ。

んで、お次はフォームモジュール。

リスト２　フォームモジュール

'宣言セクション'
Option Explicit
Private contextMenu As CommandBar    '……(1)'
Private Sub UserForm_Initialize()
  Set contextMenu = _
        Application.CommandBars.Add(Position:=msoBarPopup, _
                                    Temporary:=True)    '……(2)'
  With contextMenu
    With .Controls.Add    '……(3)'
      .Caption = "切り取り"
      .OnAction = "cutText"
      .FaceId = 21
    End With
    With .Controls.Add
      .Caption = "コピー"
      .OnAction = "copyText"
      .FaceId = 19
    End With
    With .Controls.Add
      .Caption = "貼り付け"
      .OnAction = "pasteText"
      .FaceId = 22
    End With
    With .Controls.Add
      .BeginGroup = True    '……(4)'
      .Caption = "全て選択"
      .OnAction = "selectAll"
    End With
  End With
End Sub

(1)の

Private contextMenu As CommandBar

では、フォームモジュールの宣言セクションでCommandBar型のオブジェクト変数contextMenuを宣言している。フォームモジュール内の複数のプロシージャ（「UserForm_Initialize」と、後述の「TextBoxMain_MouseDown」）から参照される変数なので、モジュールレベル変数とした。

(2)の

Set contextMenu = _
      Application.CommandBars.Add(Position:=msoBarPopup, _
                                  Temporary:=True)

では、Application.CommandBarsコレクションのAddメソッドを用いて、CommandBarオブジェクトを新しく生成して変数contextMenuにぶち込んでいる。引数Positionは、コチラによると、

新しいコマンド バーの位置または種類を指定します。使用できる定数は、 MsoBarPosition 定数のいずれかです。

ということで、msoBarPopupを指定しているので、たぶん「その場でポップアップする」ぐらいの意味なんだろう（適当）。

あと、もう一つ指定した引数Temporaryってのは、コチラに

使用が終わったとき自動的に破棄されるよう引数TemporaryにTrueを指定しておきましょう。

とあるので、そういう意味なんだろう（適当）。

(3)からの５行

With .Controls.Add    '……(3)'
  .Caption = "切り取り"
  .OnAction = "cutText"
  .FaceId = 21
End With

では、contextMenuオブジェクトの配下にControlオブジェクトを追加する処理。

ControlsコレクションのAddメソッドの引数Captionには表示される文字列、OnActionに実行されるプロシージャ名、FaceIdで表示されるアイコンを指定しているっぽい（適当）。

「切り取り」、「コピー」、「貼り付け」は同じように記述している。

「全て選択」だけはちょっと違っていて、(4)の

.BeginGroup = True

でBeginGroupプロパティをTrueにしている。

このControlオブジェクトは新しいグループに設定せよ、ということなんだろう（適当）。

あとは、テキストボックスのMouseDownイベントの設定。

リスト３　フォームモジュール

Private Sub TextBoxMain_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, _
                                  ByVal X As Single, ByVal Y As Single)
  If Button = xlSecondaryButton Then contextMenu.ShowPopup    '……(1)'
End Sub

なんと、たったのこれだけｗ

(1)の

If Button = xlSecondaryButton Then contextMenu.ShowPopup

イベント発生時に受け取った引数Buttonの中身が「2」だったら、右クリックされたということになるので、CommandBarオブジェクトのShowPopupメソッドを実行する、ということだ。

「2」と指定する代わりにxlSecondaryButtonを指定しているが、たぶんこれでいいと思う（適当）。「XlMouseButton」のメンバだし。

実行してみる

テキストボックス上で右クリックすると、

おおっ！　ちゃーんと右クリックメニューが出ましたよ！　感動！

しかーし！

「貼り付け」をクリックすると（あ、ちなみに、クリップボードには既にテキストをコピー済みです）、

(ﾟДﾟ)ﾊｧ?

分かりますか？　なんと、右クリックメニューが逃げたんです。右下に。

めげずに、追いかけてもう一度「貼り付け」をクリックすると、

無事に「貼り付け」は実行される。

これ、他の３つ（「切り取り」、「コピー」、「全て選択」）のどれをやっても同じ挙動になる。

何でなんだ？？？

まあ、たぶん、どうせしょうもない原因なんでしょうけれど……。

揮発性関数（Application.Volatileメソッド）

揮発性関数？？？

Application.Volatileメソッド

前回の

akashi-keirin.hatenablog.com

に、id:imihito さんからコメントをいただいた。

曰く、「きっと　うまく　いくでしょう」

`Excel.Application.Volatile`メソッドを使えば、その関数を揮発性関数にできたはずです。
（中略）
揮発性関数というのは計算結果が毎回再計算される関数のことです。
組み込み関数ではNOWとかOFFSET、RANDなどが該当します

ですと。

ほえ～。そんな方法があったのかぁ……。それにしても、「揮発性」て、ガソリンみたいな関数やのう……（"Volatile"を辞書で引いたら、そのものズバリ、「揮発性の」という意味が載ってた。直訳かよｗｗｗ）。

んで、やってみた。

自作ワークシート関数を揮発性関数化する

前回のリスト１のFunctionを、下記のように改変する。

リスト１　標準モジュール

Public Function assembleWord(ByVal Cell1 As Range, _
                             ByVal Cell2 As Range) As String
  Application.Volatile    '……(*)'
  Dim str As String
  str = Cell1.Value & Cell2.Value
  str = str & Cell2.Offset(0, 1).Value
  assembleWord = str
End Function

「改変した」っつっても、変えたのは(*)のところだけ。

コチラによると、たったこれだけで、わが自作ワークシート関数AssembleWordは、揮発性関数とやらに生まれ変わっとるということになる。ホンマかいな。

実験

シートモジュールに書いた前回のリスト２を全部コメントアウトしてから、

この状態の表のＣ２セルに、

「ｗ」を書き込み、[Enter]をポチッ！

ウホッ！　あっさり再計算されたｗｗｗ

id:imihito さん、

あざす!!!!!!!!

気になること

わが自作ワークシート関数AssembleWordが、実にエレガントに生まれ変わったわけだが、ちょっと気になることが。

ステップ実行で[F8]を連打しているときに気づいたんだが、どうも１回の処理をするのに、AssembleWord関数が何遍も呼び出されているみたいなのだ。

んで、今一度コチラを見てみると、

自動再計算関数は、ワークシートのいずれかのセルで計算が行われるたびに再計算を行います。

だと。

要するに、１箇所値の変更があっただけで他の数式も全部再計算しているってことか。

検証

『タモリ倶楽部』だったら、剣を打ち合う音と笙の音が流れるところ。

検証用に、次のコードで実行してみた。

リスト２　標準モジュール

'宣言セクション'
Option Explicit
Public cnt As Integer    '……(1)'

Public Function assembleWord(ByVal Cell1 As Range, _
                             ByVal Cell2 As Range) As String
  Application.Volatile
  cnt = cnt + 1    '……(2)'
  Dim str As String
  str = Cell1.Value & Cell2.Value
  str = str & Cell2.Offset(0, 1).Value
  assembleWord = str
End Function

Public Sub assembleWordTest()
  ThisWorkbook.Worksheets(2).Range("C2").Value = "ｗｗｗ"    '……(3)'
  Debug.Print cnt    '……(4)'
End Sub

(1)で、Public変数cntを準備して、

(2)では、AssembleWordが呼び出されるごとにcntをインクリメント。

エントリポイントとしてassembleWordTestプロシージャを作る。このプロシージャでは、

(3)でＣ２セルを書き変え、

(4)でcntの値をイミディエイト・ウインドウに出力する。

この状態で実行すると、イミディエイトは

こうなった。AssembleWord関数を用いたセルが５つあるので、５回呼び出された模様。

おわりに

もともと、当該の１セルだけ（今回の場合だとＤ４セルだけ）を再計算してほしかったんであって、一つ値を変えるだけで同じ関数を用いたセル全てを再計算、みたいな大袈裟なことは望んでなかったんだけれど……。

やっぱり、Application.Volatileメソッドを使うべきなんだろうか……？？？

追記

前回の

akashi-keirin.hatenablog.com

やり方では何回再計算しているのか、同じように計測してみると、何と、cntの数値が「11」と出た。

やっぱり、Application.Volatileメソッドで揮発性関数にしてしまうのが一番効率的みたいですね。