繰り返しを伴う処理をまとめる - 素人がExcelVBAによる「一人働き方改革」に挑むブログ

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

前回までの３回

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

おわりに

f:id:akashi_keirin:20190202135803g:plain

こんな風に動作します。

参考

リスト５　標準モジュール

'///ルビの割り付け位置を変更する'
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