【フォントも】あくあ角【PCも自作が基本】

'オブジェクトの相対位置を維持したまま連続で拡大・縮小するマクロです。
'シフトJISまたはユニコードで指定した範囲の文字に対して処理します。
'演算が多く処理が重いため、相当な時間を要します。
'倍率の小数点以下の桁数は任意で何桁でも可能ですが、２桁もあれば十分と思われます。

Option Explicit
Const ERRNUM_STOPMACRO = 3000'マクロ中止時のエラー番号
Const ERRNUM_INVALIDCODE = 2006'無効文字のエラー番号

Sub Main()
Dim StartCode'開始ユニコード
Dim EndCode '終了ユニコード
Dim Doc 'TTEditのDocumentオブジェクト
Dim code'編集対象ユニコード
Dim total'輪郭点数
Dim x
Dim y
Dim flags
Dim i
Dim ZoomX
Dim ZoomY
Dim SizeW
Dim SizeH
Dim OffsetX
Dim OffsetY
Dim OffsetYsub

'>>初期設定〜
'*********************************************
'適時行頭のコメントアウトを入れ替える。
'必ず63〜64行目と合わせること。
'*********************************************
StartCode = &H0020& '開始ユニコード
EndCode = &Hffff& '終了ユニコード
'---------------------------------------------
'StartCode = &H8140& '開始シフトJISコード
'EndCode = &HFFFF& '終了シフトJISコード
'*********************************************

ZoomX = 1.0 'Ｘ軸の倍率設定（ 1 = 100% とする ）※拡大なら1.20、縮小なら0.80などで小数点以下は任意の桁数
ZoomY = 1.0 'Ｙ軸の倍率設定（ 1 = 100% とする ）
OffsetYsub = 0 'Ｙ軸に任意の値で固定のオフセットを与える（ '0' で無効 ）

'〜初期設定ここまで

'>>メイン処理

Set Doc = Application.ActiveDocument
If Doc Is Nothing Then
MsgBox "TTEditでフォントファイルがオープンされていません", vbExclamation
Exit Sub
End If

For code = StartCode To EndCode
Err.Clear
On Error Resume Next

'**********************************************************************************************
'適時行頭のコメントアウトを入れ替える（ 必ず33〜37行目の開始・終了の文字コードと合わせること ）
'**********************************************************************************************
'Doc.SetCode 0, code, False'編集する文字コードを設定（ 0=シフトJIS , 1=JIS , 2=Unicode ）
Doc.SetCode 2, code, False'編集する文字コードを設定（ 0=シフトJIS , 1=JIS , 2=Unicode ）
'**********************************************************************************************

If Err.Number = ERRNUM_STOPMACRO Then'マクロ中止ボタン
Exit For
End If

If Err.Number = 0 Then
SizeW = Doc.Width'変更前の文字幅を取得
SizeH = Doc.Ascent + Doc.Descent'変更前の文字高さ（ アセント＋ディセントの合計を文字高さとする ）
OffsetX = ( SizeW - ( SizeW * ZoomX ) ) / 2'Ｘ軸オフセット
OffsetY = ( SizeH - ( SizeH * ZoomY ) ) / 2'Ｙ軸オフセット

On Error Goto 0

total = Doc.TotalPoint

For i = 0 To total -1
Doc.GetPoint2 i, x, y, flags
'*****************************************************************************************************************************
'Doc.MovePoint i, ( x * ZoomX ) + OffsetX, ( y * ZoomY ) + OffsetY + OffsetYsub'Ｘ軸、Ｙ軸ともセンタリングする場合はこちら
Doc.MovePoint i, ( x * ZoomX ) + OffsetX, ( y * ZoomY ) + OffsetYsub'Ｙ軸をベースライン基準で合わせる場合はこちら
'*****************************************************************************************************************************
Next
Else
If Err.Number <> ERRNUM_INVALIDCODE Then
msg = "エラー番号" & CStr(Err.Number) & " " & Err.Description
MsgBox msg
Exit For
End If
End If
Next
End Sub