フォルダのサイズを返すFunction

フォルダのサイズを返すFunction

フォルダのサイズを返すFunctionを作ってみた。

FileSystemObjectを使う

だいぶ前に、Twitterでノンプロ研の某氏が言っていたのを思い出した。

たしかに、Windowsのエクスプローラーでフォルダを右クリックして「プロパティ」を表示しても、フォルダのサイズはわからなくはないのだが、ファイル数が多いときに異様に時間がかかる。

FileSystemObjectを使えば一瞬なのだ。

作ったコード

ちょっとだけ工夫をして、次のようなコードにした。

リスト１

Option Explicit

Public Enum FiUnit
  fiByte
  fiKiloByte
  fiMegaByte
  fiGigaByte
  fiTeraByte
End Enum

Dim fsObj As Object

Public Function GetFolderSize( _
            ByVal a_FolderPath As String, _
   Optional ByVal a_Unit As FiUnit = fiByte) As Variant
  Dim ret As Variant
  ret = 0
  If fsObj Is Nothing Then Set fsObj = CreateObject("Scripting.FileSystemObject")
  Dim tgtFolder As Object
  'パス間違いだったら-1を返してExit'
  If Not fsObj.FolderExists(a_FolderPath) Then ret = -1: GoTo ReturnValue
  Set tgtFolder = fsObj.GetFolder(a_FolderPath)
  ret = tgtFolder.Size
  ret = ret / (1024 ^ a_Unit) '……(*)'
ReturnValue:
  GetFolderSize = ret
End Function

第2引数で、自作の列挙体を指定できるようにした。

んで、たとえばfiKiloByteが渡されたら、fiKiloByteの実体は2なので、Scripting.FolderオブジェクトのSizeプロパティが返した値を1024 ^ 2で割ることになり、キロバイト単位になる。

使ってみる

このFunctionを使って、私のSSD内のMETALLICAフォルダのサイズを表示してみた。

Byte単位とGigaByte単位で表示させてみた結果が、

これ。（英語が変だったら教えろえてください。）

エクスプローラの「プロパティ」で表示させてみた結果は、

これ。

当たり前だけど、完全一致。

おわりに

FileSystemObjectって、便利だね。

VBAで段落前後のスペースを操作する（Word）

VBAで段落前後のスペースを操作する（Word）

軽くハマったので報告。

何がしたかったか

Googleフォームで集めたアンケート結果の自由記述の部分をWordに移して整形したかった。

ただずらずらと並べただけだと読みづらいので、一人分づつ記述の間にスペースを空けて読みやすくしたい。

単にこれだけなら、段落の後ろに0.5行とか間隔を空けるようなスタイルを作って、そいつを全体に適用すればよい。

しかし、このやり方だと、回答の中で改行（段落）しているものがあると、全部隙間が空いてしまって具合が悪い。

幸い、改行を含む回答を、GoogleスプレッドシートからテキストファイルとかWordドキュメントにコピペすると、回答全体の頭とケツをダブルクオーテーションで括った形になっている。

……ということは、次のように処理すれば良いと考えたのだ。すなわち、

1. 回答全体をWordドキュメントにコピペする。
2. 各段落に対して、後ろに0.5行の間隔を空けるスタイルを当てていく。
3. 段落の先頭に「"」（ダブルクォーテーション）がある段落については、間隔を「0」にする。
4. 置換機能でダブルクォーテーションを削除する。

これで万全だと思った。

しかし、だめだったのである。

3.のところがうまくいかなかったのだ。

Paragraph.Range.ParagraphFormatオブジェクトのLineUnitAfterプロパティとか、SpaceAfterプロパティに値を設定するだけのかんたんなお仕事だと思ったんですが、うんともすんとも言いやがらねえんです。

解決までの道

ぐりぐりやっているうちに偶然（笑）解決したので、報告します。

スプシからWordに貼り付ける

スプシからWordにテキストを貼り付ける。

こうなる。セルの中に改行がある場合は、上述の通り、回答の先頭とケツに「"」が入る。

段落スタイルを当てる

この二つの段落に、自作の「My本文列挙1」スタイルを当てたところ。

自作の「My本文列挙1」の設定は次のとおり。

このスタイルを当ててあるので、当然この段落の書式は、次のとおり。

したがって、当然、二つの段落はバラバラになる。

VBAで段落書式の変更を試みる

リスト１

Private Sub test01()
  With Selection.ParagraphFormat
    .SpaceAfter = 0
  End With
End Sub

ParagraphFormatオブジェクトのSpaceAfterプロパティを「0」にするというだけのコードである。

このリスト１を、一つ目の段落にカーソルを置いて実行してみる。

このとおり、何も変わっていない。

段落書式を確認する。

なんてこった。何も変わっちゃいねえ。

異変起こる

では、と今度は先ほどのリスト１を次のように改めてみる。

リスト２

Private Sub test01()
  With Selection.ParagraphFormat
    .LineUnitAfter = 0
  End With
End Sub

こいつを実行してみた。

しかし、ダメ。やっぱり、なーーーんも変わりゃあせん。

しかし、私は見逃さなかった！

段落書式の「段落後」の値が〝ポイント表記〟になっていることを！（偶然ですけどね。）

どうやら、LineUnitAfterプロパティを設定すると、なぜか表記がポイント単位に変わるらしい。

も、もしかして……。

そして、解決へ……

今度は、リスト２を次のようにした。

Private Sub test01()
  With Selection.ParagraphFormat
    .LineUnitAfter = 0
    .SpaceAfter = 0
  End With
End Sub

一旦「段落後」の値をポイント表記に変えておき、しかる後にSpaceAfterプロパティに「0」をセットしてみたのである!!!!!!!!

うおおおおおおおおお！

でけたあああああああ！

おわりに

WordのVBAは、実に多くの試練をわれわれユーザーに投げかけてくる。

WordVBA……。それは、まさに……、

男塾

である！

isKanjiメソッドを久々に修正した

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

まじめに手直しした。

元のコード

コチラが、元のisKanjiメソッドのコード。

リスト１

Public Function isKanji(ByVal targetCharacter As String) As Boolean
  Dim char As String
  char = targetCharacter
  If Len(char) <> 1 Then Call 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

うーむ……。実にテキトーである。

これでは、第2水準以降とか、全然対応できないではないか。

で、ちょっとまじめに書き直してみた。

文字コード表は、コチラのお世話になりました。いつもありがとうございます。

書き直したコード

修正したisKanjiメソッドのコードがコチラ。

リスト２

Private Function isKanji( _
             ByVal a_Char As String) As Boolean
'///漢字だったらTrueを返す。'
  Const SP_KANJI = "ヽ ヾ ゝ ゞ 〃 仝 々 〆"
  Dim arr() As String
  arr = Split(SP_KANJI)
  isKanji = True
  Dim char As String * 1
  char = a_Char
  Dim i As Long
  '特殊文字は漢字と見なす'
  For i = LBound(arr) To UBound(arr)
    If char = arr(i) Then Exit Function
  Next
  '第4レベルの漢字判定'
  If CInt(Asc(char)) > CInt(&HFC4B) Then
    isKanji = False
    Exit Function
  End If
  If CInt(Asc(char)) > CInt(&HFA5B) Then Exit Function
  '第3レベルの漢字判定'
  If CInt(Asc(char)) > CInt(&HEAA4) Then
    isKanji = False
    Exit Function
  End If
  If CInt(Asc(char)) > CInt(&HE039) Then Exit Function
  '第2レベルの漢字判定'
  If CInt(Asc(char)) > CInt(&H9FFC) Then
    isKanji = False
    Exit Function
  End If
  If CInt(Asc(char)) > CInt(&H989E) Then Exit Function
  '第1レベルの漢字判定'
  If CInt(Asc(char)) > CInt(&H9872) Then
    isKanji = False
    Exit Function
  End If
  If CInt(Asc(char)) > CInt(&H889E) Then Exit Function
  'ここまで引っかからなかったらFalse'
  isKanji = False
End Function

文字コード表とにらめっこしながら、がんばったよ！

使ってみる

次のコードで実験

リスト３

Private Sub test10()
  Dim char As String * 1
  char = "黑"  '……(*)'
  Debug.Print char & " : "; isKanji(char)
End Sub

(*)のところで、変数charに色んな文字を入れてみて実験。

うむ。

おわりに

こんなもんでいいのではなかろうか。

FileSystemObjectのCreateFolderメソッドで半角スペースで終わるフォルダ名のフォルダを作ったらヤバい

FileSystemObjectでフォルダを作るときに気をつけた方がいいこと

ちょっと恐怖体験をしたので報告。

フォルダ名の最後の文字が半角スペースになるようなフォルダを作る

Scripting.FileSystemObjectオブジェクトの、CreateFolderメソッドを使ってフォルダを作るときに、フォルダ名の末尾を半角スペースにしてみる。

リスト１

'Microsoft Scripting Runtime 参照設定済み'
Private Sub test00()
  Dim fsObj As New Scripting.FileSystemObject
  Call fsObj.CreateFolder(ThisWorkbook.Path & "\ち～んｗ ")
End Sub

こいつを実行すると、フォルダ内が

こうなる。

一見すると、「ち～んｗ」という名前のフォルダが出来ただけのようである。

しかし……。

ファッ？！

なんと、

こんなふうになってしまうのである！

一見、全く同名のフォルダが出来たようであるが、

おわかりだろうか。

下の方は、「ｗ」の後ろがちょっと長い。

下の方は、「ち～んｗ」の後ろに半角スペースが入っているのである。

普通、こんな名前のフォルダは作れないが、どうもFileSystemObjectを使うと、こういうわけのわからないフォルダが作れてしまうようなのである。

恐ろしいこと

単に、〝ちょっと普通には作れないフォルダが作れちゃう〟というだけなら、何ら実害はない。

しかし、恐ろしいことに、こうして出来た変なフォルダ（今回の場合だと「ち～んｗ 」フォルダ。）は、次のような事態を招くのである！

け、消せねえ……。

めっちゃ困るのである！

救いの手がさしのべられた

どうしてもフォルダが消せず、困っていたところ、踊るVBEの中の人が救いの手をさしのべてくださった。

曰く、

WinAPI使ったら消せるよ！

と。

ありがたや～！

踊る氏に、教えてもらったWinAPI関数が、コチラ。

Private Declare Function RemoveDirectory Lib "kernel32" Alias "RemoveDirectoryA" (ByVal lpPathName As String) As Long

こいつを宣言セクションに書いて、次のコードで実行してみた。

リスト２

Private Sub test01()
  Call RemoveDirectory(ThisWorkbook.Path & "\ち～んｗ \")
End Sub

これで、無事に消えてくれました。

ありがとう、踊るさん！

おわりに

さすがや……。

挿入した画像に図表番号を挿入するマクロ（Word）

文書に挿入した画像にマクロで図表番号を付ける（Word）

最近、やたらマニュアルの類を作成している。

スクリーンショット等の画像を貼り付けた文書を作成することがやたら多くなったのだが、いちいち図表番号を入れるのが面倒になってきた。

……となると、当然VBAの出番なのである。

Selection.InsertCaptionメソッド

文書の編集作業をしながらサクッと図表番号を挿入することができたら素敵である。

画像を挿入するたびに、クイック アクセス ツール バーとか、ショートカットキーでサクッとやるイメージ。

そこで、Selection.InsertCaptionメソッドを使うことにする。

Selection.InsertCaptionメソッドの書式

Selection.InsertCaptionメソッドの書式は、『Word2013 developer docs』（Word2013のオフライン・ヘルプ）によると、

expression .InsertCaption(Label, Title, TitleAutoText, Position, ExcludeLabel)

である。

引数が五つもあるが、単に「図 1」、「図 2」と入れたいだけなら、「Label」、「Position」の二つを指定すれば十分だろう。

「Label」は、「図 1」の「図」の指定、「Position」は文字どおりキャプションの位置の指定に用いる。

こういうこと。

ちなみに、「Title」を指定すると、

こんなふうになる。もちろん、引数Titleに「『アホの坂田』アルバムジャケット」という文字列を指定したのである。（今気づいたけど、「アルバム」じゃねえな。メンゴメンゴ。）

引数Labelの指定

ちょいとうっとうしいのが、引数Labelの指定である。

再び、『Word2013 developer docs』から引く。引数Labelの説明は次の通りである。

The caption label to be inserted. Can be a String or one of the WdCaptionLabelID constants. If the label has not yet been defined, an error occurs. Use the Add method with the CaptionLabels object to define new caption labels.

つまり、引数Labelの指定は文字列でもWdCaptionLabelIDの指定でもどちらでも良いが、文字列で指定した場合に、その文字列が「ラベル」として登録されていないものだったらエラーが出る、ということだ。

たとえば、

このような状態で、画像を選択して

Call Selection.InsertCaption("ち～んｗ")

を実行したとしても、「ち～んｗ」などというラベルは未登録なので、

エラーになるのである。

上記引用文中に「Use the Add method with the CaptionLabels object to define new caption labels.」とあるように、未登録の文字列をラベルとして使用したければ、[CaptionLabels].Addメソッドを用いて、CaptionLabelsコレクションに追加しておかねばならんのだ。

そこで、次のような対応が必要となる。

• 使用したいラベル（名）がCaptionLabelsコレクション内にあるかどうかを調べる
• コレクション内にあれば、そのインデックスを取得する
• なかったら、CaptionLabelsコレクションに追加して、インデックス番号を取得する
• 引数Label指定時には、[CaptionLabels].Item(index).Nameの形で指定する

およそ、このような手順である。

なかなか面倒である。

ラベルのインデックスを取得するFunction

まず、ラベルのインデックスを取得するFunctionを作成する。

リスト１

Private Function getCaptionLabelIndex( _
                 ByVal a_LabelName As String) As Long
  Dim ret As Long
  Dim captLabels As CaptionLabels
  Set captLabels = Application.CaptionLabels
  Dim i As Long
  For i = 1 To captLabels.Count    '……(1)'
    If captLabels.Item(i).Name = a_LabelName Then
      ret = i
      GoTo ReturnValue
    End If
  Next
  Call captLabels.Add(a_LabelName) '……(2)'
  ret = captLabels.Count
ReturnValue:
  getCaptionLabelIndex = ret
End Function

(1)からの6行、

For i = 1 To captLabels.Count
  If captLabels.Item(i).Name = a_LabelName Then
    ret = i
    GoTo ReturnValue
  End If
Next

は、登録済みのラベル調べ。

CaptionLabelsコレクション内のCaptionLabelオブジェクトを一つづつ調べて、一致するものがあったらそのインデックスを返り値用変数retにぶち込んで、ReturnValueに飛び、値を返す。

(1)のForループを抜けたときは、引数a_LabelNameと一致するラベルがなかったということなので、(2)の

Call captLabels.Add(a_LabelName)
ret = captLabels.Count

でCaptionLabelsコレクションに追加し、追加後のアイテム数（つまり、追加したアイテムのインデックス）を返り値用変数retにぶち込むようにしている。

選択した画像の下に図表番号を入れるマクロ

あとは、Selection.InsertCaptionを使うマクロにするだけ。

リスト２

Dim lblIndex As Long
lblIndex = getCaptionLabelIndex(a_LabelName)
Dim captLabels As CaptionLabels
Set captLabels = Application.CaptionLabels
Call Selection.InsertCaption(Label:=captLabels(lblIndex).Name, _
                             Position:=a_CaptionPosition)

プロシージャの一部分だけなので、少し補足。

a_LabelNameは、引数として受け取るラベルの文字列。「図」とか、そういうやつ。

a_CaptionPositionは、引数として受け取るキャプションの位置を表す定数（WdCaptionPosition列挙体）。

一旦、ラベル文字列をgetCaptionLabelIndexに渡し、インデックス番号を取得してから、Selection.InsertCaptionの引数Labelの指定のために使っている。

使用例

挿入した画像を選択した状態で実行したときに、

• 段落スタイルを当て、
• 画像の四辺に囲み罫線を施し、
• 図表番号を挿入する

というマクロにしてみた。

リスト３

Public Sub ApplyInlineShapeSettingsMain()
  Dim ilShp As InlineShape
  If Selection.Type = wdSelectionInlineShape Then
    Set ilShp = Selection.InlineShapes(1)
  Else
    Exit Sub
  End If
  Call applyInlineShapeSettings("My図1", "図")  '……(*)'
End Sub

Private Sub applyInlineShapeSettings( _
                 ByVal a_ParagraphStyleName As String, _
                 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#)
  Call setBordersForFigure(msoLineSingle)
  Selection.Style = a_ParagraphStyleName
  Dim lblIndex As Long
  lblIndex = getCaptionLabelIndex(a_LabelName)
  Dim captLabels As CaptionLabels
  Set captLabels = Application.CaptionLabels
  Call Selection.InsertCaption(Label:=captLabels(lblIndex).Name, _
                               Position:=a_CaptionPosition)
End Sub

Private Sub setBordersForFigure( _
        Optional ByVal LineStyle As MsoLineStyle = msoLineSingle, _
        Optional ByVal 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 = LineStyle
    .Weight = LineWeight
  End With
End Sub

Private Function getCaptionLabelIndex( _
                 ByVal a_LabelName As String) As Long
  Dim ret As Long
  Dim captLabels As CaptionLabels
  Set captLabels = Application.CaptionLabels
  Dim i As Long
  For i = 1 To captLabels.Count
    If captLabels.Item(i).Name = a_LabelName Then
      ret = i
      GoTo ReturnValue
    End If
  Next
  Call captLabels.Add(a_LabelName)
  ret = captLabels.Count
ReturnValue:
  getCaptionLabelIndex = ret
End Function

(*)のところに出てくる「My図1」というのは、個人的に設定しているスタイルの名前。

挿入した画像を選択して、リスト３を実行すると、

こうなる。

めっちゃ便利！

おわりに

これからも、面倒な作業をマクロ化したい。WordのVBAもなかなか面白いですよ。

追記

単に図表番号を追加するだけのメソッドを追加しました。

リスト４

Public 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

【速報】シェイプを選択しているとVBEでショートカットキーが使えなくなる

【速報】シェイプを選択しているとVBEでショートカットキーが使えなくなる

ちょっとした覚書。常識だったらすまん。

Wordの編集画面でシェイプを選択しているとVBEでショートカットキーが使えない

もう標題の通り。

このような、

Wordに貼り付けた画像に、枠線を施したり、段落スタイルを当てたり、図表番号を挿入したりするマクロを書いているときに、しばしばショートカットキーが効かない、という現象に悩まされたのだった。

再起動したら、ショートカットキーが効くときもあれば、効かないときもある。

レジストリの初期化してみても同じ。

「なんやねんこれ……」と困り果てていたが、原因は実にあほらしいものであった。

大事なことなので、強調しておきます。

Wordの編集画面でシェイプが選択されているときは、VBE上でショートカットキーが効きません！

[ F2 ]や[ F8 ]はおろか、[ Ctrl ]＋[ V ]やら[ Ctrl ]＋[ C ]、[ Ctrl ]＋[ J ]にいたるまで根こそぎ使えません。不便なことこの上なしです。

そういえば、シェイプ選択時は、「マクロの記録」も使えないんでしたな。

おわりに

ぐぐってみても、それらしいページにはヒットしなかったので、あまりこの現象に悩まされる人っていないのかな？

まあ、これが誰かの役に立ってくれたら幸いです。

列の最終行を求めるアレはなぜわかりにくいのか（Excel）

「[Worksheet.]Cells([Worksheet.]Rows.Count, 1).End(xlUp).Row」はなぜわかりにくいのか

任意の列（標題の場合はA列）の下端のセルの行番号を求めるおなじみのコード。

ときどき、「なかなか覚えられねえ！」という文脈で話題になるので、ちょっと考えてみた。

なぜ「覚えられねえ」のか

これは、端的に言ってたぶん〝理解していないから〟だと思う。

人間、理解したものはなかなか忘れないものだが、理解を伴わずにただ覚えているだけだと、忘れるのも早いように思う。

そうじゃない人もいるかも知れんが。

なぜ「理解」できないのか

これは、端的に言って

[Worksheet.]Cells([Worksheet.]Rows.Count, 1).End(xlUp).Row

という〝式〟（でええんか？）が、端的に〝わかりにくい〟からであろう。

なんせ、

①シートの一番下にあるセルを取得して、②そのセルから上方向に空白でないセルに突き当たったところのセルを取得して、③そのセルの行番号を取得する

というだけでも相当ややこしいのに、さらに「①」の「シートの一番下にあるセル」を指定するために、「シートの一番下」の行番号を取得せねばならず、そのために

④シートの行の総数（つまり「「シートの一番下」の行番号」と同じ数値）を取得している

という、めちゃくちゃややこしい手順を１行で書く、という暴挙を敢えてしているからである。

可能な限り分けて書く

求める手順

〝シート上のＡ列の一番下の空白でないセルの行番号〟を求める手順は以下の通り。

• Ａ列の一番下のセル（bottomCell）を取得する
• そのセルにカーソルを置いて、［Ctrl］＋［ ↑ ］を押してたどり着くセル（endCell）を取得する
• そのセルの行番号（endRow）を取得する

上記、「bottomCell」、「endCell」、「endRow」は、それぞれ後のコード内で使う変数名。

コード化

上記の手順をVBAのコード化する。

リスト１

Private Sub testEndRow()
  'Ａ列を表す定数'
  Const COLUMN_A As Long = 1

  'アクティブシートを変数にセット'
  Dim tgtSh As Worksheet
  Set tgtSh = ActiveSheet

  '一番下のセルの行番号'
  Dim MAX_ROW_NUM As Long
  MAX_ROW_NUM = tgtSh.Rows.Count
  
  'Ａ列の一番下のセル（bottomCell）を取得'
  Dim bottomCell As Range
  Set bottomCell = tgtSh.Cells(MAX_ROW_NUM, COLUMN_A)
  
  'bottomCellから上方に移動し、空白でないセルに突き当たったところの'
  'セル（endCell）を取得                                           '
  Dim endCell As Range
  Set endCell = bottomCell.End(xlUp)
  
  'endCellの行番号（endRow）を取得'
  Dim endRow As Long
  endRow = endCell.Row
  
  'イミディエイトに表示'
  Debug.Print endRow
End Sub

アクティブシートのＡ列の空白でない一番下のセルの行番号を取得して、イミディエイトに表示するだけのコード。

Dim tgtSh As Worksheet
Set tgtSh = ActiveSheet

Dim endRow As Long
endRow = tgtSh.Cells(tgtSh.Rows.Count, 1).End(xlUp).Row

と、このように書くよりは、よほど理解しやすいのではなかろうか。

おわりに

リスト１に示したように、オブジェクトや値を取得するごとに変数に格納する、というやり方で初心者向けに紹介すれば、

ただ覚えるだけのもの

ではなくなるのではないか、と思う。

参考

たとえば、この状態（A5セルにカーソルがある。）で、［Ctrl］＋［ ↓ ］を押すと、

こうなる。

これが、〝Ａ列の一番下のセル〟。

この状態（A1048576セルにカーソルがある。）で、［Ctrl］＋［ ↑ ］を押すと、

こうなる。