名づけて、「ダルマ落とし方式」！ (Word) - 素人がExcelVBAによる「一人働き方改革」に挑むブログ

名づけて「ダルマ落とし方式」！

前回

akashi-keirin.hatenablog.com

のマヌケ記事の続き。

シェイプが一掃されない理由

どうも、For Eachでループさせる際に、VBAは内部でShapesコレクションに番号を振って、その番号順に処理をしているらしい。

ただ、Deleteメソッドで削除した場合に、その番号が自動的に繰り上がる仕組みのようだ。

つまり、普通にExcelで行とか列とかを削除したら、番号が繰り上がるのと同じ。

だから、For Eachで回しながらDeleteメソッドでコレクションの要素を削除すると歯抜け状態になる。

前回のアレの場合、もともと9個あったシェイプが実行後4個になったのは、

初期状態

①ア②ホ③か④ボ⑤ケ⑥か⑦カ⑧ス⑨か

コレクション番号①を削除

①ホ②か③ボ④ケ⑤か⑥カ⑦ス⑧か

コレクション番号②を削除

①ホ②ボ③ケ④か⑤カ⑥ス⑦か

コレクション番号③を削除

①ホ②ボ③か④カ⑤ス⑥か

コレクション番号④を削除

①ホ②ボ③か④ス⑤か

コレクション番号⑤を削除

①ホ②ボ③か④ス

というわけで、コレクション番号⑤まで削除したところで最後の要素に達してしまうので、4個残る、ということなのだ。

一般化すると、要素数 \ 2個分、つまり２で割った商個残る計算。

歯抜け回避の方法

Twitterでことりちゅん (id:Kotori-ChunChun) 氏が教えてくださった〈ケツから削除方式〉と、前回記事へのコメントで thom (id:t-hom) 氏が教えてくださった〈全滅するまでひたすら先頭要素を削除方式〉の二通りがある。

前者は、通常のExcelで行やら列やらを削除する場合でもおなじみなので、後者の方式を採用。

名づけて、〈ダルマ落とし方式〉！

ダルマ落とし方式を可視化する

ただ、〈ダルマ落とし方式〉のコード自体は、thom (id:t-hom) 氏がすでにコメント欄に書いてくださっているので、ダルマ落とし風に見えるようにアレンジ。

準備

まずは、「ダルマ」を準備。

f:id:akashi_keirin:20190216091327j:plain

ドキュメント上に、こんな風に「ダルマ」を設置。

一番下のシェイプのTopプロパティを170に、それぞれのシェイプのHeightプロパティを25にしている。

コード

マジックナンバーだらけの場当たりコードですが、一応全掲載。一般化するのがめんどくさいだけｗ

リスト１　標準モジュール

Option Explicit

Private winAPI As WindowsAPI

Public Sub droppingDharma()
  Dim Doc As Document
  Set Doc = ActiveDocument
  Dim targetShapes As Word.Shapes
  Set targetShapes = getTextAllocatedShapes(Doc.Shapes)
  Dim shapesTopArray As Variant
  shapesTopArray = getShapesTopArray(targetShapes)
  Set winAPI = New WindowsAPI
  Dim i As Long
  Do While Doc.Shapes.Count <> 0
    Doc.Shapes(1).Delete
    Call winAPI.waitFor(100)
    For i = 1 To Doc.Shapes.Count
      Doc.Shapes(i).Top = shapesTopArray(i - 1)
      Call winAPI.waitFor(100)
    Next
  Loop
End Sub

Private Function getShapesTopArray( _
             ByVal targetShapes As Shapes) As Variant
  Dim ret As Variant
  ReDim ret(targetShapes.Count - 1)
  Dim i As Long
  For i = LBound(ret) To UBound(ret)
    ret(i) = targetShapes(i + 1).Top
  Next
  getShapesTopArray = ret
End Function

Private Function getTextAllocatedShapes( _
             ByVal targetShapes As Shapes) As Shapes
  Dim ar As Variant
  ar = Split("お,前,は,ア,ホ,か,(ﾟДﾟ)", ",")
  Dim i As Long
  For i = LBound(ar) To UBound(ar)
    With targetShapes(i + 1)
      .Top = 170 - (25 * i)
      .TextFrame.TextRange.Text = ar(i) & vbCr
      .TextFrame.TextRange.ParagraphFormat.LineSpacing = 18
    End With
  Next
  Set getTextAllocatedShapes = targetShapes
End Function

あ、自作のWindowsAPIクラスを使用しています。

詳しいことは、

akashi-keirin.hatenablog.com

コチラをどうぞ。

未確認だが、どうもShapesコレクションのインデックス番号は常に一定というわけでもない？

実行するたびに順番が変わっているような気がしたので、getTextAllocatedShapesというメソッドによって、毎回インデックス番号1～7にテキストを設定し直し、下から順に並ぶようにした。

Shape.TextFrame.TextRange.Textプロパティの値をセットし直すと、段落設定がリセットされる（？　少なくとも「行間」の設定は解除されてしまっていた。詳しいことは調べていないので、鵜呑みにしないでください。）ので、Shape.TextFrame.TextRange.ParagraphFormat.LineSpacingプロパティを設定し直すようにしている。