Word ルビ振りマクロ
下にスクロールして、コードをコピーして使ってください。
[手順]
Wordファイルを開く
Alt + F11 で、VBAエディタを開く
［挿入］→［標準モジュール］
出てきた Module1 などに、以下のVBAコードをコピーして貼り付ける
Word画面に戻る → Alt + F8
実行したいマクロ名を選択 → ［実行］（最後にチェック＆微調整）
ルビマクロ 簡易ガイド
① Word標準ルビ（横書き文書用）
| マクロ名 | 機能 |
|---|---|
| ルビ01_選択範囲に標準ルビをふる | 選択範囲のすべての対象に標準ルビ |
| ルビ02_全文に標準ルビをふる | 文書全体に標準ルビ |
| ルビ03_選択範囲の初出のみ標準ルビ | 選択範囲で、同じ漢字・漢字列は最初の1回だけ |
| ルビ04_全文に初出のみ標準ルビ | 文書全体で、同じ漢字・漢字列は最初の1回だけ |
② テキストボックス型ルビ（国語などの縦書き文書用）
Word標準ルビで行間などのレイアウトを変えたくない場合に使う方式です。 元の文字の近くに、小さなテキストボックスとしてルビを配置します。
| マクロ名 | 機能 |
|---|---|
| ルビ11_選択範囲に縦書きルビ用テキストボックス | 選択範囲のすべての対象に付ける |
| ルビ12_全文に縦書きルビ用テキストボックス | 文書全体に付ける |
| ルビ13_選択範囲に初出のみ縦書きルビ用テキストボックス | 選択範囲で、同じ漢字・漢字列は最初の1回だけ |
| ルビ14_全文に初出のみ縦書きルビ用テキストボックス | 文書全体で、同じ漢字・漢字列は最初の1回だけ |
| ルビ15_選択範囲に古文縦書きルビ用テキストボックス | 選択範囲に古文読みを優先して付ける |
使用上の注意
- 実行前にWordファイルをコピーしてバックアップしてください。
- テキストボックス型はファイルが重くなるため、 印刷用にコピーしたWordファイルでの使用を推奨します。
- 縦書きルビのテキストボックス型は処理が遅いため、 複数ページは1ページずつファイルを分割して、同時に複数ファイルで実行するのがおすすめです。
- 人名・地名・専門用語などは誤読することがあります。 印刷前に目視確認してください。
VBA
Option Explicit
'============================================================
' 安全中断用（Escキー監視）
'
' wdDialogPhoneticGuide.Show(1) の 1 は TimeOut 指定であり、
' ダイアログの戻り値 0 をそのまま『ユーザーがCancelした』と
' 判定すると自動タイムアウトと衝突する可能性がある。
' そのため、処理中断はWindowsのEscキー状態を直接監視する。
'============================================================
#If VBA7 Then
Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" ( _
ByVal vKey As Long) As Integer
#Else
Private Declare Function GetAsyncKeyState Lib "user32" ( _
ByVal vKey As Long) As Integer
#End If
Private Const RUBY_VK_ESCAPE As Long = &H1B
Private Const RUBY_USER_INTERRUPT_ERROR As Long = 18
'============================================================
' 元コード用
'============================================================
'ルビを振った漢字を格納するArray
Public kanjiArray(9999) As String
'KanjiArrayのインデックス
Public KI As Long
'============================================================
' 縦書き・横書き自動判別RubyBox用・モジュール変数
'============================================================
'親文字に対するルビ文字サイズ
Private Const RUBY_FONT_RATIO As Double = 0.5
'テキストボックス内部余白 最低値(pt)
Private Const RUBY_MIN_MARGIN As Single = 0.5
'親文字とルビの最低間隔(pt)
Private Const RUBY_MIN_GAP As Single = 0.5
'最終手動微調整（縦書き）
Private Const RUBY_X_ADJUST As Single = 0
Private Const RUBY_Y_ADJUST As Single = 0
'最終手動微調整（横書き）
Private Const RUBY_H_X_ADJUST As Single = 0
Private Const RUBY_H_Y_REFERENCE_FONT_SIZE As Single = 11
Private Const RUBY_H_Y_REFERENCE_ADJUST As Single = 5
Private Const RUBY_H_Y_FINE_ADJUST As Single = 5
'読みモード
Private Const RUBY_READ_MODE_WORD As Long = 0
Private Const RUBY_READ_MODE_KOBUN As Long = 1
'高速読みモード
' True : キャッシュ → Excel.GetPhonetic → Word標準ルビ fallback
' False: 従来どおり毎回Word標準ルビ
Private Const FAST_RUBY_MODE As Boolean = True
'古文読み辞書（遅延初期化）
Private mKobunExact As Object
Private mKobunContext As Object
'GetPoint実測用
'同一縦列の近傍文字から ScreenPixel / PagePoint の比率を測る。
Private Const RUBY_SCALE_SEARCH_CHARS As Long = 24
'実測値の異常判定
Private Const RUBY_SCALE_MIN As Double = 0.2
Private Const RUBY_SCALE_MAX As Double = 20#
Private Const RUBY_WIDTH_MIN_RATIO As Double = 0.5
Private Const RUBY_WIDTH_MAX_RATIO As Double = 12#
Private Const RUBY_HEIGHT_MIN_RATIO As Double = 0.35
Private Const RUBY_HEIGHT_MAX_RATIO As Double = 4#
'Word再レイアウト後の座標安定判定
Private Const RUBY_GEOMETRY_TOLERANCE As Single = 0.2
Private Const RUBY_GEOMETRY_RETRY As Long = 4
'生成するShapeの識別文字
Private Const RUBYBOX_PREFIX As String = "RubyTB_"
'読み取得用一時文書
Private mRubyTempDoc As Word.Document
'高速読み用キャッシュ / Excel.Application（遅延初期化・参照設定不要）
Private mRubyReadCache As Object
Private mRubyExcelApp As Object
'高速読み統計
Private mRubyCacheHit As Long
Private mRubyExcelHit As Long
Private mRubyWordFallback As Long
'Shape連番
Private mRubyShapeSeq As Long
'処理件数
Private mRubyOK As Long
Private mRubyEmpty As Long
Private mRubySkip As Long
Private mRubyErr As Long
Private mRubyKobunHit As Long
'ユーザーによる処理中断
Private mRubyCancelled As Boolean
'============================================================
' Escキーの古い押下状態を読み捨てる
'============================================================
Private Sub ResetRubyCancelState()
Dim dummy As Integer
mRubyCancelled = False
On Error Resume Next
dummy = GetAsyncKeyState(RUBY_VK_ESCAPE)
On Error GoTo 0
End Sub
'============================================================
' Escが押されたか確認
'
' High bit : 現在押下中
' Low bit : 前回呼出し以降に押された
' のどちらかを拾う。
'============================================================
Private Function RubyCancelRequested() As Boolean
Dim keyState As Integer
If mRubyCancelled = True Then
RubyCancelRequested = True
Exit Function
End If
On Error Resume Next
Err.Clear
keyState = GetAsyncKeyState(RUBY_VK_ESCAPE)
If Err.Number = 0 Then
If ((CLng(keyState) And &H8000&) <> 0) _
Or ((CLng(keyState) And 1&) <> 0) Then
mRubyCancelled = True
End If
End If
Err.Clear
On Error GoTo 0
RubyCancelRequested = mRubyCancelled
End Function
'################################################################
'
' 元のWord標準ルビマクロ
'
'################################################################
'============================================================
' 選択した範囲内の文字列にルビ設定 MakeRubiPartial
'============================================================
Public Sub ルビ01_選択範囲に標準ルビをふる()
SetPhoneticRange Selection.Range, False
End Sub
'============================================================
' 文書全体にルビ設定 MakeRubiAll
'============================================================
Public Sub ルビ02_全文に標準ルビをふる()
SetPhoneticRange ActiveDocument.Range, False
End Sub
'============================================================
' 選択した範囲内の文字列にルビ設定 MakeFirstRubiPartial
' 最初の漢字のみ
'============================================================
Public Sub ルビ03_選択範囲の初出のみ標準ルビ()
SetPhoneticRange Selection.Range, True
End Sub
'============================================================
' 文書全体にルビ設定 MakeFirstRubiAll
' 最初の漢字のみ
'============================================================
Public Sub ルビ04_全文に初出のみ標準ルビ()
SetPhoneticRange ActiveDocument.Range, True
End Sub
'============================================================
' 元の標準ルビ処理
'============================================================
Private Sub SetPhoneticRange( _
ByVal rng As Word.Range, _
ByVal FirstFlag As Boolean)
Dim r As Word.Range
Dim s As Word.Range
Dim i As Long
Dim dFlag As Boolean
KI = 0
For Each r In rng.Words
If r.Fields.Count < 1 Then
If ChkKanjiRange2(r) = True Then
If ChkKanjiRange(r) = True Then
If FirstFlag = False Then
r.Select
Application.Dialogs( _
wdDialogPhoneticGuide).Show 1
Else
If inKanjiArray(r.Text) = False Then
addKanjiArray r.Text
r.Select
Application.Dialogs( _
wdDialogPhoneticGuide).Show 1
End If
End If
Else
i = 1
For Each s In r.Characters
If ChkKanjiRange(s) = True Then
dFlag = False
If i < Len(r.Text) Then
If Len(Mid$(r.Text, i + 1, 1)) > 0 Then
If isKanji( _
Mid$(r.Text, i + 1, 1)) = True Then
s.End = s.End + 1
dFlag = True
End If
End If
End If
If FirstFlag = False Then
s.Select
Application.Dialogs( _
wdDialogPhoneticGuide).Show 1
Else
If inKanjiArray(s.Text) = False Then
If dFlag = True Then
addKanjiArray _
Mid$(r.Text, i, 1)
addKanjiArray _
Mid$(r.Text, i + 1, 1)
End If
addKanjiArray s.Text
s.Select
Application.Dialogs( _
wdDialogPhoneticGuide).Show 1
End If
End If
End If
i = i + 1
Next s
End If
End If
End If
Next r
End Sub
'============================================================
' 指定Rangeが全部漢字だったらTrue
'============================================================
Private Function ChkKanjiRange( _
ByVal rng As Word.Range) As Boolean
Dim i As Long
ChkKanjiRange = True
For i = 1 To Len(rng.Text)
If isKanji(Mid$(rng.Text, i, 1)) = False Then
ChkKanjiRange = False
Exit Function
End If
Next i
End Function
'============================================================
' 指定Rangeに漢字が1文字でも含まれていたらTrue
'============================================================
Private Function ChkKanjiRange2( _
ByVal rng As Word.Range) As Boolean
Dim i As Long
ChkKanjiRange2 = False
For i = 1 To Len(rng.Text)
If isKanji(Mid$(rng.Text, i, 1)) = True Then
ChkKanjiRange2 = True
Exit Function
End If
Next i
End Function
'============================================================
' 漢字判定
'============================================================
Private Function isKanji( _
ByVal strIn As String) As Boolean
Dim re As Object
Set re = CreateObject("VBScript.RegExp")
re.Pattern = "[一-龠〃々〆〇]"
isKanji = re.Test(strIn)
End Function
'============================================================
' kanjiArrayに存在するか
'============================================================
Private Function inKanjiArray( _
ByVal str As String) As Boolean
Dim i As Long
inKanjiArray = False
For i = 0 To KI + 1
If StrComp(kanjiArray(i), str) = 0 Then
inKanjiArray = True
Exit Function
End If
Next i
End Function
'============================================================
' kanjiArrayへ追加
'============================================================
Private Function addKanjiArray( _
ByVal str As String) As Boolean
kanjiArray(KI) = str
KI = KI + 1
addKanjiArray = True
End Function
'################################################################
'
' 縦書き・横書き自動判別テキストボックス型ルビ
'
'################################################################
'============================================================
' 選択範囲 / 全対象 MakeRubyBoxPartial
'============================================================
Public Sub ルビ11_選択範囲に縦書きルビ用テキストボックス()
RunRubyBoxProcess _
Selection.Range, _
False, _
False
End Sub
'============================================================
' 選択範囲 / 古文読み優先 MakeKobunRubyBoxPartial
'
' 古文辞書に一致した場合は古文読みを使用し、
' 一致しない対象は従来どおりWord標準ルビへフォールバックする。
'============================================================
Public Sub ルビ15_選択範囲に古文縦書きルビ用テキストボックス()
RunRubyBoxProcess _
Selection.Range, _
False, _
False, _
RUBY_READ_MODE_KOBUN
End Sub
'============================================================
' 文書全体 / 全対象 MakeRubyBoxAll
'
' MainTextStoryに加え、既存TextFrameStoryも処理する。
'============================================================
Public Sub ルビ12_全文に縦書きルビ用テキストボックス()
RunRubyBoxProcess _
ActiveDocument.Range, _
False, _
True
End Sub
'============================================================
' 選択範囲 / 初出のみ MakeFirstRubyBoxPartial
'============================================================
Public Sub ルビ13_選択範囲に初出のみ縦書きルビ用テキストボックス()
RunRubyBoxProcess _
Selection.Range, _
True, _
False
End Sub
'============================================================
' 文書全体 / 初出のみ MakeFirstRubyBoxAll
'============================================================
Public Sub ルビ14_全文に初出のみ縦書きルビ用テキストボックス()
RunRubyBoxProcess _
ActiveDocument.Range, _
True, _
True
End Sub
'============================================================
' RubyBox処理全体の管理
'
' FullFlag=True の場合：
' 1. 既存RubyBoxを全削除
' 2. その時点のTextFrameStoryをスナップショット
' 3. MainTextStoryを処理
' 4. スナップショットしたTextFrameStoryを処理
'
' RubyBox自身もTextFrameを持つため、処理開始前に
' スナップショットしておくことで新規RubyBoxの再処理を防ぐ。
'============================================================
Private Sub RunRubyBoxProcess( _
ByVal rng As Word.Range, _
ByVal FirstFlag As Boolean, _
ByVal FullFlag As Boolean, _
Optional ByVal readMode As Long = RUBY_READ_MODE_WORD)
Dim mainDoc As Word.Document
Dim workRng As Word.Range
Dim savedSel As Word.Range
Dim textFrameStories As Collection
Dim storyRng As Word.Range
Dim i As Long
Dim storyKey As String
Dim storyPage As Long
Dim modeInfo As String
On Error GoTo ERR_HANDLER
Set mainDoc = rng.Document
'現在選択位置を保存
On Error Resume Next
If Selection.Document Is mainDoc Then
Set savedSel = Selection.Range.Duplicate
End If
On Error GoTo ERR_HANDLER
'初期化
KI = 0
mRubyOK = 0
mRubyEmpty = 0
mRubySkip = 0
mRubyErr = 0
mRubyKobunHit = 0
mRubyCacheHit = 0
mRubyExcelHit = 0
mRubyWordFallback = 0
mRubyShapeSeq = 0
Set mRubyReadCache = Nothing
Set mRubyExcelApp = Nothing
ResetRubyCancelState
'削除処理へ入る前にもEscを確認する。
If RubyCancelRequested() = True Then
GoTo CLEAN_EXIT
End If
If FullFlag = True Then
'既存RubyBoxを先に消す。
'これによりStoryRangesのスナップショットへRubyBox自身が入らない。
DeleteAllRubyBoxes mainDoc
Set textFrameStories = _
SnapshotTextFrameStories(mainDoc)
Set workRng = _
mainDoc.Range.Duplicate
Else
Set workRng = _
rng.Duplicate
storyKey = _
GetRangeStoryKey(workRng)
storyPage = _
GetRangePageNumber(workRng)
DeleteRubyBoxesInRange _
mainDoc, _
CLng(workRng.StoryType), _
storyKey, _
storyPage, _
workRng.Start, _
workRng.End
End If
'既存RubyBox削除中などに押されたEscもここで拾う。
If RubyCancelRequested() = True Then
GoTo CLEAN_EXIT
End If
'読み取得専用一時文書
Set mRubyTempDoc = _
Documents.Add(Visible:=True)
mainDoc.Activate
'MainTextStoryまたは選択されたStoryを処理
ProcessRubyBoxRange _
workRng, _
mainDoc, _
FirstFlag, _
readMode
If mRubyCancelled = True Then
GoTo CLEAN_EXIT
End If
'全文処理時は、開始時点に存在したTextFrameStoryも処理
If FullFlag = True Then
If Not textFrameStories Is Nothing Then
For i = 1 To textFrameStories.Count
If RubyCancelRequested() = True Then
Exit For
End If
Set storyRng = _
textFrameStories(i)
ProcessRubyBoxRange _
storyRng, _
mainDoc, _
FirstFlag, _
readMode
If mRubyCancelled = True Then
Exit For
End If
Next i
End If
End If
CLEAN_EXIT:
On Error Resume Next
'高速読みで起動したExcel.Applicationを確実に解放する。
ReleaseFastRubyResources
If Not mRubyTempDoc Is Nothing Then
mRubyTempDoc.Close _
SaveChanges:=wdDoNotSaveChanges
End If
Set mRubyTempDoc = Nothing
If Not mainDoc Is Nothing Then
mainDoc.Activate
End If
If Not savedSel Is Nothing Then
savedSel.Select
End If
On Error GoTo 0
modeInfo = ""
If FAST_RUBY_MODE = True Then
modeInfo = _
modeInfo & vbCrLf & _
"高速読取 Excel : " & mRubyExcelHit & vbCrLf & _
"高速読取 Cache : " & mRubyCacheHit & vbCrLf & _
"Word fallback : " & mRubyWordFallback
End If
If readMode = RUBY_READ_MODE_KOBUN Then
modeInfo = _
modeInfo & vbCrLf & _
"古文辞書ヒット: " & mRubyKobunHit
End If
If mRubyCancelled = True Then
MsgBox _
"ルビ処理を中断しました。" & _
vbCrLf & vbCrLf & _
"作成済みRubyBox : " & mRubyOK & vbCrLf & _
"空RubyBox : " & mRubyEmpty & vbCrLf & _
"スキップ : " & mRubySkip & vbCrLf & _
"エラー : " & mRubyErr & _
modeInfo & _
vbCrLf & vbCrLf & _
"※中断前に作成済みのRubyBoxは残しています。", _
vbInformation
Else
MsgBox _
"テキストボックス型ルビ処理が終了しました。" & _
vbCrLf & vbCrLf & _
"通常RubyBox : " & mRubyOK & vbCrLf & _
"空RubyBox : " & mRubyEmpty & vbCrLf & _
"スキップ : " & mRubySkip & vbCrLf & _
"エラー : " & mRubyErr & _
modeInfo, _
vbInformation
End If
Exit Sub
ERR_HANDLER:
If Err.Number = RUBY_USER_INTERRUPT_ERROR Then
mRubyCancelled = True
Resume CLEAN_EXIT
End If
mRubyErr = mRubyErr + 1
Resume CLEAN_EXIT
End Sub
'============================================================
' 処理開始時点のTextFrameStoryを保存
'
' Wordではテキストボックス本文はwdTextFrameStoryという
' MainTextStoryとは別のStoryとして管理される。
'============================================================
Private Function SnapshotTextFrameStories( _
ByVal doc As Word.Document) As Collection
Dim result As Collection
Dim curStory As Word.Range
Dim copyRng As Word.Range
Set result = New Collection
On Error Resume Next
Set curStory = _
doc.StoryRanges(wdTextFrameStory)
On Error GoTo ERR_HANDLER
Do While Not curStory Is Nothing
Set copyRng = _
curStory.Duplicate
result.Add copyRng
Set curStory = _
curStory.NextStoryRange
Loop
Set SnapshotTextFrameStories = result
Exit Function
ERR_HANDLER:
'取得途中で問題が起きても、取得済みStoryは返す。
Set SnapshotTextFrameStories = result
End Function
'============================================================
' 1つのStory/Rangeを元コード同様に単語単位で処理
'============================================================
Private Sub ProcessRubyBoxRange( _
ByVal workRng As Word.Range, _
ByVal mainDoc As Word.Document, _
ByVal FirstFlag As Boolean, _
ByVal readMode As Long)
Dim r As Word.Range
Dim s As Word.Range
Dim targetRng As Word.Range
Dim contextRng As Word.Range
Dim i As Long
Dim dFlag As Boolean
Dim skipNext As Boolean
Dim targetStart As Long
Dim targetEnd As Long
On Error GoTo ERR_HANDLER
For Each r In workRng.Words
If RubyCancelRequested() = True Then
Exit Sub
End If
If r.Fields.Count < 1 Then
If ChkKanjiRange2(r) = True Then
If ChkKanjiRange(r) = True Then
Set targetRng = _
r.Duplicate
Set contextRng = _
r.Duplicate
If FirstFlag = False Then
CreateRubyBoxForRange _
targetRng, _
mainDoc, _
contextRng, _
readMode
Else
If inKanjiArray( _
targetRng.Text) = False Then
addKanjiArray _
targetRng.Text
CreateRubyBoxForRange _
targetRng, _
mainDoc, _
contextRng, _
readMode
End If
End If
Else
'漢字・かな等が混在
i = 1
skipNext = False
For Each s In r.Characters
If RubyCancelRequested() = True Then
Exit Sub
End If
If skipNext = True Then
skipNext = False
ElseIf ChkKanjiRange(s) = True Then
'Rangeオブジェクトを直接伸縮させず、
'この時点のStart/Endを数値で固定してから対象Rangeを作る。
'Shape作成・選択変更・再レイアウトによる
'Range境界の追随ズレをメタ情報へ持ち込まないため。
targetStart = s.Start
targetEnd = s.End
dFlag = False
'次の文字も漢字なら2文字まとめる
If i < Len(r.Text) Then
If Len(Mid$(r.Text, i + 1, 1)) > 0 Then
If isKanji( _
Mid$(r.Text, i + 1, 1)) = True Then
targetEnd = targetEnd + 1
dFlag = True
End If
End If
End If
Set targetRng = _
r.Duplicate
targetRng.SetRange _
Start:=targetStart, _
End:=targetEnd
Set contextRng = _
r.Duplicate
If FirstFlag = False Then
CreateRubyBoxForRange _
targetRng, _
mainDoc, _
contextRng, _
readMode
Else
If inKanjiArray( _
targetRng.Text) = False Then
If dFlag = True Then
addKanjiArray _
Mid$(r.Text, i, 1)
addKanjiArray _
Mid$(r.Text, i + 1, 1)
End If
addKanjiArray _
targetRng.Text
CreateRubyBoxForRange _
targetRng, _
mainDoc, _
contextRng, _
readMode
End If
End If
If dFlag = True Then
skipNext = True
End If
End If
i = i + 1
Next s
End If
End If
End If
Next r
Exit Sub
ERR_HANDLER:
If Err.Number = RUBY_USER_INTERRUPT_ERROR Then
mRubyCancelled = True
Exit Sub
End If
'1 Storyの異常で全文処理を止めない。
mRubyErr = mRubyErr + 1
End Sub
'============================================================
' 1対象の処理
'
' 読み取得だけ失敗した場合は処理を中止せず、
' rubyText="" の空RubyBoxを同じ位置計算で作る。
'============================================================
Private Sub CreateRubyBoxForRange( _
ByVal target As Word.Range, _
ByVal mainDoc As Word.Document, _
ByVal contextRng As Word.Range, _
ByVal readMode As Long)
Dim rubyText As String
Dim rubyReadOK As Boolean
Dim usedKobun As Boolean
Dim baseSize As Single
Dim rubySize As Single
Dim baseFont As String
Dim baseLeft As Single
Dim baseTop As Single
Dim baseWidth As Single
Dim baseHeight As Single
'元Rangeの識別情報は、Dialog/Shape作成より前に固定する。
Dim sourceStoryType As Long
Dim sourceStoryKey As String
Dim sourcePage As Long
Dim sourceStart As Long
Dim sourceEnd As Long
On Error GoTo ERR_HANDLER
If RubyCancelRequested() = True Then
Exit Sub
End If
If Len(target.Text) = 0 Then
mRubySkip = mRubySkip + 1
Exit Sub
End If
sourceStoryType = _
CLng(target.StoryType)
sourceStart = target.Start
sourceEnd = target.End
sourceStoryKey = _
GetRangeStoryKey(target)
sourcePage = _
GetRangePageNumber(target)
'読み取得。
'通常モードは従来どおりWord標準ルビ。
'古文モードは「文脈辞書 → 単語辞書 → Word標準ルビ」。
usedKobun = False
If readMode = RUBY_READ_MODE_KOBUN Then
rubyText = _
GetKobunRubyText( _
target, _
contextRng, _
rubyReadOK, _
usedKobun)
Else
rubyText = _
GetSmartRubyText( _
target, _
contextRng, _
rubyReadOK)
End If
'読み取得中にEscが押された場合、この対象のBoxは作らない。
If mRubyCancelled = True Then
Exit Sub
End If
If usedKobun = True Then
mRubyKobunHit = mRubyKobunHit + 1
End If
If rubyReadOK = False Then
rubyText = ""
End If
baseSize = _
GetBaseFontSize(target)
If baseSize <= 0 Then
mRubySkip = mRubySkip + 1
Exit Sub
End If
rubySize = _
baseSize * RUBY_FONT_RATIO
baseFont = _
GetBaseFontName(target)
mainDoc.Activate
If GetStableTargetGeometry( _
target, _
baseLeft, _
baseTop, _
baseWidth, _
baseHeight) = False Then
If mRubyCancelled = True Then
Exit Sub
End If
'座標が取得できない場合は同位置のBoxを作れないためスキップ。
mRubySkip = mRubySkip + 1
Exit Sub
End If
If AddRubyTextBox( _
mainDoc, _
target, _
rubyText, _
baseSize, _
rubySize, _
baseFont, _
baseLeft, _
baseTop, _
baseWidth, _
baseHeight, _
sourceStoryType, _
sourceStoryKey, _
sourcePage, _
sourceStart, _
sourceEnd) = False Then
If mRubyCancelled = True Then
Exit Sub
End If
mRubyErr = mRubyErr + 1
Exit Sub
End If
If rubyReadOK = True Then
mRubyOK = mRubyOK + 1
Else
mRubyEmpty = mRubyEmpty + 1
End If
Exit Sub
ERR_HANDLER:
If Err.Number = RUBY_USER_INTERRUPT_ERROR Then
mRubyCancelled = True
Exit Sub
End If
mRubyErr = mRubyErr + 1
End Sub
'============================================================
' 高速読みルータ
'
' FAST_RUBY_MODE=True:
' 1. キャッシュ
' 2. Excel.Application.GetPhonetic
' 3. Word標準ルビ fallback
'
' FAST_RUBY_MODE=False:
' 従来のGetWordRubyTextを直接呼ぶ。
'============================================================
Private Function GetSmartRubyText( _
ByVal src As Word.Range, _
ByVal contextRng As Word.Range, _
ByRef readOK As Boolean) As String
Dim cacheKey As String
Dim rubyText As String
readOK = False
GetSmartRubyText = ""
On Error GoTo WORD_FALLBACK
If FAST_RUBY_MODE = False Then
GetSmartRubyText = _
GetWordRubyText( _
src, _
contextRng, _
readOK)
Exit Function
End If
If RubyCancelRequested() = True Then
Exit Function
End If
EnsureRubyReadCache
cacheKey = _
BuildRubyReadCacheKey( _
src, _
contextRng)
If Not mRubyReadCache Is Nothing Then
If Len(cacheKey) > 0 Then
If mRubyReadCache.Exists(cacheKey) Then
rubyText = _
CStr(mRubyReadCache(cacheKey))
If Len(rubyText) > 0 Then
mRubyCacheHit = mRubyCacheHit + 1
readOK = True
GetSmartRubyText = rubyText
Exit Function
End If
End If
End If
End If
rubyText = _
GetExcelRubyText( _
src, _
contextRng, _
readOK)
If readOK = True And Len(rubyText) > 0 Then
mRubyExcelHit = mRubyExcelHit + 1
If Not mRubyReadCache Is Nothing _
And Len(cacheKey) > 0 Then
mRubyReadCache(cacheKey) = rubyText
End If
GetSmartRubyText = rubyText
Exit Function
End If
WORD_FALLBACK:
If mRubyCancelled = True Then
readOK = False
GetSmartRubyText = ""
Exit Function
End If
Err.Clear
mRubyWordFallback = mRubyWordFallback + 1
rubyText = _
GetWordRubyText( _
src, _
contextRng, _
readOK)
If readOK = True And Len(rubyText) > 0 Then
If Not mRubyReadCache Is Nothing _
And Len(cacheKey) > 0 Then
mRubyReadCache(cacheKey) = rubyText
End If
GetSmartRubyText = rubyText
Else
GetSmartRubyText = ""
End If
End Function
'============================================================
' 高速読みキャッシュを初期化
'============================================================
Private Sub EnsureRubyReadCache()
On Error GoTo ERR_HANDLER
If mRubyReadCache Is Nothing Then
Set mRubyReadCache = _
CreateObject("Scripting.Dictionary")
mRubyReadCache.CompareMode = vbBinaryCompare
End If
Exit Sub
ERR_HANDLER:
Set mRubyReadCache = Nothing
End Sub
'============================================================
' Excel.Applicationを遅延初期化
'
' 参照設定は不要。専用の非表示Excelを1プロセスだけ起動し、
' RubyBox処理終了時にReleaseFastRubyResourcesでQuitする。
'============================================================
Private Function EnsureRubyExcelApp() As Boolean
EnsureRubyExcelApp = False
On Error GoTo ERR_HANDLER
If mRubyExcelApp Is Nothing Then
Set mRubyExcelApp = _
CreateObject("Excel.Application")
On Error Resume Next
mRubyExcelApp.Visible = False
mRubyExcelApp.DisplayAlerts = False
On Error GoTo ERR_HANDLER
End If
EnsureRubyExcelApp = True
Exit Function
ERR_HANDLER:
Set mRubyExcelApp = Nothing
EnsureRubyExcelApp = False
End Function
'============================================================
' 高速読み用リソースを解放
'============================================================
Private Sub ReleaseFastRubyResources()
On Error Resume Next
If Not mRubyExcelApp Is Nothing Then
mRubyExcelApp.Quit
End If
Set mRubyExcelApp = Nothing
Set mRubyReadCache = Nothing
On Error GoTo 0
End Sub
'============================================================
' 読みキャッシュ用キー
'
' 同じ表記でも送り仮名・前後文脈が違えば別キーにする。
'============================================================
Private Function BuildRubyReadCacheKey( _
ByVal src As Word.Range, _
ByVal contextRng As Word.Range) As String
Dim contextText As String
Dim relStart As Long
Dim relEnd As Long
BuildRubyReadCacheKey = ""
If GetRubyReadContextInfo( _
src, _
contextRng, _
contextText, _
relStart, _
relEnd) = False Then
Exit Function
End If
BuildRubyReadCacheKey = _
contextText & vbTab & _
CStr(relStart) & ":" & CStr(relEnd) & vbTab & _
src.Text
End Function
'============================================================
' srcとcontextRngから読み取得用の文脈情報を作る
'
' relStart / relEnd は0始まり・End非包含。
'============================================================
Private Function GetRubyReadContextInfo( _
ByVal src As Word.Range, _
ByVal contextRng As Word.Range, _
ByRef contextText As String, _
ByRef relStart As Long, _
ByRef relEnd As Long) As Boolean
contextText = ""
relStart = 0
relEnd = 0
GetRubyReadContextInfo = False
On Error GoTo ERR_HANDLER
If src Is Nothing Then
Exit Function
End If
If contextRng Is Nothing Then
contextText = src.Text
relStart = 0
relEnd = Len(src.Text)
ElseIf contextRng.Document Is src.Document _
And contextRng.StoryType = src.StoryType _
And contextRng.Start <= src.Start _
And contextRng.End >= src.End Then
contextText = contextRng.Text
relStart = src.Start - contextRng.Start
relEnd = src.End - contextRng.Start
Else
contextText = src.Text
relStart = 0
relEnd = Len(src.Text)
End If
contextText = _
NormalizeRubyContextText(contextText)
If Len(contextText) = 0 Then
Exit Function
End If
If relStart < 0 _
Or relEnd <= relStart _
Or relEnd > Len(contextText) Then
contextText = _
NormalizeRubyContextText(src.Text)
relStart = 0
relEnd = Len(contextText)
End If
If Len(contextText) = 0 Then
Exit Function
End If
GetRubyReadContextInfo = True
Exit Function
ERR_HANDLER:
contextText = ""
relStart = 0
relEnd = 0
GetRubyReadContextInfo = False
End Function
'============================================================
' WordのStory末尾制御文字だけ除去
'============================================================
Private Function NormalizeRubyContextText( _
ByVal textValue As String) As String
Dim result As String
result = textValue
result = Replace(result, vbCr, "")
result = Replace(result, vbLf, "")
result = Replace(result, ChrW(7), "")
NormalizeRubyContextText = result
End Function
'============================================================
' Excel.GetPhoneticを使って読みを取得
'
' context全体の読みから、srcの外側にある「かな」だけを
' 前後から安全に除去できる場合に限って採用する。
' 少しでも対応関係が曖昧ならFalseとしてWordへfallbackする。
'============================================================
Private Function GetExcelRubyText( _
ByVal src As Word.Range, _
ByVal contextRng As Word.Range, _
ByRef readOK As Boolean) As String
Dim contextText As String
Dim relStart As Long
Dim relEnd As Long
Dim rawRuby As String
Dim rubyText As String
Dim prefixSurface As String
Dim suffixSurface As String
Dim prefixRuby As String
Dim suffixRuby As String
readOK = False
GetExcelRubyText = ""
On Error GoTo ERR_HANDLER
If EnsureRubyExcelApp() = False Then
Exit Function
End If
If GetRubyReadContextInfo( _
src, _
contextRng, _
contextText, _
relStart, _
relEnd) = False Then
Exit Function
End If
rawRuby = _
CStr(mRubyExcelApp.GetPhonetic(contextText))
rubyText = _
NormalizeRubyReading(rawRuby)
If Len(rubyText) = 0 Then
Exit Function
End If
'対象が文脈全体なら、そのまま採用できる。
If relStart = 0 _
And relEnd = Len(contextText) Then
readOK = True
GetExcelRubyText = rubyText
Exit Function
End If
prefixSurface = _
Left$(contextText, relStart)
suffixSurface = _
Mid$(contextText, relEnd + 1)
If TrySurfaceKanaToRubyBoundary( _
prefixSurface, _
prefixRuby) = False Then
Exit Function
End If
If TrySurfaceKanaToRubyBoundary( _
suffixSurface, _
suffixRuby) = False Then
Exit Function
End If
If Len(prefixRuby) > 0 Then
If Len(rubyText) < Len(prefixRuby) Then
Exit Function
End If
If StrComp( _
Left$(rubyText, Len(prefixRuby)), _
prefixRuby, _
vbBinaryCompare) <> 0 Then
Exit Function
End If
rubyText = _
Mid$(rubyText, Len(prefixRuby) + 1)
End If
If Len(suffixRuby) > 0 Then
If Len(rubyText) < Len(suffixRuby) Then
Exit Function
End If
If StrComp( _
Right$(rubyText, Len(suffixRuby)), _
suffixRuby, _
vbBinaryCompare) <> 0 Then
Exit Function
End If
rubyText = _
Left$( _
rubyText, _
Len(rubyText) - Len(suffixRuby))
End If
If Len(rubyText) = 0 Then
Exit Function
End If
readOK = True
GetExcelRubyText = rubyText
Exit Function
ERR_HANDLER:
readOK = False
GetExcelRubyText = ""
End Function
'============================================================
' Excelの読みをひらがなへ統一
'============================================================
Private Function NormalizeRubyReading( _
ByVal rubyText As String) As String
Dim result As String
On Error GoTo ERR_HANDLER
result = rubyText
result = Replace(result, " ", "")
result = Replace(result, " ", "")
result = Replace(result, vbCr, "")
result = Replace(result, vbLf, "")
If Len(result) = 0 Then
Exit Function
End If
result = StrConv(result, vbHiragana)
NormalizeRubyReading = result
Exit Function
ERR_HANDLER:
NormalizeRubyReading = ""
End Function
'============================================================
' srcの外側にある表記を、読み境界として安全に使えるか判定
'
' かな・空白・一般的な句読点だけならTrue。
' 漢字 / 英数字などが混じれば対応付けが曖昧なのでFalse。
'============================================================
Private Function TrySurfaceKanaToRubyBoundary( _
ByVal surfaceText As String, _
ByRef rubyBoundary As String) As Boolean
Dim i As Long
Dim ch As String
Dim codePoint As Long
Dim result As String
rubyBoundary = ""
TrySurfaceKanaToRubyBoundary = False
On Error GoTo ERR_HANDLER
For i = 1 To Len(surfaceText)
ch = Mid$(surfaceText, i, 1)
codePoint = AscW(ch)
'ひらがな
If codePoint >= &H3041 _
And codePoint <= &H3096 Then
result = result & ch
'カタカナ
ElseIf codePoint >= &H30A1 _
And codePoint <= &H30FA Then
result = _
result & StrConv(ch, vbHiragana)
'長音符は読み側にも残る。
ElseIf ch = "ー" Then
result = result & ch
'空白・句読点・括弧類は読み境界には含めない。
ElseIf IsRubyIgnorableBoundaryChar(ch) = True Then
'何もしない
Else
Exit Function
End If
Next i
rubyBoundary = result
TrySurfaceKanaToRubyBoundary = True
Exit Function
ERR_HANDLER:
rubyBoundary = ""
TrySurfaceKanaToRubyBoundary = False
End Function
'============================================================
' 読み境界で無視してよい記号
'============================================================
Private Function IsRubyIgnorableBoundaryChar( _
ByVal ch As String) As Boolean
Select Case ch
Case " ", " ", vbTab, _
"、", "。", "，", "．", ",", ".", _
"・", "！", "？", "!", "?", _
"「", "」", "『", "』", _
"（", "）", "(", ")", _
"［", "］", "[", "]", _
"【", "】", "〈", "〉", "《", "》", _
"…", "‥", "：", "；", ":", ";"
IsRubyIgnorableBoundaryChar = True
Case Else
IsRubyIgnorableBoundaryChar = False
End Select
End Function
'============================================================
' Word標準ルビから読み取得
'
' contextRng全体を一時文書へコピーし、src部分だけを選択する。
' これにより「食べる」→「食」=「た」のような送り仮名文脈を
' 元コードと同様に残す。
'
' 読み取得失敗時：
' 戻り値 = ""
' readOK = False
'============================================================
Private Function GetWordRubyText( _
ByVal src As Word.Range, _
ByVal contextRng As Word.Range, _
ByRef readOK As Boolean) As String
Dim trAll As Word.Range
Dim tr As Word.Range
Dim fld As Word.Field
Dim fldCode As String
Dim rubyPart As String
Dim rubyText As String
Dim baseSize As Single
Dim baseFont As String
Dim contextText As String
Dim relStart As Long
Dim relEnd As Long
Dim dlgResult As Long
readOK = False
GetWordRubyText = ""
On Error GoTo ERR_HANDLER
If mRubyTempDoc Is Nothing Then
Exit Function
End If
If contextRng Is Nothing Then
contextText = src.Text
relStart = 0
relEnd = Len(src.Text)
ElseIf contextRng.Document Is src.Document _
And contextRng.StoryType = src.StoryType _
And contextRng.Start <= src.Start _
And contextRng.End >= src.End Then
contextText = contextRng.Text
relStart = src.Start - contextRng.Start
relEnd = src.End - contextRng.Start
Else
contextText = src.Text
relStart = 0
relEnd = Len(src.Text)
End If
If Len(contextText) = 0 Then
Exit Function
End If
If relStart < 0 _
Or relEnd <= relStart _
Or relEnd > Len(contextText) Then
contextText = src.Text
relStart = 0
relEnd = Len(src.Text)
End If
ResetRubyTempDocument
'送り仮名込みの単語全体をコピー
Set trAll = _
mRubyTempDoc.Range(0, 0)
trAll.Text = contextText
Set trAll = _
mRubyTempDoc.Range( _
Start:=0, _
End:=Len(contextText))
baseSize = _
GetBaseFontSize(src)
baseFont = _
GetBaseFontName(src)
If baseSize > 0 Then
trAll.Font.Size = baseSize
End If
If Len(baseFont) > 0 Then
On Error Resume Next
trAll.Font.NameFarEast = baseFont
trAll.Font.Name = baseFont
On Error GoTo ERR_HANDLER
End If
Set tr = _
mRubyTempDoc.Range( _
Start:=relStart, _
End:=relEnd)
If tr.Characters.Count < 1 Then
Exit Function
End If
If RubyCancelRequested() = True Then
Exit Function
End If
mRubyTempDoc.Activate
tr.Select
dlgResult = _
Application.Dialogs( _
wdDialogPhoneticGuide).Show(1)
DoEvents
'重要:
' .Show(1) の 1 は約1msのTimeOut指定。
' そのため dlgResult=0 を無条件にユーザーCancelとは判定しない。
' EscはGetAsyncKeyStateで独立して検知する。
If RubyCancelRequested() = True Then
readOK = False
GetWordRubyText = ""
Exit Function
End If
'読み取得失敗の場合はFieldが無いので空Boxへ回す。
rubyText = ""
For Each fld In mRubyTempDoc.Fields
fldCode = fld.Code.Text
rubyPart = _
ExtractRubyFromFieldCode(fldCode)
If Len(rubyPart) > 0 Then
rubyText = rubyText & rubyPart
End If
Next fld
If Len(rubyText) > 0 Then
readOK = True
GetWordRubyText = rubyText
Else
readOK = False
GetWordRubyText = ""
End If
Exit Function
ERR_HANDLER:
If Err.Number = RUBY_USER_INTERRUPT_ERROR Then
mRubyCancelled = True
End If
readOK = False
GetWordRubyText = ""
End Function
'============================================================
' 古文読み優先でルビ文字列を取得
'
' 優先順位：
' 1. 文脈付き古文辞書
' 2. 対象文字列そのものの古文辞書
' 3. Word標準ルビへフォールバック
'
' 例：本文が「給ふ」で対象Rangeが「給」の場合、
' ルビは「たま」にする。送り仮名「ふ」は本文側に残るため、
' 辞書には「たまふ」ではなく「たま」を登録する。
'============================================================
Private Function GetKobunRubyText( _
ByVal src As Word.Range, _
ByVal contextRng As Word.Range, _
ByRef readOK As Boolean, _
ByRef usedKobun As Boolean) As String
Dim targetText As String
Dim contextText As String
Dim rubyText As String
readOK = False
usedKobun = False
GetKobunRubyText = ""
On Error GoTo FALLBACK_WORD
If RubyCancelRequested() = True Then
Exit Function
End If
targetText = _
NormalizeKobunLookupText(src.Text)
If contextRng Is Nothing Then
contextText = targetText
Else
contextText = _
NormalizeKobunLookupText(contextRng.Text)
End If
If Len(targetText) = 0 Then
GoTo FALLBACK_WORD
End If
EnsureKobunDictionaries
'まず送り仮名・活用形を含む文脈辞書を優先。
rubyText = _
LookupKobunContextRuby( _
targetText, _
contextText)
'文脈辞書に無ければ、対象文字列の完全一致辞書。
If Len(rubyText) = 0 Then
If Not mKobunExact Is Nothing Then
If mKobunExact.Exists(targetText) Then
rubyText = CStr(mKobunExact(targetText))
End If
End If
End If
If Len(rubyText) > 0 Then
usedKobun = True
readOK = True
GetKobunRubyText = rubyText
Exit Function
End If
FALLBACK_WORD:
If Err.Number = RUBY_USER_INTERRUPT_ERROR Then
mRubyCancelled = True
End If
If mRubyCancelled = True Then
readOK = False
GetKobunRubyText = ""
Exit Function
End If
'辞書に無い語は、高速読み経路へ。
'FAST_RUBY_MODE=Falseなら従来どおりWord標準ルビを使う。
GetKobunRubyText = _
GetSmartRubyText( _
src, _
contextRng, _
readOK)
End Function
'============================================================
' 古文辞書検索用にRange文字列を正規化
' Wordの段落末・セル末などだけ除き、本文中の仮名は変更しない。
'============================================================
Private Function NormalizeKobunLookupText( _
ByVal textValue As String) As String
Dim result As String
result = textValue
result = Replace(result, vbCr, "")
result = Replace(result, vbLf, "")
result = Replace(result, ChrW(7), "")
NormalizeKobunLookupText = Trim$(result)
End Function
'============================================================
' 古文読み辞書の初期化
'
' 【追加方法】
' 単語そのものが古文読みになるもの：
' AddKobunExactEntry "今日", "けふ"
'
' 送り仮名・活用形まで見て決めたいもの：
' AddKobunContextEntry "給ふ", "給", "たま"
'
' 第2引数は実際にRubyBoxを付ける漢字Range、
' 第3引数はその漢字部分だけの読みを指定する。
'============================================================
Private Sub EnsureKobunDictionaries()
On Error GoTo ERR_HANDLER
If Not mKobunExact Is Nothing Then
If Not mKobunContext Is Nothing Then
Exit Sub
End If
End If
Set mKobunExact = _
CreateObject("Scripting.Dictionary")
Set mKobunContext = _
CreateObject("Scripting.Dictionary")
mKobunExact.CompareMode = vbBinaryCompare
mKobunContext.CompareMode = vbBinaryCompare
'--------------------------------------------------------
' 単語完全一致辞書
' 必要な語はこの欄へ追加する。
'--------------------------------------------------------
AddKobunExactEntry "今日", "けふ"
AddKobunExactEntry "昨日", "きのふ"
AddKobunExactEntry "一昨日", "をととひ"
AddKobunExactEntry "蝶", "てふ"
'--------------------------------------------------------
' 文脈辞書
' 送り仮名を本文に残すため、Ruby文字列は漢字部分だけを登録。
'--------------------------------------------------------
'給ふ → たまふ
AddKobunContextEntry "給は", "給", "たま"
AddKobunContextEntry "給ひ", "給", "たま"
AddKobunContextEntry "給ふ", "給", "たま"
AddKobunContextEntry "給へ", "給", "たま"
'宣ふ → のたまふ
AddKobunContextEntry "宣は", "宣", "のたま"
AddKobunContextEntry "宣ひ", "宣", "のたま"
AddKobunContextEntry "宣ふ", "宣", "のたま"
AddKobunContextEntry "宣へ", "宣", "のたま"
'候ふ → さうらふ
AddKobunContextEntry "候は", "候", "さうら"
AddKobunContextEntry "候ひ", "候", "さうら"
AddKobunContextEntry "候ふ", "候", "さうら"
AddKobunContextEntry "候へ", "候", "さうら"
'侍り → はべり
AddKobunContextEntry "侍ら", "侍", "はべ"
AddKobunContextEntry "侍り", "侍", "はべ"
AddKobunContextEntry "侍る", "侍", "はべ"
AddKobunContextEntry "侍れ", "侍", "はべ"
'参る → まゐる
AddKobunContextEntry "参ら", "参", "まゐ"
AddKobunContextEntry "参り", "参", "まゐ"
AddKobunContextEntry "参る", "参", "まゐ"
AddKobunContextEntry "参れ", "参", "まゐ"
'居る → ゐる
AddKobunContextEntry "居ら", "居", "ゐ"
AddKobunContextEntry "居り", "居", "ゐ"
AddKobunContextEntry "居る", "居", "ゐ"
AddKobunContextEntry "居れ", "居", "ゐ"
'用ゐる → もちゐる
AddKobunContextEntry "用ゐ", "用", "もち"
Exit Sub
ERR_HANDLER:
Set mKobunExact = Nothing
Set mKobunContext = Nothing
End Sub
'============================================================
' 古文・単語完全一致辞書へ追加
'============================================================
Private Sub AddKobunExactEntry( _
ByVal targetText As String, _
ByVal rubyText As String)
If mKobunExact Is Nothing Then
Exit Sub
End If
If Len(targetText) = 0 Or Len(rubyText) = 0 Then
Exit Sub
End If
mKobunExact(targetText) = rubyText
End Sub
'============================================================
' 古文・文脈辞書へ追加
' キー = 文脈文字列 + TAB + 対象漢字Range
'============================================================
Private Sub AddKobunContextEntry( _
ByVal contextText As String, _
ByVal targetText As String, _
ByVal rubyText As String)
Dim keyText As String
If mKobunContext Is Nothing Then
Exit Sub
End If
If Len(contextText) = 0 _
Or Len(targetText) = 0 _
Or Len(rubyText) = 0 Then
Exit Sub
End If
keyText = _
contextText & vbTab & targetText
mKobunContext(keyText) = rubyText
End Sub
'============================================================
' 文脈辞書を検索
' contextRngがWord.Words由来で前後を少し含んでも拾えるよう、
' 文脈文字列は完全一致ではなく包含一致で判定する。
'============================================================
Private Function LookupKobunContextRuby( _
ByVal targetText As String, _
ByVal contextText As String) As String
Dim keyValue As Variant
Dim parts() As String
Dim phraseText As String
Dim keyTarget As String
LookupKobunContextRuby = ""
On Error GoTo ERR_HANDLER
If mKobunContext Is Nothing Then
Exit Function
End If
For Each keyValue In mKobunContext.Keys
parts = Split(CStr(keyValue), vbTab)
If UBound(parts) >= 1 Then
phraseText = parts(0)
keyTarget = parts(1)
If StrComp( _
keyTarget, _
targetText, _
vbBinaryCompare) = 0 Then
If InStr( _
1, _
contextText, _
phraseText, _
vbBinaryCompare) > 0 Then
LookupKobunContextRuby = _
CStr(mKobunContext(keyValue))
Exit Function
End If
End If
End If
Next keyValue
Exit Function
ERR_HANDLER:
LookupKobunContextRuby = ""
End Function
'============================================================
' EQフィールドコードから読み文字列を取得
'============================================================
Private Function ExtractRubyFromFieldCode( _
ByVal fldCode As String) As String
Dim p As Long
Dim pOpen As Long
Dim pClose As Long
On Error GoTo ERR_HANDLER
p = _
InStr(1, fldCode, "\up", vbTextCompare)
If p = 0 Then
p = InStr(1, fldCode, "\do", vbTextCompare)
End If
If p = 0 Then
Exit Function
End If
pOpen = _
InStr(p, fldCode, "(")
If pOpen = 0 Then
Exit Function
End If
pClose = _
InStr(pOpen + 1, fldCode, "),")
If pClose = 0 Then
pClose = InStr(pOpen + 1, fldCode, ")")
End If
If pClose = 0 Then
Exit Function
End If
ExtractRubyFromFieldCode = _
Mid$( _
fldCode, _
pOpen + 1, _
pClose - pOpen - 1)
Exit Function
ERR_HANDLER:
ExtractRubyFromFieldCode = ""
End Function
'============================================================
' 一時文書を空にする
'============================================================
Private Sub ResetRubyTempDocument()
Dim rr As Word.Range
On Error Resume Next
Set rr = mRubyTempDoc.Content
If rr.End > rr.Start Then
rr.End = rr.End - 1
End If
rr.Delete
On Error GoTo 0
End Sub
'============================================================
' 対象Rangeのページ上実座標を取得
'
' TextFrameStoryでも、対象を画面へ出した後で
' wdHorizontal/VerticalPositionRelativeToPageを取得する。
'============================================================
Private Function GetTargetGeometry( _
ByVal target As Word.Range, _
ByRef baseLeft As Single, _
ByRef baseTop As Single, _
ByRef baseWidth As Single, _
ByRef baseHeight As Single) As Boolean
On Error GoTo ERR_HANDLER
If IsVerticalRubyTarget(target) = True Then
GetTargetGeometry = _
GetVerticalTargetGeometry( _
target, _
baseLeft, _
baseTop, _
baseWidth, _
baseHeight)
Else
GetTargetGeometry = _
GetHorizontalTargetGeometry( _
target, _
baseLeft, _
baseTop, _
baseWidth, _
baseHeight)
End If
Exit Function
ERR_HANDLER:
GetTargetGeometry = False
End Function
'============================================================
' 対象Rangeが縦書きか判定
'
' Word.Range.Orientation を第一判定に使う。
' 日本語縦書きは通常 wdTextOrientationVerticalFarEast。
' wdTextOrientationVertical も縦書きとして扱う。
' 取得失敗時は近傍文字のページ座標から進行方向を推定する。
'============================================================
Private Function IsVerticalRubyTarget( _
ByVal target As Word.Range) As Boolean
Dim orientationValue As Long
On Error GoTo GEOMETRY_FALLBACK
orientationValue = _
CLng(target.Orientation)
Select Case orientationValue
Case wdTextOrientationVerticalFarEast, _
wdTextOrientationVertical
IsVerticalRubyTarget = True
Exit Function
Case wdTextOrientationHorizontal, _
wdTextOrientationHorizontalRotatedFarEast
IsVerticalRubyTarget = False
Exit Function
Case Else
'Downward/Upward等の特殊方向や予期しない値は
'実座標から進行方向を推定する。
GoTo GEOMETRY_FALLBACK
End Select
GEOMETRY_FALLBACK:
IsVerticalRubyTarget = _
InferVerticalFromRangeGeometry(target)
End Function
'============================================================
' Orientation取得不能時の進行方向フォールバック
'
' 対象自身または同一Story内の近傍1文字とのページ座標差を見て、
' Y方向の移動量がX方向より大きければ縦書きと推定する。
' あくまでOrientation取得不能時だけ使う保険であり、
' 通常の縦横判定には影響しない。
'============================================================
Private Function InferVerticalFromRangeGeometry( _
ByVal target As Word.Range) As Boolean
Dim refChar As Word.Range
Dim candidate As Word.Range
Dim storyRng As Word.Range
Dim offset As Long
Dim pos As Long
Dim dx As Double
Dim dy As Double
On Error GoTo FALLBACK_HORIZONTAL
If target Is Nothing Then
Exit Function
End If
If target.Characters.Count < 1 Then
Exit Function
End If
Set refChar = _
target.Characters(1).Duplicate
If target.Characters.Count >= 2 Then
Set candidate = _
target.Characters( _
target.Characters.Count).Duplicate
If TryGetRangeDirectionDelta( _
refChar, _
candidate, _
dx, _
dy) = True Then
InferVerticalFromRangeGeometry = _
(dy > dx)
Exit Function
End If
End If
Set storyRng = _
target.Duplicate
storyRng.Expand _
Unit:=wdStory
For offset = 1 To RUBY_SCALE_SEARCH_CHARS
pos = refChar.Start + offset
If pos >= storyRng.Start _
And pos < storyRng.End Then
Set candidate = _
storyRng.Duplicate
candidate.SetRange _
Start:=pos, _
End:=pos + 1
If TryGetRangeDirectionDelta( _
refChar, _
candidate, _
dx, _
dy) = True Then
InferVerticalFromRangeGeometry = _
(dy > dx)
Exit Function
End If
End If
pos = refChar.Start - offset
If pos >= storyRng.Start _
And pos < storyRng.End Then
Set candidate = _
storyRng.Duplicate
candidate.SetRange _
Start:=pos, _
End:=pos + 1
If TryGetRangeDirectionDelta( _
refChar, _
candidate, _
dx, _
dy) = True Then
InferVerticalFromRangeGeometry = _
(dy > dx)
Exit Function
End If
End If
Next offset
FALLBACK_HORIZONTAL:
'判定材料が無い極端に短いStoryではWord既定の横書き扱い。
InferVerticalFromRangeGeometry = False
End Function
'============================================================
' 2文字Range間のページ座標差を取得
'============================================================
Private Function TryGetRangeDirectionDelta( _
ByVal a As Word.Range, _
ByVal b As Word.Range, _
ByRef dx As Double, _
ByRef dy As Double) As Boolean
Dim pageA As Long
Dim pageB As Long
Dim xA As Single
Dim yA As Single
Dim xB As Single
Dim yB As Single
On Error GoTo ERR_HANDLER
dx = 0
dy = 0
pageA = _
CLng(a.Information( _
wdActiveEndPageNumber))
pageB = _
CLng(b.Information( _
wdActiveEndPageNumber))
If pageA <= 0 Or pageB <= 0 Then
Exit Function
End If
If pageA <> pageB Then
Exit Function
End If
xA = CSng(a.Information( _
wdHorizontalPositionRelativeToPage))
yA = CSng(a.Information( _
wdVerticalPositionRelativeToPage))
xB = CSng(b.Information( _
wdHorizontalPositionRelativeToPage))
yB = CSng(b.Information( _
wdVerticalPositionRelativeToPage))
If xA < 0 Or yA < 0 Or xB < 0 Or yB < 0 Then
Exit Function
End If
dx = Abs(CDbl(xB) - CDbl(xA))
dy = Abs(CDbl(yB) - CDbl(yA))
If dx < 0.5 And dy < 0.5 Then
Exit Function
End If
TryGetRangeDirectionDelta = True
Exit Function
ERR_HANDLER:
dx = 0
dy = 0
TryGetRangeDirectionDelta = False
End Function
'============================================================
' 縦書き対象Rangeのページ上実座標を取得
'============================================================
Private Function GetVerticalTargetGeometry( _
ByVal target As Word.Range, _
ByRef baseLeft As Single, _
ByRef baseTop As Single, _
ByRef baseWidth As Single, _
ByRef baseHeight As Single) As Boolean
Dim firstChar As Word.Range
Dim lastChar As Word.Range
Dim x1 As Single
Dim y1 As Single
Dim x2 As Single
Dim y2 As Single
Dim fs As Single
Dim measuredWidth As Single
On Error GoTo ERR_HANDLER
target.Document.Activate
If ActiveWindow.View.Type = wdOutlineView Then
Exit Function
End If
'まずScrollIntoView。TextFrameで失敗する環境ではSelectをフォールバック。
On Error Resume Next
Err.Clear
ActiveWindow.ScrollIntoView _
Obj:=target, _
Start:=True
If Err.Number <> 0 Then
Err.Clear
target.Select
End If
On Error GoTo ERR_HANDLER
DoEvents
If target.Characters.Count < 1 Then
Exit Function
End If
Set firstChar = _
target.Characters(1).Duplicate
Set lastChar = _
target.Characters( _
target.Characters.Count).Duplicate
x1 = CSng( _
firstChar.Information( _
wdHorizontalPositionRelativeToPage))
y1 = CSng( _
firstChar.Information( _
wdVerticalPositionRelativeToPage))
x2 = CSng( _
lastChar.Information( _
wdHorizontalPositionRelativeToPage))
y2 = CSng( _
lastChar.Information( _
wdVerticalPositionRelativeToPage))
'画面外なら一度だけSelectして再試行
If x1 < 0 Or y1 < 0 Or x2 < 0 Or y2 < 0 Then
target.Select
DoEvents
x1 = CSng( _
firstChar.Information( _
wdHorizontalPositionRelativeToPage))
y1 = CSng( _
firstChar.Information( _
wdVerticalPositionRelativeToPage))
x2 = CSng( _
lastChar.Information( _
wdHorizontalPositionRelativeToPage))
y2 = CSng( _
lastChar.Information( _
wdVerticalPositionRelativeToPage))
End If
If x1 < 0 Or y1 < 0 Or x2 < 0 Or y2 < 0 Then
Exit Function
End If
fs = _
GetBaseFontSize(target)
If fs <= 0 Then
Exit Function
End If
'縦書きで同一列か確認
If Abs(x1 - x2) > _
MaxSingle(fs * 0.8, 2) Then
Exit Function
End If
baseLeft = _
MinSingle(x1, x2)
baseTop = _
MinSingle(y1, y2)
'--------------------------------------------------------
' ここが今回の本修正。
'
' 旧:
' baseWidth = fs
'
' 新:
' Window.GetPoint が返す実画面幅(px)を、
' 同一縦列の「Page.Y(pt)差 / Screen.Top(px)差」から
' その場で求めた px/pt 比率でptへ戻す。
'
' 実測に失敗したときだけ旧仕様(fs)へフォールバックする。
'--------------------------------------------------------
measuredWidth = _
GetActualBaseWidthInPoints( _
target, _
fs)
If measuredWidth > 0 Then
baseWidth = measuredWidth
Else
baseWidth = fs
End If
'Y方向は今回のX問題と独立しているため従来計算を維持。
baseHeight = _
Abs(y2 - y1) + fs
GetVerticalTargetGeometry = True
Exit Function
ERR_HANDLER:
GetVerticalTargetGeometry = False
End Function
'============================================================
' 横書き対象Rangeのページ上実座標を取得
'
' 縦書き版と同じく、Wordが実際に描画した結果を基準にする。
' 横書きでは同一行を確認し、GetPointの画面矩形を
' 同一行の文字間隔から求めたpx/pt比率で文書ptへ戻す。
' 実測できない場合だけ文字座標＋フォントサイズへフォールバック。
'============================================================
Private Function GetHorizontalTargetGeometry( _
ByVal target As Word.Range, _
ByRef baseLeft As Single, _
ByRef baseTop As Single, _
ByRef baseWidth As Single, _
ByRef baseHeight As Single) As Boolean
Dim firstChar As Word.Range
Dim lastChar As Word.Range
Dim x1 As Single
Dim y1 As Single
Dim x2 As Single
Dim y2 As Single
Dim fs As Single
Dim measuredWidth As Single
Dim measuredHeight As Single
On Error GoTo ERR_HANDLER
target.Document.Activate
If ActiveWindow.View.Type = wdOutlineView Then
Exit Function
End If
On Error Resume Next
Err.Clear
ActiveWindow.ScrollIntoView _
Obj:=target, _
Start:=True
If Err.Number <> 0 Then
Err.Clear
target.Select
End If
On Error GoTo ERR_HANDLER
DoEvents
If target.Characters.Count < 1 Then
Exit Function
End If
Set firstChar = _
target.Characters(1).Duplicate
Set lastChar = _
target.Characters( _
target.Characters.Count).Duplicate
x1 = CSng( _
firstChar.Information( _
wdHorizontalPositionRelativeToPage))
y1 = CSng( _
firstChar.Information( _
wdVerticalPositionRelativeToPage))
x2 = CSng( _
lastChar.Information( _
wdHorizontalPositionRelativeToPage))
y2 = CSng( _
lastChar.Information( _
wdVerticalPositionRelativeToPage))
If x1 < 0 Or y1 < 0 Or x2 < 0 Or y2 < 0 Then
target.Select
DoEvents
x1 = CSng( _
firstChar.Information( _
wdHorizontalPositionRelativeToPage))
y1 = CSng( _
firstChar.Information( _
wdVerticalPositionRelativeToPage))
x2 = CSng( _
lastChar.Information( _
wdHorizontalPositionRelativeToPage))
y2 = CSng( _
lastChar.Information( _
wdVerticalPositionRelativeToPage))
End If
If x1 < 0 Or y1 < 0 Or x2 < 0 Or y2 < 0 Then
Exit Function
End If
fs = _
GetBaseFontSize(target)
If fs <= 0 Then
Exit Function
End If
'横書きで同一行か確認。
If Abs(y1 - y2) > _
MaxSingle(fs * 0.8, 2) Then
Exit Function
End If
baseLeft = _
MinSingle(x1, x2)
baseTop = _
MinSingle(y1, y2)
If GetActualHorizontalBaseSizeInPoints( _
target, _
fs, _
measuredWidth, _
measuredHeight) = True Then
baseWidth = measuredWidth
baseHeight = measuredHeight
Else
'実測不能時のみ従来型の幾何計算へフォールバック。
baseWidth = _
Abs(x2 - x1) + fs
baseHeight = fs
End If
GetHorizontalTargetGeometry = True
Exit Function
ERR_HANDLER:
GetHorizontalTargetGeometry = False
End Function
'============================================================
' Window.GetPointでRangeの画面矩形を取得
'
' GetPointはRange全体が画面に見えていないとエラーになるため、
' 呼び出し側でScrollIntoViewした状態を前提にFalseで返す。
'============================================================
Private Function GetRangeScreenRect( _
ByVal target As Word.Range, _
ByRef pxLeft As Long, _
ByRef pxTop As Long, _
ByRef pxWidth As Long, _
ByRef pxHeight As Long) As Boolean
On Error GoTo ERR_HANDLER
pxLeft = 0
pxTop = 0
pxWidth = 0
pxHeight = 0
ActiveWindow.GetPoint _
pxLeft, _
pxTop, _
pxWidth, _
pxHeight, _
target
If pxWidth <= 0 Or pxHeight <= 0 Then
Exit Function
End If
GetRangeScreenRect = True
Exit Function
ERR_HANDLER:
GetRangeScreenRect = False
End Function
'============================================================
' Wordが対象Rangeへ実際に確保した横方向幅をptで取得
'
' 1) targetのGetPoint.Width(px)を取得
' 2) 同じ縦列の近傍文字からpx/ptを実測
' 3) WidthPx / (px/pt) で文書ptへ戻す
'
' 実測スケールが取れない場合は、
' Word.Application.PixelsToPoints + 現在Zoomをフォールバックに使う。
'============================================================
Private Function GetActualBaseWidthInPoints( _
ByVal target As Word.Range, _
ByVal baseSize As Single) As Single
Dim pxLeft As Long
Dim pxTop As Long
Dim pxWidth As Long
Dim pxHeight As Long
Dim pxPerPt As Double
Dim widthPt As Double
Dim zoomPct As Long
On Error GoTo ERR_HANDLER
If baseSize <= 0 Then
Exit Function
End If
If GetRangeScreenRect( _
target, _
pxLeft, _
pxTop, _
pxWidth, _
pxHeight) = False Then
Exit Function
End If
pxPerPt = _
GetScreenPixelsPerPoint( _
target, _
baseSize)
If pxPerPt > 0 Then
widthPt = _
CDbl(pxWidth) / pxPerPt
Else
'近傍2点でスケールが測れない極端に短いStory等の保険。
'PixelsToPointsは表示デバイス換算なので、
'現在のWord Zoom分だけ文書座標へ戻す。
widthPt = _
CDbl(Application.PixelsToPoints( _
CSng(pxWidth), _
False))
zoomPct = _
ActiveWindow.View.Zoom.Percentage
If zoomPct > 0 Then
widthPt = _
widthPt * 100# / CDbl(zoomPct)
End If
End If
'GetPoint失敗や一時的な再レイアウト値を弾く。
If widthPt < _
CDbl(baseSize) * RUBY_WIDTH_MIN_RATIO _
Or widthPt > _
CDbl(baseSize) * RUBY_WIDTH_MAX_RATIO Then
Exit Function
End If
GetActualBaseWidthInPoints = _
CSng(widthPt)
Exit Function
ERR_HANDLER:
GetActualBaseWidthInPoints = 0
End Function
'============================================================
' 同一縦列の2文字から ScreenPixel / PagePoint を実測
'
' targetが2文字以上ならまず先頭/末尾を使用。
' 1文字の場合や差が取れない場合は、Story内の前後24文字を探索する。
'============================================================
Private Function GetScreenPixelsPerPoint( _
ByVal target As Word.Range, _
ByVal baseSize As Single) As Double
Dim refChar As Word.Range
Dim candidate As Word.Range
Dim storyRng As Word.Range
Dim offset As Long
Dim pos As Long
Dim scaleValue As Double
On Error GoTo ERR_HANDLER
If target.Characters.Count < 1 Then
Exit Function
End If
Set refChar = _
target.Characters(1).Duplicate
'対象自身が複数文字なら、まず同一対象内で測る。
If target.Characters.Count >= 2 Then
Set candidate = _
target.Characters( _
target.Characters.Count).Duplicate
If TryGetPixelsPerPointFromPair( _
refChar, _
candidate, _
baseSize, _
scaleValue) = True Then
GetScreenPixelsPerPoint = scaleValue
Exit Function
End If
End If
Set storyRng = _
target.Duplicate
storyRng.Expand _
Unit:=wdStory
For offset = 1 To RUBY_SCALE_SEARCH_CHARS
'後方
pos = refChar.Start + offset
If pos >= storyRng.Start _
And pos < storyRng.End Then
Set candidate = _
storyRng.Duplicate
candidate.SetRange _
Start:=pos, _
End:=pos + 1
If TryGetPixelsPerPointFromPair( _
refChar, _
candidate, _
baseSize, _
scaleValue) = True Then
GetScreenPixelsPerPoint = scaleValue
Exit Function
End If
End If
'前方
pos = refChar.Start - offset
If pos >= storyRng.Start _
And pos < storyRng.End Then
Set candidate = _
storyRng.Duplicate
candidate.SetRange _
Start:=pos, _
End:=pos + 1
If TryGetPixelsPerPointFromPair( _
refChar, _
candidate, _
baseSize, _
scaleValue) = True Then
GetScreenPixelsPerPoint = scaleValue
Exit Function
End If
End If
Next offset
Exit Function
ERR_HANDLER:
GetScreenPixelsPerPoint = 0
End Function
'============================================================
' 2つの1文字Rangeが同一縦列にある場合、px/ptを返す
'============================================================
Private Function TryGetPixelsPerPointFromPair( _
ByVal a As Word.Range, _
ByVal b As Word.Range, _
ByVal baseSize As Single, _
ByRef scaleValue As Double) As Boolean
Dim pageA As Long
Dim pageB As Long
Dim xA As Single
Dim yA As Single
Dim xB As Single
Dim yB As Single
Dim leftA As Long
Dim topA As Long
Dim widthA As Long
Dim heightA As Long
Dim leftB As Long
Dim topB As Long
Dim widthB As Long
Dim heightB As Long
Dim dyPt As Double
Dim dyPx As Double
Dim candidateScale As Double
On Error GoTo ERR_HANDLER
scaleValue = 0
If a Is Nothing Then
Exit Function
End If
If b Is Nothing Then
Exit Function
End If
pageA = _
CLng(a.Information( _
wdActiveEndPageNumber))
pageB = _
CLng(b.Information( _
wdActiveEndPageNumber))
If pageA <= 0 Or pageB <= 0 Then
Exit Function
End If
If pageA <> pageB Then
Exit Function
End If
xA = CSng(a.Information( _
wdHorizontalPositionRelativeToPage))
yA = CSng(a.Information( _
wdVerticalPositionRelativeToPage))
xB = CSng(b.Information( _
wdHorizontalPositionRelativeToPage))
yB = CSng(b.Information( _
wdVerticalPositionRelativeToPage))
If xA < 0 Or yA < 0 Or xB < 0 Or yB < 0 Then
Exit Function
End If
'同じ縦列だけを採用する。
If Abs(xA - xB) > _
MaxSingle(baseSize * 0.8, 2) Then
Exit Function
End If
dyPt = _
Abs(CDbl(yB) - CDbl(yA))
If dyPt < _
CDbl(MaxSingle(baseSize * 0.4, 2)) Then
Exit Function
End If
If GetRangeScreenRect( _
a, _
leftA, _
topA, _
widthA, _
heightA) = False Then
Exit Function
End If
If GetRangeScreenRect( _
b, _
leftB, _
topB, _
widthB, _
heightB) = False Then
Exit Function
End If
dyPx = _
Abs(CDbl(topB) - CDbl(topA))
If dyPx <= 0 Then
Exit Function
End If
candidateScale = _
dyPx / dyPt
If candidateScale < RUBY_SCALE_MIN _
Or candidateScale > RUBY_SCALE_MAX Then
Exit Function
End If
scaleValue = candidateScale
TryGetPixelsPerPointFromPair = True
Exit Function
ERR_HANDLER:
scaleValue = 0
TryGetPixelsPerPointFromPair = False
End Function
'============================================================
' 横書き対象の実幅・実高さをptで取得
'
' GetPointのWidth/Height(px)を、同一行の近傍文字から実測した
' ScreenPixel / PagePoint 比率で文書ptへ戻す。
'============================================================
Private Function GetActualHorizontalBaseSizeInPoints( _
ByVal target As Word.Range, _
ByVal baseSize As Single, _
ByRef widthPt As Single, _
ByRef heightPt As Single) As Boolean
Dim pxLeft As Long
Dim pxTop As Long
Dim pxWidth As Long
Dim pxHeight As Long
Dim pxPerPt As Double
Dim measuredWidth As Double
Dim measuredHeight As Double
Dim zoomPct As Long
On Error GoTo ERR_HANDLER
widthPt = 0
heightPt = 0
If baseSize <= 0 Then
Exit Function
End If
If GetRangeScreenRect( _
target, _
pxLeft, _
pxTop, _
pxWidth, _
pxHeight) = False Then
Exit Function
End If
pxPerPt = _
GetHorizontalScreenPixelsPerPoint( _
target, _
baseSize)
If pxPerPt > 0 Then
measuredWidth = _
CDbl(pxWidth) / pxPerPt
measuredHeight = _
CDbl(pxHeight) / pxPerPt
Else
measuredWidth = _
CDbl(Application.PixelsToPoints( _
CSng(pxWidth), _
False))
measuredHeight = _
CDbl(Application.PixelsToPoints( _
CSng(pxHeight), _
True))
zoomPct = _
ActiveWindow.View.Zoom.Percentage
If zoomPct > 0 Then
measuredWidth = _
measuredWidth * 100# / CDbl(zoomPct)
measuredHeight = _
measuredHeight * 100# / CDbl(zoomPct)
End If
End If
If measuredWidth < _
CDbl(baseSize) * RUBY_WIDTH_MIN_RATIO _
Or measuredWidth > _
CDbl(baseSize) * RUBY_WIDTH_MAX_RATIO Then
Exit Function
End If
If measuredHeight < _
CDbl(baseSize) * RUBY_HEIGHT_MIN_RATIO _
Or measuredHeight > _
CDbl(baseSize) * RUBY_HEIGHT_MAX_RATIO Then
Exit Function
End If
widthPt = CSng(measuredWidth)
heightPt = CSng(measuredHeight)
GetActualHorizontalBaseSizeInPoints = True
Exit Function
ERR_HANDLER:
widthPt = 0
heightPt = 0
GetActualHorizontalBaseSizeInPoints = False
End Function
'============================================================
' 横書き同一行の2文字から ScreenPixel / PagePoint を実測
'============================================================
Private Function GetHorizontalScreenPixelsPerPoint( _
ByVal target As Word.Range, _
ByVal baseSize As Single) As Double
Dim refChar As Word.Range
Dim candidate As Word.Range
Dim storyRng As Word.Range
Dim offset As Long
Dim pos As Long
Dim scaleValue As Double
On Error GoTo ERR_HANDLER
If target.Characters.Count < 1 Then
Exit Function
End If
Set refChar = _
target.Characters(1).Duplicate
If target.Characters.Count >= 2 Then
Set candidate = _
target.Characters( _
target.Characters.Count).Duplicate
If TryGetHorizontalPixelsPerPointFromPair( _
refChar, _
candidate, _
baseSize, _
scaleValue) = True Then
GetHorizontalScreenPixelsPerPoint = scaleValue
Exit Function
End If
End If
Set storyRng = _
target.Duplicate
storyRng.Expand _
Unit:=wdStory
For offset = 1 To RUBY_SCALE_SEARCH_CHARS
pos = refChar.Start + offset
If pos >= storyRng.Start _
And pos < storyRng.End Then
Set candidate = _
storyRng.Duplicate
candidate.SetRange _
Start:=pos, _
End:=pos + 1
If TryGetHorizontalPixelsPerPointFromPair( _
refChar, _
candidate, _
baseSize, _
scaleValue) = True Then
GetHorizontalScreenPixelsPerPoint = scaleValue
Exit Function
End If
End If
pos = refChar.Start - offset
If pos >= storyRng.Start _
And pos < storyRng.End Then
Set candidate = _
storyRng.Duplicate
candidate.SetRange _
Start:=pos, _
End:=pos + 1
If TryGetHorizontalPixelsPerPointFromPair( _
refChar, _
candidate, _
baseSize, _
scaleValue) = True Then
GetHorizontalScreenPixelsPerPoint = scaleValue
Exit Function
End If
End If
Next offset
Exit Function
ERR_HANDLER:
GetHorizontalScreenPixelsPerPoint = 0
End Function
'============================================================
' 2つの1文字Rangeが同一横行にある場合、px/ptを返す
'============================================================
Private Function TryGetHorizontalPixelsPerPointFromPair( _
ByVal a As Word.Range, _
ByVal b As Word.Range, _
ByVal baseSize As Single, _
ByRef scaleValue As Double) As Boolean
Dim pageA As Long
Dim pageB As Long
Dim xA As Single
Dim yA As Single
Dim xB As Single
Dim yB As Single
Dim leftA As Long
Dim topA As Long
Dim widthA As Long
Dim heightA As Long
Dim leftB As Long
Dim topB As Long
Dim widthB As Long
Dim heightB As Long
Dim dxPt As Double
Dim dxPx As Double
Dim candidateScale As Double
On Error GoTo ERR_HANDLER
scaleValue = 0
If a Is Nothing Then
Exit Function
End If
If b Is Nothing Then
Exit Function
End If
pageA = _
CLng(a.Information( _
wdActiveEndPageNumber))
pageB = _
CLng(b.Information( _
wdActiveEndPageNumber))
If pageA <= 0 Or pageB <= 0 Then
Exit Function
End If
If pageA <> pageB Then
Exit Function
End If
xA = CSng(a.Information( _
wdHorizontalPositionRelativeToPage))
yA = CSng(a.Information( _
wdVerticalPositionRelativeToPage))
xB = CSng(b.Information( _
wdHorizontalPositionRelativeToPage))
yB = CSng(b.Information( _
wdVerticalPositionRelativeToPage))
If xA < 0 Or yA < 0 Or xB < 0 Or yB < 0 Then
Exit Function
End If
If Abs(yA - yB) > _
MaxSingle(baseSize * 0.8, 2) Then
Exit Function
End If
dxPt = _
Abs(CDbl(xB) - CDbl(xA))
If dxPt < _
CDbl(MaxSingle(baseSize * 0.4, 2)) Then
Exit Function
End If
If GetRangeScreenRect( _
a, _
leftA, _
topA, _
widthA, _
heightA) = False Then
Exit Function
End If
If GetRangeScreenRect( _
b, _
leftB, _
topB, _
widthB, _
heightB) = False Then
Exit Function
End If
dxPx = _
Abs(CDbl(leftB) - CDbl(leftA))
If dxPx <= 0 Then
Exit Function
End If
candidateScale = _
dxPx / dxPt
If candidateScale < RUBY_SCALE_MIN _
Or candidateScale > RUBY_SCALE_MAX Then
Exit Function
End If
scaleValue = candidateScale
TryGetHorizontalPixelsPerPointFromPair = True
Exit Function
ERR_HANDLER:
scaleValue = 0
TryGetHorizontalPixelsPerPointFromPair = False
End Function
'============================================================
' Word再レイアウト後の対象Range座標を安定取得
'============================================================
Private Function GetStableTargetGeometry( _
ByVal target As Word.Range, _
ByRef baseLeft As Single, _
ByRef baseTop As Single, _
ByRef baseWidth As Single, _
ByRef baseHeight As Single) As Boolean
Dim i As Long
Dim curLeft As Single
Dim curTop As Single
Dim curWidth As Single
Dim curHeight As Single
Dim prevLeft As Single
Dim prevTop As Single
Dim prevWidth As Single
Dim prevHeight As Single
Dim hasPrev As Boolean
Dim hasValue As Boolean
On Error GoTo ERR_HANDLER
For i = 1 To RUBY_GEOMETRY_RETRY
DoEvents
If RubyCancelRequested() = True Then
Exit Function
End If
If GetTargetGeometry( _
target, _
curLeft, _
curTop, _
curWidth, _
curHeight) = True Then
hasValue = True
If hasPrev = True Then
If Abs(curLeft - prevLeft) <= _
RUBY_GEOMETRY_TOLERANCE _
And Abs(curTop - prevTop) <= _
RUBY_GEOMETRY_TOLERANCE _
And Abs(curWidth - prevWidth) <= _
RUBY_GEOMETRY_TOLERANCE _
And Abs(curHeight - prevHeight) <= _
RUBY_GEOMETRY_TOLERANCE Then
baseLeft = curLeft
baseTop = curTop
baseWidth = curWidth
baseHeight = curHeight
GetStableTargetGeometry = True
Exit Function
End If
End If
prevLeft = curLeft
prevTop = curTop
prevWidth = curWidth
prevHeight = curHeight
hasPrev = True
End If
Next i
If hasValue = True Then
baseLeft = prevLeft
baseTop = prevTop
baseWidth = prevWidth
baseHeight = prevHeight
GetStableTargetGeometry = True
Exit Function
End If
ERR_HANDLER:
GetStableTargetGeometry = False
End Function
'============================================================
' RubyBoxを置くための安全なアンカーRangeを取得
'
' Word.Shapes.AddTextboxにはAnchor引数が無い。
' そのため：
' MainTextStory → 対象段落先頭を選択
' TextFrameStory等 → 対象ページのMainTextStoryを選択
' してからAddTextboxする。
'
' Shapeはアンカーと同じページに留まるため、
' TextFrame本文から作る場合でもRubyBox自体はMainTextStory側へ
' アンカーし、Left/Topはページ絶対座標で合わせる。
'============================================================
Private Function GetRubyAnchorRange( _
ByVal target As Word.Range, _
ByVal mainDoc As Word.Document) As Word.Range
Dim anchorRng As Word.Range
Dim pageNo As Long
On Error GoTo FALLBACK
If target.StoryType = wdMainTextStory Then
If target.Paragraphs.Count > 0 Then
Set anchorRng = _
target.Paragraphs(1).Range.Duplicate
anchorRng.Collapse _
wdCollapseStart
Set GetRubyAnchorRange = anchorRng
Exit Function
End If
End If
pageNo = _
GetRangePageNumber(target)
If pageNo > 0 Then
Set anchorRng = _
mainDoc.GoTo( _
What:=wdGoToPage, _
Which:=wdGoToAbsolute, _
Count:=pageNo)
anchorRng.Collapse _
wdCollapseStart
Set GetRubyAnchorRange = anchorRng
Exit Function
End If
FALLBACK:
On Error Resume Next
Set anchorRng = _
mainDoc.Range(0, 0)
Set GetRubyAnchorRange = anchorRng
On Error GoTo 0
End Function
'============================================================
' テキストボックス作成
'============================================================
Private Function AddRubyTextBox( _
ByVal mainDoc As Word.Document, _
ByVal target As Word.Range, _
ByVal rubyText As String, _
ByVal baseSize As Single, _
ByVal rubySize As Single, _
ByVal fontName As String, _
ByVal baseLeft As Single, _
ByVal baseTop As Single, _
ByVal baseWidth As Single, _
ByVal baseHeight As Single, _
ByVal sourceStoryType As Long, _
ByVal sourceStoryKey As String, _
ByVal sourcePage As Long, _
ByVal sourceStart As Long, _
ByVal sourceEnd As Long) As Boolean
Dim shp As Word.Shape
Dim anchorRng As Word.Range
Dim rubyMargin As Single
Dim rubyGap As Single
Dim initWidth As Single
Dim initHeight As Single
Dim rubyLeft As Single
Dim rubyTop As Single
Dim lineAdjust As Single
Dim shapeName As String
Dim isEmptyRuby As Boolean
Dim isVertical As Boolean
Dim rubyOrientation As Long
On Error GoTo ERR_HANDLER
If RubyCancelRequested() = True Then
Exit Function
End If
isEmptyRuby = _
(Len(rubyText) = 0)
isVertical = _
IsVerticalRubyTarget(target)
If isVertical = True Then
rubyOrientation = msoTextOrientationVerticalFarEast
Else
rubyOrientation = msoTextOrientationHorizontal
End If
rubyMargin = _
MaxSingle( _
RUBY_MIN_MARGIN, _
rubySize * 0.15)
rubyGap = _
MaxSingle( _
RUBY_MIN_GAP, _
rubySize * 0.1)
If isVertical = True Then
'縦書きRubyBox：細い幅＋読みの長さに応じた高さ。
initWidth = _
rubySize * 2 + _
rubyMargin * 2
If isEmptyRuby = True Then
initHeight = _
MaxSingle( _
baseHeight, _
rubySize * 2 + _
rubyMargin * 2 + _
2)
Else
initHeight = _
rubySize * Len(rubyText) + _
rubyMargin * 2 + _
2
If initHeight < rubySize * 2 Then
initHeight = rubySize * 2
End If
End If
Else
'横書きRubyBox：読みの長さに応じた幅＋低い高さ。
initHeight = _
rubySize * 2 + _
rubyMargin * 2
If isEmptyRuby = True Then
initWidth = _
MaxSingle( _
baseWidth, _
rubySize * 2 + _
rubyMargin * 2 + _
2)
Else
initWidth = _
rubySize * Len(rubyText) + _
rubyMargin * 2 + _
2
If initWidth < rubySize * 2 Then
initWidth = rubySize * 2
End If
End If
End If
'--------------------------------------------------------
' TextFrameStoryを選択したままShapeを作らない。
' RubyBoxのアンカー用MainTextStory Rangeを先に選択する。
'--------------------------------------------------------
Set anchorRng = _
GetRubyAnchorRange( _
target, _
mainDoc)
mainDoc.Activate
If Not anchorRng Is Nothing Then
anchorRng.Select
End If
DoEvents
If RubyCancelRequested() = True Then
Exit Function
End If
Set shp = _
mainDoc.Shapes.AddTextbox( _
Orientation:=rubyOrientation, _
Left:=0, _
Top:=0, _
Width:=initWidth, _
Height:=initHeight)
If shp Is Nothing Then
GoTo ERR_HANDLER
End If
'作成直後に本文非干渉・ページ基準を確定
shp.WrapFormat.Type = wdWrapNone
shp.RelativeHorizontalPosition = _
wdRelativeHorizontalPositionPage
shp.RelativeVerticalPosition = _
wdRelativeVerticalPositionPage
'Shape識別名
mRubyShapeSeq = _
mRubyShapeSeq + 1
shapeName = _
RUBYBOX_PREFIX & _
Format$( _
CLng(Timer * 100), _
"00000000") & _
"_" & _
Format$( _
mRubyShapeSeq, _
"000000")
On Error Resume Next
shp.Name = shapeName
On Error GoTo ERR_HANDLER
'元Range情報。
'Dialog/Shape作成前に固定した値を使い、
'Range追随によるStart/Endの1文字ズレを防ぐ。
shp.AlternativeText = _
"RUBYBOX|" & _
"ST=" & CStr(sourceStoryType) & "|" & _
"SK=" & sourceStoryKey & "|" & _
"P=" & CStr(sourcePage) & "|" & _
"S=" & CStr(sourceStart) & "|" & _
"E=" & CStr(sourceEnd) & "|" & _
"O=" & IIf(isVertical, "V", "H") & "|" & _
"EMPTY=" & CStr(Abs(CLng(isEmptyRuby))) & "|"
With shp
.Fill.Visible = msoFalse
.Line.Visible = msoFalse
On Error Resume Next
.Shadow.Visible = msoFalse
On Error GoTo ERR_HANDLER
.WrapFormat.Type = wdWrapNone
.RelativeHorizontalPosition = _
wdRelativeHorizontalPositionPage
.RelativeVerticalPosition = _
wdRelativeVerticalPositionPage
.LockAnchor = True
On Error Resume Next
.LayoutInCell = False
On Error GoTo ERR_HANDLER
End With
With shp.TextFrame
.Orientation = rubyOrientation
.MarginLeft = rubyMargin
.MarginRight = rubyMargin
.MarginTop = rubyMargin
.MarginBottom = rubyMargin
.TextRange.Text = rubyText
With .TextRange.Font
.Size = rubySize
If Len(fontName) > 0 Then
On Error Resume Next
.NameFarEast = fontName
.Name = fontName
On Error GoTo ERR_HANDLER
End If
End With
With .TextRange.ParagraphFormat
.SpaceBefore = 0
.SpaceAfter = 0
.LineSpacingRule = wdLineSpaceSingle
.Alignment = wdAlignParagraphCenter
End With
'空文字をAutoSizeするとWordがBoxを極端に縮める場合がある。
If isEmptyRuby = True Then
.AutoSize = False
Else
.AutoSize = True
End If
End With
'TextFrame2が利用可能なら折返し防止＋自動サイズ
On Error Resume Next
shp.TextFrame2.WordWrap = msoFalse
If isEmptyRuby = True Then
shp.TextFrame2.AutoSize = msoAutoSizeNone
Else
shp.TextFrame2.AutoSize = msoAutoSizeShapeToFitText
End If
On Error GoTo ERR_HANDLER
DoEvents
If RubyCancelRequested() = True Then
GoTo ERR_HANDLER
End If
'Shape追加後の再レイアウトを吸収するため親文字座標を再取得
If GetStableTargetGeometry( _
target, _
baseLeft, _
baseTop, _
baseWidth, _
baseHeight) = False Then
GoTo ERR_HANDLER
End If
'空Boxは親文字の進行方向サイズに追従させる。
If isEmptyRuby = True Then
If isVertical = True Then
If shp.Height < baseHeight Then
shp.Height = baseHeight
End If
Else
If shp.Width < baseWidth Then
shp.Width = baseWidth
End If
End If
End If
If isVertical = True Then
'----------------------------------------------------
' 縦書き：本文の右側へ配置。
' 既存Final版の実測セル幅補正をそのまま維持する。
'----------------------------------------------------
lineAdjust = _
((baseWidth - baseSize) - _
(shp.Width - rubySize)) / 2
rubyLeft = _
baseLeft + _
baseSize + _
rubyGap + _
lineAdjust + _
RUBY_X_ADJUST
rubyTop = _
baseTop + _
((baseHeight - shp.Height) / 2) + _
RUBY_Y_ADJUST
Else
'横書きは、実測した本文上端(baseTop)を基準に
'RubyBoxの下端を本文へ寄せる。
'
'旧lineAdjustは大フォント時に過剰補正になるため、
'横書きY位置には使用しない。
rubyLeft = _
baseLeft + _
((baseWidth - shp.Width) / 2) + _
RUBY_H_X_ADJUST
rubyTop = _
baseTop - _
shp.Height + _
GetHorizontalRubyYAdjust(baseSize)
End If
If rubyLeft < 0 Then
rubyLeft = 0
End If
If rubyTop < 0 Then
rubyTop = 0
End If
shp.Left = rubyLeft
shp.Top = rubyTop
AddRubyTextBox = True
Exit Function
ERR_HANDLER:
If Err.Number = RUBY_USER_INTERRUPT_ERROR Then
mRubyCancelled = True
End If
On Error Resume Next
If Not shp Is Nothing Then
shp.Delete
End If
On Error GoTo 0
AddRubyTextBox = False
End Function
'============================================================
' 親文字フォントサイズ
'============================================================
Private Function GetBaseFontSize( _
ByVal target As Word.Range) As Single
Dim fs As Single
On Error GoTo ERR_HANDLER
If target.Characters.Count < 1 Then
Exit Function
End If
fs = _
target.Characters(1).Font.Size
If fs <= 0 Then
Exit Function
End If
GetBaseFontSize = fs
Exit Function
ERR_HANDLER:
GetBaseFontSize = 0
End Function
'============================================================
' 親文字日本語フォント
'============================================================
Private Function GetBaseFontName( _
ByVal target As Word.Range) As String
Dim strFont As String
On Error Resume Next
strFont = _
target.Characters(1).Font.NameFarEast
If Len(strFont) = 0 Then
strFont = target.Characters(1).Font.Name
End If
GetBaseFontName = strFont
On Error GoTo 0
End Function
'============================================================
' Rangeが存在する実ページ番号
'============================================================
Private Function GetRangePageNumber( _
ByVal target As Word.Range) As Long
Dim pageNo As Long
GetRangePageNumber = -1
On Error GoTo ERR_HANDLER
target.Document.Activate
pageNo = _
CLng(target.Information( _
wdActiveEndPageNumber))
If pageNo > 0 Then
GetRangePageNumber = pageNo
End If
Exit Function
ERR_HANDLER:
GetRangePageNumber = -1
End Function
'============================================================
' Story識別キー
'
' TextFrameStoryでは複数の独立したStoryが同じStart/Endを
' 持ち得るため、StoryTypeだけでは不十分。
'
' Story先頭のページ座標＋先頭文字列の簡易ハッシュを使って
' 誤削除を抑える。
'============================================================
Private Function GetRangeStoryKey( _
ByVal target As Word.Range) As String
Dim storyRng As Word.Range
Dim firstChar As Word.Range
Dim pageNo As Long
Dim x As Single
Dim y As Single
Dim x10 As Long
Dim y10 As Long
Dim sampleText As String
Dim h As Long
On Error GoTo ERR_HANDLER
If target.StoryType = wdMainTextStory Then
GetRangeStoryKey = "MAIN"
Exit Function
End If
Set storyRng = _
target.Duplicate
storyRng.Expand _
Unit:=wdStory
sampleText = _
Left$(storyRng.Text, 64)
h = _
SimpleTextHash(sampleText)
pageNo = _
GetRangePageNumber(storyRng)
x = -1
y = -1
If storyRng.Characters.Count > 0 Then
Set firstChar = _
storyRng.Characters(1).Duplicate
On Error Resume Next
target.Document.Activate
ActiveWindow.ScrollIntoView _
Obj:=firstChar, _
Start:=True
DoEvents
x = CSng(firstChar.Information( _
wdHorizontalPositionRelativeToPage))
y = CSng(firstChar.Information( _
wdVerticalPositionRelativeToPage))
On Error GoTo ERR_HANDLER
End If
x10 = CLng(x * 10)
y10 = CLng(y * 10)
GetRangeStoryKey = _
"ST" & CStr(CLng(target.StoryType)) & _
"P" & CStr(pageNo) & _
"X" & CStr(x10) & _
"Y" & CStr(y10) & _
"H" & CStr(h)
Exit Function
ERR_HANDLER:
GetRangeStoryKey = _
"ST" & CStr(CLng(target.StoryType))
End Function
'============================================================
' 文字列の簡易ハッシュ
' VBA Longのオーバーフローを避けるためDoubleで剰余計算する。
'============================================================
Private Function SimpleTextHash( _
ByVal textValue As String) As Long
Dim i As Long
Dim h As Double
Dim codeValue As Long
h = 5381#
On Error GoTo ERR_HANDLER
For i = 1 To Len(textValue)
codeValue = _
AscW(Mid$(textValue, i, 1))
If codeValue < 0 Then
codeValue = codeValue + 65536
End If
h = h * 33# + CDbl(codeValue)
h = h - _
Int(h / 2147483647#) * 2147483647#
Next i
SimpleTextHash = CLng(h)
Exit Function
ERR_HANDLER:
SimpleTextHash = 0
End Function
'============================================================
' 文書全体のRubyBox削除
'============================================================
Private Sub DeleteAllRubyBoxes( _
ByVal doc As Word.Document)
Dim i As Long
On Error Resume Next
For i = doc.Shapes.Count To 1 Step -1
If IsRubyBoxShape(doc.Shapes(i)) Then
doc.Shapes(i).Delete
End If
Next i
On Error GoTo 0
End Sub
'============================================================
' 選択範囲内RubyBox削除
'
' MainTextStoryとTextFrameStoryではStart/Endの座標系が別。
' TextFrameStory同士でも独立StoryのStart/Endが重なるため、
' ST/SK/P/S/Eを組み合わせて判定する。
'============================================================
Private Sub DeleteRubyBoxesInRange( _
ByVal doc As Word.Document, _
ByVal rangeStoryType As Long, _
ByVal rangeStoryKey As String, _
ByVal rangePage As Long, _
ByVal rangeStart As Long, _
ByVal rangeEnd As Long)
Dim i As Long
Dim shp As Word.Shape
Dim srcStoryType As Long
Dim srcPage As Long
Dim srcStart As Long
Dim srcEnd As Long
Dim srcStoryKey As String
Dim storyOK As Boolean
Dim pageOK As Boolean
Dim keyOK As Boolean
On Error Resume Next
For i = doc.Shapes.Count To 1 Step -1
Set shp = doc.Shapes(i)
If IsRubyBoxShape(shp) Then
srcStoryType = _
GetMetaLong( _
shp.AlternativeText, _
"ST=")
srcPage = _
GetMetaLong( _
shp.AlternativeText, _
"P=")
srcStart = _
GetMetaLong( _
shp.AlternativeText, _
"S=")
srcEnd = _
GetMetaLong( _
shp.AlternativeText, _
"E=")
srcStoryKey = _
GetMetaText( _
shp.AlternativeText, _
"SK=")
If srcStart >= 0 And srcEnd >= 0 Then
'旧版メタ情報（ST無し）はMainTextStoryだけ互換削除。
If srcStoryType < 0 Then
storyOK = _
(rangeStoryType = wdMainTextStory)
Else
storyOK = _
(srcStoryType = rangeStoryType)
End If
If srcPage < 0 Or rangePage < 0 Then
pageOK = True
Else
pageOK = (srcPage = rangePage)
End If
If Len(srcStoryKey) = 0 _
Or Len(rangeStoryKey) = 0 _
Or rangeStoryType = wdMainTextStory Then
keyOK = True
Else
keyOK = _
(StrComp( _
srcStoryKey, _
rangeStoryKey, _
vbBinaryCompare) = 0)
End If
If storyOK = True _
And pageOK = True _
And keyOK = True Then
If srcEnd > rangeStart _
And srcStart < rangeEnd Then
shp.Delete
End If
End If
Else
'メタ情報が無い非常に古いRubyBox。
'MainTextStory選択時だけアンカー位置で代替判定する。
If rangeStoryType = wdMainTextStory Then
If shp.Anchor.Start >= rangeStart _
And shp.Anchor.Start <= rangeEnd Then
shp.Delete
End If
End If
End If
End If
Next i
On Error GoTo 0
End Sub
'============================================================
' RubyBox Shapeか
'============================================================
Private Function IsRubyBoxShape( _
ByVal shp As Word.Shape) As Boolean
On Error Resume Next
If Left$( _
shp.Name, _
Len(RUBYBOX_PREFIX)) = _
RUBYBOX_PREFIX Then
IsRubyBoxShape = True
Exit Function
End If
If Left$( _
shp.AlternativeText, _
8) = "RUBYBOX|" Then
IsRubyBoxShape = True
Exit Function
End If
IsRubyBoxShape = False
On Error GoTo 0
End Function
'============================================================
' Shapeメタ情報からLong取得
'============================================================
Private Function GetMetaLong( _
ByVal metaText As String, _
ByVal keyText As String) As Long
Dim tmp As String
GetMetaLong = -1
tmp = _
GetMetaText( _
metaText, _
keyText)
If Len(tmp) = 0 Then
Exit Function
End If
If IsNumeric(tmp) Then
On Error Resume Next
GetMetaLong = CLng(tmp)
On Error GoTo 0
End If
End Function
'============================================================
' Shapeメタ情報から文字列取得
'============================================================
Private Function GetMetaText( _
ByVal metaText As String, _
ByVal keyText As String) As String
Dim p As Long
Dim q As Long
GetMetaText = ""
On Error GoTo ERR_HANDLER
p = _
InStr( _
1, _
metaText, _
keyText, _
vbTextCompare)
If p = 0 Then
Exit Function
End If
p = p + Len(keyText)
q = _
InStr(p, metaText, "|")
If q = 0 Then
q = Len(metaText) + 1
End If
GetMetaText = _
Mid$( _
metaText, _
p, _
q - p)
Exit Function
ERR_HANDLER:
GetMetaText = ""
End Function
'============================================================
' Single用 Max
'============================================================
Private Function MaxSingle( _
ByVal a As Single, _
ByVal b As Single) As Single
If a > b Then
MaxSingle = a
Else
MaxSingle = b
End If
End Function
'============================================================
' Single用 Min
'============================================================
Private Function MinSingle( _
ByVal a As Single, _
ByVal b As Single) As Single
If a < b Then
MinSingle = a
Else
MinSingle = b
End If
End Function
Private Function GetHorizontalRubyYAdjust( _
ByVal baseSize As Single) As Single
Dim adjustValue As Double
If baseSize <= 0 Then
GetHorizontalRubyYAdjust = _
RUBY_H_Y_FINE_ADJUST
Exit Function
End If
adjustValue = _
CDbl(RUBY_H_Y_REFERENCE_ADJUST) * _
CDbl(baseSize) / _
CDbl(RUBY_H_Y_REFERENCE_FONT_SIZE)
GetHorizontalRubyYAdjust = _
CSng(adjustValue) + _
RUBY_H_Y_FINE_ADJUST
End Function
コピーしました！