LoginSignup
0

More than 5 years have passed since last update.

Publisher VBA 4桁の年度末 年末 年始に必要な西暦を1年ずらすマクロ フィールド内の2ケタの和暦をずらすマクロ

Posted at

#参照設定

VBScript Regular Expression Version 5.5 laterを参照設定してください
#コード
このコードは西暦がフィールドに入っているときはべつのアプローチが必要です。
縦書き中の横書きの西暦はフィールドになります。
Publiserhなどで様式を作っていて、4桁の年数があります。
その年数をしらべあげ、最大の年数から変換していきます。

フィールドは TextboxfieldChangeGrp2

これは29を30にする例です。
テキストボックスはグループ化しているとShapeGroupに入っていますが、見た目ではわかりません。
そこでエラー判定を利用し、エラーが起きたら単なるテキストボックスとして修正します。
いまのところ、1度起動すると1度しか変換しません。


'You need VBScript Regular Expression 5.5 Later Reference Setting
Sub take4digitstring()
'西暦と思われる4桁の数字を抜き出す

Dim Pg As Page
Dim s As Shape
Dim tF As TextFrame, tR As TextRange
Dim M, MC As MatchCollection, SMc As SubMatches
Dim i As Long, ar()
For Each Pg In ThisDocument.Pages
For Each s In Pg.Shapes
If s.HasTextFrame Then Set tR = s.TextFrame.TextRange
buf = buf & tR.Text
Next s
Next Pg
With CreateObject("VbScript.RegExp")
.Pattern = "[1-9]{1}[0-9]{3}"
.Global = True
.Multiline = True
Set MC = .Execute(buf)
End With
For i = 0 To MC.Count - 1
ReDim Preserve ar(0 To i)
ar(i) = MC.Item(i).Value
Next i
ar = InsertionSort(ar, 0, UBound(ar))
For i = UBound(ar) To 0 Step -1
Call ReplacewithtextCustom (CStr(ar(i)))

Next i

End Sub

Function InsertionSort(ByRef data As Variant, ByVal low As Long, ByVal high As Long)
'https://www.tipsfound.com/vba/02020 Data Temp は型をLongに合わせると早くなる
Dim i As Variant
Dim k As Variant
Dim temp As Variant
For i = low + 1 To high
temp = data(i)
If data(i - 1) > temp Then
k = i

Do While k > low
If data(k - 1) <= temp Then
Exit Do
End If

data(k) = data(k - 1)
k = k - 1
Loop

data(k) = temp
End If
Next
InsertionSort = data
End Function

Sub ReplacewithtextCustom(strSource As String)
'西暦の4桁の最大値から1つたして全文を変換する
With ActiveDocument.Find
.Clear '検索条件のクリア
.FindText = strSource
.ReplaceWithText = CLng(strSource) + 1
.MatchWholeWord = True
.ReplaceScope = pbReplaceScopeAll 'すべて置換
.Execute
End With
End Sub


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
On Error Resume Next
Set GShps = sRng.GroupItems
If Err.Number <> 0 Then Call TextboxfieldChange 'Groupでない場合にはシングル変換する
i = 0
For Each shp In GShps
ReDim Preserve arShp(0 To i)
Set arShp(i) = shp
If shp.HasTextFrame = True Then
If shp.TextFrame.TextRange.Fields.Count > 0 Then Exit For
End If
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 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
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個に限定。

If fld.TextRange.Text Like "*" & cnsStrSource & "*" Then 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

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
0