ThisWorkbookモジュールにインターフェースを実装することはできるのか

ThisWorkbookモジュールにインターフェースを実装することはできるのか

前回

akashi-keirin.hatenablog.com

ブックのThisWorkbookモジュールにメソッドを搭載したら、まるでブックのメソッドであるかのように呼び出すことができることを示した。

では、ThisWorkbookモジュールにインターフェースをImplementsしたら、各ブックに共通メソッドの搭載を強制させることができるのだろうか。

ちょっとやってみた。

インターフェース作り

クラスモジュールを挿入。

ChokiShowableというアホなオブジェクト名のインターフェースを作成。

で、次のようなコードを書いておく。

リスト１　クラスモジュール

Option Explicit

Public Sub showChoki()
End Sub

showChokiというメソッドを書いておく。

このインターフェースを実装したオブジェクトには、必ずshowChokiメソッドが搭載されていることになる。

ちょうど、マンガ『キン肉マン』に出てきた超人「カニベース」の着ぐるみのようなものだと思ってもらえばよい。カニベースの着ぐるみを着ると、チョキが出せるようになるのだ！

このChokiShowableインターフェースを、「ち～んｗ１号.xlsm」、「ち～んｗ２号.xlsm」それぞれに装着しておく。

プロジェクト エクスプローラーはこんな状態。

インターフェースの実装

今度は、「ち～んｗ１号.xlsm」のThisWorkbookモジュールにChokiShowableインターフェースを実装する。

リスト２　ち～んｗ１号.xlsmのThisWorkbookモジュール

Option Explicit

Implements ChokiShowable

Public Sub ChokiShowable_showChoki()
  Debug.Print "ち～んｗ１号は　チョキを　出した！"
End Sub

Public Sub callHelloWorld()
  Call Sheet1.helloWorld
End Sub

このように、showChokiメソッドを搭載。

これでおしまい。ちょっと独特の書き方ですな。

インターフェースメソッドを呼び出す

このshowChokiメソッドを呼び出すコードを「ち～んｗ２号.xlsm」の標準モジュールに書く。

リスト３　ち～んｗ１号.xlsmの標準モジュール

Public Sub testThisWorkbookInterface()
  Dim anotherBook As Workbook
  Set anotherBook = _
        Workbooks.Open(ThisWorkbook.Path & "\ち～んｗ１号.xlsm")
  Dim kaniBase As ChokiShowable  '……(1)'
  Set kaniBase = anotherBook
  Call kaniBase.showChoki  '……(2)'
  Call anotherBook.Close(SaveChanges:=False)
  Set anotherBook = Nothing
End Sub

「ち～んｗ１号.xlsm」を開いて変数にぶち込むところまでは前回と同じ。

今回は、こうして得たWorkbookオブジェクトを(1)の

Dim kaniBase As ChokiShowable

インターフェースChokiShowable型の変数にぶち込み直す。

これで、Workbookオブジェクトはカニベースの着ぐるみを着たも同然なので、チョキが出せるはず！

現に、(2)の

Call kaniBase.showChoki

を入力する際には、

このようにIntellisenseが効く！

胸熱!!!!!!!!

実行してみる

リスト３を実行すると……、

あえなくエラーｗｗｗ

おわりに

さて、どうしたものか……。

追記

中途半端に解決しました。

akashi-keirin.hatenablog.com

参考

akashi-keirin.hatenablog.com

akashi-keirin.hatenablog.com

別ブックのThisWorkbookモジュールのメソッドを呼ぶ(Excel)

別ブックのThisWorkbookモジュールのメソッドを呼ぶ

前回

akashi-keirin.hatenablog.com

別ブックのシートモジュールのメソッドを呼ぶ実験をした。

では、別ブックのThisWorkbookモジュールのメソッドはどうなのだろうか。

コードの追加

まず、ち～んｗ１号.xlsmのThisWorkbookモジュールに次のコードを追加する。

リスト１　ち～んｗ１号.xlsmのThisWorkbookモジュール

Public Sub callHelloWorld()
  Call Sheet1.helloWorld
End Sub

ご覧のとおり、Sheet1モジュールのhelloWorldメソッドを呼ぶだけのメソッド。

んで、前回のリスト３（＝ち～んｗ２号.xlsmの標準モジュールのコード）にちょこっとコードを追加する。

リスト２　ち～んｗ２号.xlsmの標準モジュール

Public Sub testCallSheetObjectProcedure()
  Dim anotherBook As Workbook
' ち～んｗ１号.xlsmを開いて変数にぶち込む'
  Set anotherBook =  _
        Workbooks.Open(ThisWorkbook.Path & "\ち～んｗ１号.xlsm")
  Call anotherBook.callHelloWorld  '……(*)'
' 「ち～んｗ１」シートを変数にぶち込む'
  Dim targetSheet As Object
  Set targetSheet = anotherBook.Worksheets("ち～んｗ１")
' helloWorldメソッドを呼ぶ'
  Call targetSheet.helloWorld
' ち～んｗ１号.xlsmを閉じる'
  Call anotherBook.Close(SaveChanges:=False)
' オブジェクト変数の解放'
  Set anotherBook = Nothing
  Set targetSheet = Nothing
End Sub

追加したのは(*)の１行だけ。

とりあえず、Workbook型のオブジェクト変数に「.」で無理矢理callHelloWorldをつないでみた。Intellisenseが効かないのでちょっと不安。

実行してみる

リスト２を実行してみると、

イミディエイト・ウインドウにこのように出力された。

つまり、Workbook型オブジェクトのメソッドであるかのように呼び出すことができた。（コーディング時に入力補完が効かないのが痛いけど。）

おわりに

つまり、Sheetオブジェクトのモジュールに書いたメソッドは、その所属するブックのThisWorkbookモジュールに呼び出し窓口的なメソッドを置けば、気軽に呼び出せる、ということになる。

別ブックのシートモジュールのメソッドを呼ぶ(Excel)

別ブックのシートモジュールに書いたメソッドを呼ぶ

シート独自の処理など、シートモジュールに書いておくのは、「コードの整理」という観点からは非常に便利。

では、シートモジュールに書いた処理を、他のブック（プロジェクト）から呼び出すことはできるのだろうか。

他ブックのシートモジュールのメソッドを呼ぼうとしてみる

準備

同じフォルダ内に、二つのブックを作る。

こんな感じ。

いちおう、それぞれのプロジェクト エクスプローラーの状態をどうぞ。

オブジェクト名とシート名がごっちゃになるとややこしいので、シート名はご覧のように変えています。

次に、それぞれのSheet1モジュールに次のようにコードを書く。

リスト１　Sheet1モジュール

'ち～んｗ１号.xlsmのSheet1モジュールです。'
Public Sub helloWorld()
  Debug.Print "Hello, World from １号！"
End Sub

リスト２　Sheet1モジュール

'ち～んｗ２号.xlsmのSheet1モジュールです。'
Public Sub helloWorld()
  Debug.Print "Hello, World from ２号！"
End Sub

超シンプルなメソッドをそれぞれのブックのSheet1モジュールに搭載。

ち～んｗ２号から呼び出しを試みる

まず、ち～んｗ２号.xlsmの標準モジュールから、ち～んｗ１号.xlsmのSheet1モジュールに搭載したhelloWorldメソッドを呼び出すことを試みる。

リスト３　ち～んｗ２号.xlsmの標準モジュール

Public Sub testCallSheetObjectProcedure()
  Dim anotherBook As Workbook
' ち～んｗ１号.xlsmを開いて変数にぶち込む'
  Set anotherBook =  _
        Workbooks.Open(ThisWorkbook.Path & "\ち～んｗ１号.xlsm")
' 「ち～んｗ１」シートを変数にぶち込む'
  Dim targetSheet As Worksheet
  Set targetSheet = anotherBook.Worksheets("ち～んｗ１")
' helloWorldメソッドを呼ぶ'
  Call targetSheet.helloWorld
' ち～んｗ１号.xlsmを閉じる'
  Call anotherBook.Close(SaveChanges:=False)
' オブジェクト変数の解放'
  Set anotherBook = Nothing
  Set targetSheet = Nothing
End Sub

コードの詳細はコメントをご覧くだされ。

こいつを実行しようとすると、

そもそもコンパイルが通らない。

Object型変数を使う

コードを修正する。

リスト４　ち～んｗ２号.xlsmの標準モジュール

Public Sub testCallSheetObjectProcedure()
  Dim anotherBook As Workbook
' ち～んｗ１号.xlsmを開いて変数にぶち込む'
  Set anotherBook =  _
        Workbooks.Open(ThisWorkbook.Path & "\ち～んｗ１号.xlsm")
' 「ち～んｗ１」シートを変数にぶち込む'
  Dim targetSheet As Object  '……(*)'
  Set targetSheet = anotherBook.Worksheets("ち～んｗ１")
' helloWorldメソッドを呼ぶ'
  Call targetSheet.helloWorld
' ち～んｗ１号.xlsmを閉じる'
  Call anotherBook.Close(SaveChanges:=False)
' オブジェクト変数の解放'
  Set anotherBook = Nothing
  Set targetSheet = Nothing
End Sub

変えたのは(*)のところだけ。

リスト３でWorksheet型にしていた変数をObject型に変えた。

こいつを実行すると、

意図どおりの結果が得られた。

おわりに

実にめんどくさい。

名づけて、「ダルマ落とし方式」！ (Word)

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

前回

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) 氏がすでにコメント欄に書いてくださっているので、ダルマ落とし風に見えるようにアレンジ。

準備

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

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

一番下のシェイプの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プロパティを設定し直すようにしている。

これが「ダルマ落とし」だ！

実行すると、

こうなります。まさに「ダルマ落とし」!!!!!!!!

おわりに

もちろん、作り込めば、もっとなめらかにアニメーションさせたりすることもできることでしょう。

Document内のテキストボックスを一掃すること能わず……(Word)

WordのDocument上からテキストボックスを一掃できない

やたらとテキストボックスがベタベタ貼り付けられた文書に出会った。

文章をコピペしようにも、巻き添えでテキストボックスが選択されてしまうのでうっとうしいことこの上ない。

で、マクロで一掃してやろうと思って次のコードを書いた。

文書内のシェイプを一掃する（はずの）コード

リスト１　標準モジュール

Public Sub removeAllShapes()
  Dim Doc As Document
  Set Doc = ActiveDocument
  Dim shp As Word.Shape
  For Each shp In Doc.Shapes
    Call shp.Delete
  Next
End Sub

文書内のShapeオブジェクトを総ナメして、Deleteメソッドで抹殺。

完璧なはずだ。

実行

このような文書を用意して、実行してみる。

ちなみに、実行前のシェイプの数は、

９個。

実行してみると……。

ぬな！？

シェイプが４個も残っとるやんけ。

おわりに

なんでやねん。

追記

コメント欄と併せ、コチラもどうぞ。

akashi-keirin.hatenablog.com

ルビと親文字の距離を調整するFunction(Word)

ルビと親文字の距離を調整するFucntion

ルビと親文字の距離を司るのは、

EQ \* jc4 \* "Font:ＭＳ 明朝" \* hps10 \o\ar(\s\up 10(ムーンサルト),月面宙返)

の中の

\s\up 10

の部分。

たとえば、

この状態のときのルビの設定は、

このとおり。

このときのフィールドコードが

EQ \* jc4 \* "Font:ＭＳ 明朝" \* hps10 \o\ar(\s\up 10(ムーンサルト),月面宙返)

んで、「オフセット」の値を

このように1増やして2にすると、フィールドコードは

EQ \* jc4 \* "Font:ＭＳ 明朝" \* hps10 \o\ar(\s\up 11(ムーンサルト),月面宙返)

になる。

いまいち仕組みがよくわからないが、とにかく\s\up 11のところの数字を増減させれば、ルビと親文字の位置関係を調整することができる。

コード

リスト１　標準モジュール

Private Function getShiftedOffsetSizeRubyFieldCodeText( _
                   ByVal targetFieldCodeText As String, _
                   ByVal shiftSize As Long) As String
  Dim ret As String
  ret = targetFieldCodeText
  ret = getRepairedFieldCodeText(ret)  '……(1)'
  Dim ar As Variant
  ar = Split(ret, "\") '"
  Dim tmp As String
  tmp = Split(ar(7))(1)  '……(2)'
  tmp = Split(tmp, "(")(0)
  tmp = Replace(ar(7), tmp, CStr(CLng(tmp) + shiftSize))
  ar(7) = tmp
  ret = getAssembledFieldCodeText(ar)  '……(3)'
  getShiftedOffsetSizeRubyFieldCodeText = ret
End Function

(1)の

ret = getRepairedFieldCodeText(ret)

は、このシリーズではすでにおなじみの自作FunctiongetRepairedFieldCodeText（【参考】）を用いて、引数で受け取ったフィールドコード文字列を必要に応じて整形。

今回の目玉は、(2)からの３行

tmp = Split(ar(7))(1)
tmp = Split(tmp, "(")(0)
tmp = Replace(ar(7), tmp, CStr(CLng(tmp) + shiftSize))

ここがちょっとややこしい。

先に

ar = Split(ret, "\") '"

としてあるので、たとえばretに入っているフィールドコード文字列が、先に紹介した

EQ \* jc4 \* "Font:ＭＳ 明朝" \* hps10 \o\ar(\s\up 10(ムーンサルト),月面宙返)

である場合、ar(7)の値は、

up 10(ムーンサルト),月面宙返)

になる。

たとえば、引数shiftSizeが1だったとしたら、up 10(ムーンサルト),月面宙返)の「10」を「11」に変えたいわけなのだ。

そのために、まず、変数tmpを用意して、そこに

Split(ar(7))(1)

の値を入れる。

第２引数を省略してSplit関数を用いると、半角スペースが区切り文字になるので、インデックス番号1の要素は10(ムーンサルト),月面宙返)になるはず。

そこで、一旦こいつをtmpにぶち込んでおいて、さらに

tmp = Split(tmp, "(")(0)

を実行する。今度は、「(」を区切り文字にしてSplit関数を用いる。

できた配列のインデックス番号0の要素は、先頭の数字（今回の例だと10）になるはず。

これで、tmpには、現在の数値が入っているので、あとは、

tmp = Replace(ar(7), tmp, CStr(CLng(tmp) + shiftSize))

で、Replace関数を用いて、現在のtmpをtmpにshiftSizeを加えた数値（を文字列にキャストしたもの）で置き換える。

めんどくせーなｗ

最後に、これまたおなじみの自作FunctiongetAssembledFieldCodeText（【参考】）でフィールドコード文字列を組み立て直してreturn。

使ってみる

この状態（「オフセット」値は「1」）で、次のコードを実行してみる。

リスト２　標準モジュール

Public Sub test01()
  Dim targetField As Field
  For Each targetField In Selection.Fields
    With targetField
      Dim str As String
      If .Type = wdFieldFormula And _
         (InStr(1, .Code.Text, "\s\up") > 0 Or _
          InStr(1, .Code.Text, "\s\do") > 0) Then
        .Code.Text = getShiftedOffsetSizeRubyFieldCodeText(.Code.Text, 1)
      End If
    End With
  Next
End Sub

オフセット値を1プラスするコード。

実行すると、

こうなる。ちょっとわかりづらいけれど、ルビの設定を確認すると、

ちゃんと「オフセット値」が「2」になっている。

おわりに

実は、フィールドコードの「\s\up 11」の「\up」の部分を「\do」に変えて、数字をマイナスにすると、うまくやれば下付のルビにもできたりするのだが、数字の調整のしかたがよくわからない。

このあたりは今後の課題。フィールドコード自体の理解を深める必要があるのかも。

参考

akashi-keirin.hatenablog.com

akashi-keirin.hatenablog.com

akashi-keirin.hatenablog.com

akashi-keirin.hatenablog.com

繰り返しを伴う処理をまとめる

フィールドコード総ナメ方式のプロシージャをまとめる

前回までの３回

akashi-keirin.hatenablog.com

akashi-keirin.hatenablog.com

akashi-keirin.hatenablog.com

で紹介したFunctionを使って、選択範囲のフィールドコードを総当たりで処理するプロシージャを作ってみた。

たとえば、ルビの割り付け位置を設定するgetConvertedAlignmentRubyFieldCodeTextの場合だと、次のようなものになる。

リスト１　標準モジュール

Private Sub changeSelectionRubiesalign( _
             ByVal targetSelection As Selection, _
             ByVal targetAlignCode As AlignCode)    '……(1)'
On Error GoTo Finalizer
  Application.ScreenUpdating = False
  Dim orgRange As Range
  Set orgRange = targetSelection.Range
  Dim targetField As Field
  For Each targetField In orgRange.Fields
    With targetField
      If .Type = wdFieldFormula And _
         (InStr(1, .Code.Text, "\s\up") > 0 Or _
          InStr(1, .Code.Text, "\s\do") > 0) Then
        .Code.Text = _
          getConvertedAlignmentRubyFieldCodeText(.Code.Text, _
                                                 targetAlignCode)  '……(2)'
      End If
    End With
  Next
Finalizer:
  Application.ScreenUpdating = True
End Sub

全てのフィールドコードを総当たりで調べて、ルビに関するフィールドコードだったらgetConvertedAlignmentRubyFieldCodeTextで書き換えたフィールドコード文字列を取得して、Field.Code.Textプロパティを書き換える。

上記の例は、ルビの割り付けに関するものだが、これをルビのサイズとか、ルビのフォントの種類を変更するものに変えようとすると、変更箇所はわづかにリスト内の(1)と(2)の箇所だけである。

コピペして(1)と(2)の箇所だけ書き換えたプロシージャを作っても良いが、それではモジュール内の見通しが悪くなってしまう。

そこで、繰り返し処理の部分は共通化してしまうことを考えた。

繰り返し処理部分を共通化したコード

リスト２　標準モジュール宣言セクション

まずは、列挙体と定数。

'Enums'
Public Enum AlignCode
  acAlignCenter = 0     '中央揃え'
  acAlignDistribution1  '均等割付1'
  acAlignDistribution2  '均等割付2'
  acAlignLeft           '左揃え'
  acAlignRight          '右揃え'
End Enum

Private Enum SettingCode
  scAlign
  scFontSize
  scFontName
End Enum

'Constants'
Private Const MAX_RUBY_SIZE As Single = 20
Private Const STANDARD_RUBY_FONT As String = "ＭＳ 明朝"

外部から呼び出すときに使う必要性が生じるので、AlignCodeについてはPublic指定に変更。

リスト３　標準モジュール

Private Sub changeSelectionRubiesSetting( _
             ByVal targetSelection As Selection, _
             ByVal targetArg As Variant, _
             ByVal settingType As SettingCode)  '……(3)'
On Error GoTo Finalizer
  Application.ScreenUpdating = False
  Dim orgRange As Range
  Set orgRange = targetSelection.Range
  Dim targetField As Field
  For Each targetField In orgRange.Fields
    With targetField
      If .Type = wdFieldFormula And _
         (InStr(1, .Code.Text, "\s\up") > 0 Or _
          InStr(1, .Code.Text, "\s\do") > 0) Then
        .Code.Text = getRubiesSettingFieldCodeText(.Code.Text, _
                                                   targetArg, _
                                                   settingType)  '……(4)'
      End If
    End With
  Next
Finalizer:
  Application.ScreenUpdating = True
End Sub

Private Function getRubiesSettingFieldCodeText( _
                   ByVal fieldCodeText As String, _
                   ByVal receiptArg As Variant, _
                   ByVal settingType As SettingCode) As String
On Error GoTo Finalizer
  Dim ret As String
  ret = fieldCodeText
  Select Case settingType    '……(5)'
    Case scAlign
      ret = getConvertedAlignmentRubyFieldCodeText( _
                              fieldCodeText, CInt(receiptArg))
    Case scFontSize:
      ret = getChangedRubySizeFieldCodeText( _
                              fieldCodeText, CSng(receiptArg))
    Case scFontName:
      ret = getChangedRubyFontNameFieldCodeText( _
                              fieldCodeText, CStr(receiptArg))
  End Select
Finalizer:
  getRubiesSettingFieldCodeText = ret
End Function

上段のchangeSelectionRubiesSettingが３メソッド共通の入り口。

(3)の

Private Sub changeSelectionRubiesSetting( _
             ByVal targetSelection As Selection, _
             ByVal targetArg As Variant, _
             ByVal settingType As SettingCode)

を見ればおわかりのように、第３引数targetArgでどんな種類の引数でも受け取れるようにしておき、第４引数のsettingTypeでどの処理を呼び出すのかを指定する。

今回は引数チェックのガード節はまだ追加していない。

(4)の

 .Code.Text = getRubiesSettingFieldCodeText(.Code.Text, _
                                            targetArg, _
                                            settingType)

まで来たら、下段のgetRubiesSettingFieldCodeTextメソッドを呼び出す。

getRubiesSettingFieldCodeTextメソッド内では、(5)の

Select Case settingType
  Case scAlign
    ret = getConvertedAlignmentRubyFieldCodeText( _
                            fieldCodeText, CInt(receiptArg))
  Case scFontSize:
    ret = getChangedRubySizeFieldCodeText( _
                            fieldCodeText, CSng(receiptArg))
  Case scFontName:
    ret = getChangedRubyFontNameFieldCodeText( _
                            fieldCodeText, CStr(receiptArg))
End Select

で、引数settingTypeの値に応じて、getConvertedAlignmentRubyFieldCodeText、getChangedRubySizeFieldCodeText、getChangedRubyFontNameFieldCodeTextのうちいづれかを呼び出してフィールドコード文字列を得る。（以上３メソッドのコードについては、下のリスト５に再掲します。）

必要ないかも知れないけれど、Variantで受け取った引数receiptArgは、一応キャストして各メソッドに渡すようにしている。

使ってみる

次のような呼び出し用プロシージャで利用する。

リスト４－１　標準モジュール

'///選択範囲のルビ割付を一括変換'
Public Sub changeSelectionRubiesAlign(ByVal targetAlignCode As AlignCode)
  Call changeSelectionRubiesSetting(Selection, _
                                    targetAlignCode, _
                                    scAlign)
End Sub
'///選択範囲のルビサイズを一括変換'
Public Sub changeSelectionRubiesSize(ByVal targetSize As Single)
  Call changeSelectionRubiesSetting(Selection, _
                                    targetSize, _
                                    scFontSize)
End Sub
'///選択範囲のルビのフォントを一括変換'
Public Sub changeSelectionRubiesFontName(ByVal targetFontName As String)
  Call changeSelectionRubiesSetting(Selection, _
                                    targetFontName, _
                                    scFontName)
End Sub

おわりに

こんな風に動作します。

参考

リスト５　標準モジュール

'///ルビの割り付け位置を変更する'
Private Function getConvertedAlignmentRubyFieldCodeText( _
                   ByVal targetFieldCodeText As String, _
                   ByVal targetAlignCode As AlignCode) As String
  Dim ret As String
  ret = targetFieldCodeText
  If targetAlignCode < 0 Or _
     targetAlignCode > 4 Then GoTo Finalizer
  ret = getRepairedFieldCodeText(ret)
  Dim alignSetting1 As String
  Dim alignSetting2 As String
  Select Case targetAlignCode
    Case acAlignCenter
      alignSetting1 = "* jc0 ": alignSetting2 = "ac("
    Case acAlignDistribution1
      alignSetting1 = "* jc1 ": alignSetting2 = "ad("
    Case acAlignDistribution2
      alignSetting1 = "* jc2 ": alignSetting2 = "ad("
    Case acAlignLeft
      alignSetting1 = "* jc3 ": alignSetting2 = "al("
    Case acAlignRight
      alignSetting1 = "* jc4 ": alignSetting2 = "ar("
  End Select
  Dim ar As Variant
  ar = Split(ret, "\")    '"
  ar(1) = alignSetting1
  ar(5) = alignSetting2
  ret = getAssembledFieldCodeText(ar)
Finalizer:
  getConvertedAlignmentRubyFieldCodeText = ret
End Function

'///ルビのサイズを変更する'
Private Function getChangedRubySizeFieldCodeText( _
                   ByVal targetFieldCodeText As String, _
                   ByVal targetSize As Single) As String
  Dim ret As String
  ret = targetFieldCodeText
  If targetSize > MAX_RUBY_SIZE Then GoTo Finalizer
  ret = getRepairedFieldCodeText(ret)
  Dim ar As Variant
  ar = Split(targetFieldCodeText, "\") '"
  ar(3) = "* hps" & targetSize * 2
  ret = getAssembledFieldCodeText(ar)
Finalizer:
  getChangedRubySizeFieldCodeText = ret
End Function

'///ルビのフォントの種類を変更する'
Private Function getChangedRubyFontNameFieldCodeText( _
                   ByVal targetFieldCodeText As String, _
          Optional ByVal targetFontName As String = STANDARD_RUBY_FONT) As String
  Dim ret As String
  ret = targetFieldCodeText
  ret = getRepairedFieldCodeText(ret)
  Dim ar As Variant
  ar = Split(ret, "\")  '"
  ar(2) = "* " & """Font:" & targetFontName & """"
  ret = getAssembledFieldCodeText(ar)
Finalizer:
  getChangedRubyFontNameFieldCodeText = ret
End Function

'///SplitでバラしたFieldCodeを元通りにする'
Private Function getAssembledFieldCodeText( _
                   ByRef splitFieldCode As Variant) As String
  Dim i As Long
  Dim ret As String
  For i = LBound(splitFieldCode) To UBound(splitFieldCode)
    ret = ret & splitFieldCode(i) & "\"  '"
  Next
  ret = Left(ret, Len(ret) - 1)
  getAssembledFieldCodeText = ret
End Function

'///手動で「中央揃え」にしたときのスイッチ省略への対応'
Private Function getRepairedFieldCodeText( _
                   ByVal targetFieldCodeText) As String
  Dim ret As String
  ret = targetFieldCodeText
  Dim ar As Variant
  ar = Split(ret, "\")  '"
  'インデックスの最大値が「7」だったら、省略されていない。'
  If UBound(ar) = 7 Then GoTo Finalizer
  '省略を補う処理'
  ReDim Preserve ar(7)
  ar(7) = ar(6)
  ar(6) = ar(5)
  ar(5) = "ac("
  ar(4) = "o"
  '手動で「中央揃え」にした後だと、 ar(4) の値が"o("になるときがある。'
  ret = getAssembledFieldCodeText(ar)
Finalizer:
  getRepairedFieldCodeText = ret
End Function

akashi-keirin.hatenablog.com

akashi-keirin.hatenablog.com

akashi-keirin.hatenablog.com

akashi-keirin.hatenablog.com