たぶん全世界初
検索しても見つからないので。まあコンマじゃない国もあるし（ドイツが確か上）Publisher自体マイナーなので。
Word に続いて
Word VBA 数字をコンマ付き数字に変えるマクロ
が出来たので、これをPublsherに移植してみました。
いまのところ、単純な整数のみです。
というかここに来るまでが大変でしたけど。
Sub Insertcommas()
'For Publisher
'Microsoft VBScript Regular Expression 5.5 Laterを参照設定してください。
Dim pbDoc As Publisher.Document: Set pbDoc = ThisDocument
Dim pbPage As Publisher.Page, pbPages As Publisher.Pages
Dim shps As Publisher.Shapes, Shp As Publisher.Shape
Dim i As Long, i1 As Long, i2 As Long, iLength As Long
Dim tFrame As TextFrame, pbStories As Publisher.Stories, pbStory As Publisher.Story
Dim tRn1 As TextRange, tRng As Publisher.TextRange, tRn1sub As TextRange
Dim str As String
Set pbStories = pbDoc.Stories
For Each pbStory In pbStories
If pbStory.HasTextFrame Then
Set tFrame = pbStory.TextFrame
Set tRng = tFrame.TextRange
iLength = tRng.Length
For i = iLength To 1 Step -1
Set tRn1 = tRng.Characters(Start:=i, Length:=1)
If IsNumericString(tRn1.Text) Then
str = ""
str = tRn1.Text
For i1 = i - 1 To 1 Step -1
Set tRn1sub = tRng.Characters(Start:=i1, Length:=1)
If IsNumericString(tRn1sub.Text) Then
str = tRn1sub.Text & str
Else
If Len(str) > 3 Then
Call StringInsertcommma(i, iLength, i1, tRng, str)
Exit For
Else
Exit For
End If
End If
Next i1
End If 'If IsNumericString(tRn1.Text) Then
Next
End If 'If pbStory.HasTextFrame Then
Next 'For Each pbStory In pbStories
End Sub
Sub StringInsertcommma(i As Long, iLength As Long, i1 As Long, tRng As TextRange, str As String)
Dim re As RegExp: Set re = New RegExp
Dim iDigi As Long
Dim tRna As TextRange
Dim tRNext As TextRange
Dim tRPrev As TextRange
Dim icommas As Long
Dim icnt As Long, icnt1 As Long
Dim buf As String
Dim rngFind As TextRange
Set tRna = tRng.Characters(Start:=i1 + 1, Length:=i - i1)
If tRna.Length <= 3 Then
icommas = 1
Else
icommas = Int(tRna.Length / 3) - 1
If tRna.Length Mod 3 <> 0 Then
icommas = icommas + 1
End If
End If
buf = ""
icnt1 = 1
For icnt = Len(str) To 1 Step -1
If icnt1 Mod 3 <> 0 Then
buf = Mid(str, icnt, 1) & buf
Else
buf = "," & Mid(str, icnt, 1) & buf
End If
icnt1 = icnt1 + 1
Next icnt
If Mid(buf, 1, 1) = "," Then buf = Replace(buf, ",", "", 1, 1, vbTextCompare)
With tRna.Find
.ReplaceScope = pbReplaceScopeOne
.FindText = str
.ReplaceWithText = buf
.Execute
End With
Set re = Nothing
End Sub
Function IsNumericString(str As String) As Boolean
Dim re As RegExp: Set re = New RegExp
With re
.Pattern = "[0-9]"
.Global = True
.IgnoreCase = False
.Multiline = False
If .Test(str) Then IsNumericString = True Else IsNumericString = False
End With
Set re = Nothing
End Function
ポイント
- VBScript Regular Expression 5.5を参照設定してください。
- ほぼすべてのテキストレンジを取得するにはActiveDocument.Storiesを使う。
- この場合、全ページのテキストレンジを扱える。
- 各テキストレンジの最後から順にテキストレンジを動かして数字ではないところでいったん変換する。
- 変換文字列(コンマ入り数字)を作ってからReplaceする。中途半端にテキストレンジを動かすと例外処理でおかしくなる。
- 現在のところ半角数字のみ。年などの例外処理はない。（あとから追加する予定）
- ワイルドカードがないのがWordと違う点。（参照設定をしないと正規表現が使えない）
確認されている問題
- 現在のところ1行目の1文字目から始まる数字が変換できません。なぜか2行目までテキストレンジが広がっていて、調べています。