[Publisher VBA] 全世界史上初公開 縦中横にした和暦の年を書き換えて縦中横にする β

下準備 Startキットを別モジュール及びThisDocumentにいれてください。

ThisDocumentは必ずしもいらないのですが、どこで作ったかは分かるので…
Publisher VBA Startセット(1) Typeステートメントと関数
Publisher VBA Startセット(2) Startセット
Publisher VBA Startセット(3) PropertySearch 調査セット

以前

Publisher VBA 縦中横 を実行して数字を並べるマクロ
というのを作りました。
しかし、このように縦中横にした数字は置換できませんでした。
しかし選択したテキストボックス（グループシェイプを含む場合も含む）の縦中横の数字も書き換えたいものです。

今回

平成29となっているテキストボックスを選択します。
Publisherの中ではShapeです
イメージはこんな感じです。コクヨのフラットファイルをイメージしました。

Publisherで作成すると「縦中横」を使って縦書きに横書きの数字を入れることができます。
しかし、このとき、縦中横で横書きになった数字は実はテキストボックスの中のFieldになっています。
テキストで見ると 平成?29?年のように表示されます。
これをオートで変換するにはどうすればよいのか。
エラーが出るのでOn Errorで回避したベータバージョンです。
まだ完全には変換できません。
仕組みはこうです。
まず平成２９年などと表示されているテキストボックスを選択します。
これで下記のプロシージャを実行します。
そしてテキスト範囲の中に数字を見出し、30に変えます。
これでもそこそこ便利です。
だがfieldが消えて、縦中横が解除されます。
しかし、そこからさらに、正規表現で数字の位置を割り出し、からのテキスト範囲を作り、それに入力します。

vb.net

Sub TextboxfieldChange()
'for Publisher
'Beta Version
Dim pDoc As Publisher.Document: Set pDoc = ThisDocument
Dim pPage As Publisher.Page
Dim sRng As Publisher.ShapeRange
Dim sel As Selection
Dim shp As Shape
Dim tFrame As TextFrame, tRng As TextRange, tRngTmp As TextRange
Dim fld As Publisher.Field
Dim Reg As RegExp: Set Reg = New RegExp
Dim buf As String, pbStry As Publisher.Story, pbStrys As Publisher.Stories
Dim iStat As Long, iEnd As Long '文字位置
Dim M As Match, MC As MatchCollection, SMs As SubMatches
Dim fldTmp As TextRange
Dim yRng As TextRange
Set sel = Selection
Set sRng = sel.ShapeRange 'Point Selectionの中身はShapeRangeなのでShapeには一呼吸置かなければならない
Set shp = sRng.Item(1) 'ItemとしてShapeをつかむ。
If shp.HasTextFrame Then
Set tFrame = shp.TextFrame
If tFrame.TextRange.Fields.Count > 0 Then
Set fld = tFrame.TextRange.Fields(1) '対象となるフィールドは1個に限定。

fld.TextRange.Text = 30
With Reg
.Global = True
.Multiline = True
.IgnoreCase = False
.Pattern = "[0-9]{2}"
buf = tFrame.TextRange.Text 'テキスト範囲の文字列を取得
Set MC = .Execute(buf) '年を探す
Set M = MC(0) '1個だけ選択
iStat = M.FirstIndex + 1
Set fld = Nothing 'Fieldがなくなったので開放する
Set tRngTmp = tFrame.TextRange.Characters(M.FirstIndex + 1, 2)
Set yRng = tRngTmp.InsertAfter("") '平成の末尾に空のRangeを作る
On Error Resume Next
'空のTextRangeにFieldを追加する
Set fldTmp = yRng.Fields.AddHorizontalInVertical(Range:=tRngTmp.InsertAfter("30"), Text:="30") 'この表記はエラーになるので改善が必要
tRngTmp.Delete
Selection.Unselect '選択を解除
End With
End If
End If
End Sub

GoupItem対応版

ShapeRangeがGropeShapesだった場合、上記のコードは失敗します。
そこでGroupItemの場合

1. Set shp = sRng.Item(1) 'ItemとしてShapeをつかむ。は必ずしも対象のテキストボックスではないので失敗する
2. そこでGroupShapesの場合、中のShapeをFor Eachで回し、テキスト枠とフィールドがあればExitして変換する。
3. 何回か稼働させると、2桁の縦中横はすべて30になる。
4. 稼働させすぎ注意（たとえばグループ化されたシェイプ(テキストボックス)に住所と平成30年が混在しているようなとき)

vb.net

Sub TextboxfieldChangeGrp()
Const cnsStrSource = "29" , cnsStrDistination = "30"
Dim pDoc As Publisher.Document: Set pDoc = ThisDocument
Dim pPage As Publisher.Page
Dim sRng As Publisher.ShapeRange
Dim sel As Selection
Dim shp As Shape
Dim tFrame As TextFrame, tRng As TextRange, tRngTmp As TextRange
Dim fld As Publisher.Field
Dim Reg As RegExp: Set Reg = New RegExp
Dim buf As String, pbStry As Publisher.Story, pbStrys As Publisher.Stories
Dim iStat As Long, iEnd As Long '文字位置
Dim M As Match, MC As MatchCollection, SMs As SubMatches
Dim fldTmp As TextRange
Dim yRng As TextRange
Dim GShps As GroupShapes
Dim arShp(), i As Long
Dim arStr As String
Set sel = Selection
Set sRng = sel.ShapeRange
Set GShps = sRng.GroupItems
i = 0
For Each shp In GShps
ReDim Preserve arShp(0 To i)
Set arShp(i) = shp
If shp.HasTextFrame = msoTrue And shp.TextFrame.TextRange.Fields.Count > 0 Then Exit For
Next
Debug.Print arStr
If shp.HasTextFrame Then
Set tFrame = shp.TextFrame
If tFrame.TextRange.Fields.Count > 0 Then
Set fld = tFrame.TextRange.Fields(1)
fld.TextRange.Text = cnsStrDistination
With Reg
.Global = True
.Multiline = True
.IgnoreCase = False
.Pattern = "[0-9]{2}"'平成29を想定している
buf = tFrame.TextRange.Text
Set MC = .Execute(buf)
Set M = MC(0) '平成29を想定しているため、最初のマッチにしている。本当はここもループさせる必要がありそう
iStat = M.FirstIndex + 1: iEnd = M.FirstIndex + 2
Set fld = Nothing
Set tRngTmp = tFrame.TextRange.Characters(M.FirstIndex + 1, 2)
Set yRng = tRngTmp.InsertAfter("")
On Error Resume Next
Set fldTmp = yRng.Fields.AddHorizontalInVertical(Range:=tRngTmp.InsertAfter(cnsStrDistination), Text:= cnsStrDistination)
tRngTmp.Delete
Selection.Unselect
End With
End If
End If
End Sub

GropShapesのコレクションで29を30に変える

vb.net

Sub TextboxfieldChangeGrp2()

Const cnsStrSource = 29 , cnsStrDistination = 30
Dim pDoc As Publisher.Document: Set pDoc = ThisDocument
Dim pPage As Publisher.Page
Dim sRng As Publisher.ShapeRange
Dim sel As Selection
Dim shp As Shape
Dim tFrame As TextFrame, tRng As TextRange, tRngTmp As TextRange
Dim fld As Publisher.Field
Dim Reg As RegExp: Set Reg = New RegExp
Dim buf As String, pbStry As Publisher.Story, pbStrys As Publisher.Stories
Dim iStat As Long, iEnd As Long '文字位置
Dim M As Match, MC As MatchCollection, SMs As SubMatches
Dim fldTmp As TextRange
Dim yRng As TextRange
Dim GShps As GroupShapes
Dim arShp(), i As Long
Dim arStr As String
Set sel = Selection
Set sRng = sel.ShapeRange
Set GShps = sRng.GroupItems
i = 0
For Each shp In GShps
ReDim Preserve arShp(0 To i)
Set arShp(i) = shp
If shp.HasTextFrame = msoTrue And shp.TextFrame.TextRange.Fields.Count > 0 Then Exit For
Next
Debug.Print arStr 'せっかくなのでグループ化している図形の名前をイミディエイトウィンドウに出力

For Each shp In GShps
If shp.HasTextFrame Then
Set tFrame = shp.TextFrame
If tFrame.TextRange.Fields.Count > 0 Then
For i = 1 To tFrame.TextRange.Fields.Count
Set fld = tFrame.TextRange.Fields(i)
Debug.Print fld.TextRange.Text
If fld.TextRange.Text Like "*" & cnsStrSource & "*" Then 'ここを=29だと失敗する?29?なのでLikeにする
fld.TextRange.Text = cnsStrDistination
With Reg
.Global = True
.Multiline = True
.IgnoreCase = False
.Pattern = "[0-9]{2}" '平成29などを想定しているため、数字2桁を探す
buf = tFrame.TextRange.Text
Set MC = .Execute(buf)
Set M = MC(0) '平成29を想定しているため、最初のマッチにしている。本当はここもループさせる必要がありそう
iStat = M.FirstIndex + 1
Set fld = Nothing
Set stry = tFrame.TextRange.Story
Set tRngTmp = tFrame.TextRange.Characters(M.FirstIndex + 1, 2)
Set yRng = tRngTmp.InsertAfter("")
yRng.Fields.AddHorizontalInVertical Range:=tRngTmp.InsertAfter(cnsStrDistination), Text:= cnsStrDistination
tRngTmp.Delete
End With
End If
Next i
End If
End If
Next shp
Selection.Unselect '変換を連続させない。矢印キーを押して図形が動かないようにする。という目的でセレクションを解除する。
End Sub