VBAを活用してウディタで中国語を表示する方法
（21/8/31執筆、9/9修正）
備考
・翻訳支援ツールが製作中との事ですのでそちらが販売されるまでの暫定的な対応です。
・フォントの利用規約を十分確認してください。今回使用しているMSゴシック及びMSPゴシックは画像として配布さえしなければ問題ないフォントの筈です。
・触り始めて5ヶ月のクソコードです。他の方が公開されているサンプルコードを参考にしました。
本題
（2行目の1文字目が対象）
1年半くらい前の記事ではウディタを用いた変換用の記号への変換と表示について書きましたが、今回は最近裏で覚えたVBAを用いた内容です。
予定には無かったのですが、7月にテキスト画像の背景を透明にして保存する簡単な方法という記事を見つけた結果として今回の方法と完全な実装が実現しました。
この場をお借りしてお礼申し上げます。
フォントの取得
今回の方法ではcsvファイルに格納した文字列を使用します。
私は https://uic.jp/charset/supported_list/ 様から取得しましたが、文字の被り等を考えると後で楽できるようUnicodeの文字コードを取得したほうが良いです。
今回は昔に用意した中国語用の文字コードを使用します。
（サンプルコード）
Sub フォント出力()
Application.ScreenUpdating = False
Dim code As String
code = InputBox("取得元の言語を入力（chs,cht）")
Dim fold As String
'保存先フォルダを指定
If code = "chs" Then
code = "chslist.xlsx"
fold = "chs"
ElseIf code = "cht" Then
code = "chtlist.xlsx"
fold = "cht"
Else
MsgBox "エラーが発生しました。処理を終了します。"
End
End If
'エラー対策（既にリストが開かれていないかの確認）
Dim wb As Workbook, flag As Boolean
For Each wb In Workbooks
If wb.Name = code Then
flag = True
Exit For
End If
Next wb
'開かれてない時だけ開く
If Not flag Then
Workbooks.Open Filename:= _
ThisWorkbook.Path & "/" & code
End If
'雑に変数宣言（細かな設定を弄るならここで）
Dim size As Integer
size = 14
'まずフォルダを作る
If Dir(fold & size, vbDirectory) = "" Then
MkDir fold & size
End If
'下の文字数を減らす為にワークシート名を全て指定
Dim filei As String
filei = "Book2"
Dim file As String
'xlsmから開いた場合と実行後のhtmの場合があるので両方に対応
flag = False
For Each wb In Workbooks
If wb.Name = "Book2.xlsm" Then
flag = True
Exit For
End If
Next wb
If flag = True Then
file = filei & ".xlsm"
'fileをアクティブに
Windows(file).Activate
'xlsmなら一度保存してhtmにする
'警告非表示
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:= ＿
ThisWorkbook.Path & "\Book2.htm", ＿
FileFormat:=xlHtml, ReadOnlyRecommended:=False, CreateBackup:=False
End If
'file名を置き換え
file = filei & ".htm"
'ワークシートの指定はアクティブシートしか反映されないので宣言前にActivateを挟む
Windows(code).Activate
Dim 保存 As Worksheet
Set 保存 = Worksheets("Sheet1")
Dim mes As String
Dim x, y As Long
Dim x16 As String
Dim savef As String
'フォントサイズに応じてテキストボックスのサイズを調整
Windows(file).Activate
If size = 24 Then
With ActiveSheet.Shapes.Range(Array("TextBox 1"))
.Width = 25.5118110236
.Height = 25.5118110236
End With
ElseIf size = 14 Then
With ActiveSheet.Shapes.Range(Array("TextBox 1"))
.Width = 13.8897637795
.Height = 13.8897637795
End With
End If
'途中から再開用
Dim r As Long
r = 2
'動作チェックのため途中で止める
For y = r To Range("a2").End(xlDown).Row
' For y = 2 To 2
Windows(code).Activate
x16 = Cells(y, 1).Value
For x = 2 To 17
Windows(code).Activate
mes = 保存.Cells(y, x).Value
If mes = "" Then
GoTo nx
End If
'保存名を設定（一番上にあるのでそれを利用）
savef = x16 & Cells(1, x)
'元のシートに戻ってテキストボックスに貼り付け
Windows(file).Activate
ActiveSheet.Shapes.Range(Array("TextBox 1")).Select
'文字を指定
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = mes
'書式設定
Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 1).ParagraphFormat. _
FirstLineIndent = 0
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 1).Font
'色
.Fill.ForeColor.RGB = RGB(255, 255, 255)
.Fill.Transparency = 0
.Fill.Solid
'サイズ
.size = size
.Name = "+mn-lt"
.NameComplexScript = "+mn-cs"
.NameFarEast = "+mn-ea"
End With
Application.EnableEvents = False
'警告非表示
Application.DisplayAlerts = False
'保存、ThisWorkbook.Pathはこのブックの保存場所
ActiveWorkbook.SaveAs Filename:= ＿
ThisWorkbook.Path & "\Book2.htm", ＿
FileFormat:=xlHtml, ReadOnlyRecommended:=False, CreateBackup:=False
FileCopy ThisWorkbook.Path & "/book2.files/image001.png", ThisWorkbook.Path & "/" & fold & size & "/" & savef & ".png"
file = "Book2.htm"
'空白の場合の飛ばし先
nx:
Next
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Shift-JISの文字を含めた全ての文字を取得するコードでした。
Shift-JIS以外の文字のみにしたい場合は以下の部分を変えてください。
（変更前）
mes = 保存.Cells(y, x).Value
If mes = "" Then
GoTo nx
End If
（Shift-JISの文字を弾くよう変更した場合）
mes = 保存.Cells(y, x).Value
If mes = "" Then
GoTo nx
ElseIf mes <> "?" And _
Asc(mes) = Asc("?") Then
Else
GoTo nx
End If
問題が起こり途中で止まらなければ6時間ほどで保存用フォルダに全ての文字のpng画像が保存されます。
私の環境では1度固まってました。
変換用記号への変換・復号
Excelの該当箇所にコピーして実行すると変換と復号が行われるコードです。
Sub 文章置換()
Application.ScreenUpdating = False
Windows("呼出元.xlsm").Activate
Worksheets("置換").Select
Range("A2", Range("a2").End(xlDown)).Copy
Range("B2").PasteSpecial
Range("C2").PasteSpecial
Application.CutCopyMode = False
Dim code As String
code = InputBox("取得元の言語を入力（chs,cht）")
Dim fold As String
'保存先フォルダを指定
If code = "chs" Then
code = "chslist.xlsx"
fold = "chs"
ElseIf code = "cht" Then
code = "chtlist.xlsx"
fold = "cht"
Else
MsgBox "エラーが発生しました。処理を終了します。"
End
End If
'エラー対策（既にリストが開かれていないかの確認）
Dim wb As Workbook, flag As Boolean
For Each wb In Workbooks
If wb.Name = code Then
flag = True
Exit For
End If
Next wb
'開かれてない時だけ開く
If Not flag Then
Workbooks.Open Filename:= _
ThisWorkbook.Path & "/" & code
End If
Dim 行数 As Long
行数 = Range("a2").End(xlDown).Row
Dim 先頭 As String
Dim x As Long
Dim y As Long
Dim 保存 As String
Dim ループ As Long
For ループ = 2 To 行数
Do Until Cells(ループ, 2) = ""
先頭 = Mid(Cells(ループ, 2), 1, 1)
If 先頭 <> "?" And _
Asc(先頭) = Asc("?") Then
Windows(code).Activate
Cells.Find(What:=先頭, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= ＿
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False ＿
, MatchByte:=False, SearchFormat:=False).Activate
x = ActiveCell.Column
y = ActiveCell.Row
保存 = Cells(y, 1).value & Cells(1, x).value
Windows("呼出元.xlsm").Activate
'機種依存文字を置き換える
Range("A2", Range("a2").End(xlDown)).Offset(0, 2).Select
Selection.Replace What:=先頭, Replacement:="\" & fold & "[" & 保存 & "]", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ＿
ReplaceFormat:=False
End If
'処理済みの文字を消す
Range("A2", Range("a2").End(xlDown)).Offset(0, 1).Select
Selection.Replace What:=先頭, Replacement:="", LookAt:=xlPart, ＿
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ＿
ReplaceFormat:=False
Loop
Next
Application.ScreenUpdating = True
End Sub
文章の復号は上の内容より厄介です。
Sub 文章復号()
Application.ScreenUpdating = False
Windows("呼出元.xlsm").Activate
Worksheets("置換").Select
Range("A2", Range("a2").End(xlDown)).Copy
Range("B2").PasteSpecial
Range("C2").PasteSpecial
Application.CutCopyMode = False
Dim code As String
code = InputBox("取得元の言語を入力（chs,cht）")
Dim fold As String
'保存先フォルダを指定
If code = "chs" Then
code = "chslist.xlsx"
fold = "chs"
ElseIf code = "cht" Then
code = "chtlist.xlsx"
fold = "cht"
Else
MsgBox "エラーが発生しました。処理を終了します。"
End
End If
'エラー対策（既にリストが開かれていないかの確認）
Dim wb As Workbook, flag As Boolean
For Each wb In Workbooks
If wb.Name = code Then
flag = True
Exit For
End If
Next wb
'開かれてない時だけ開く
If Not flag Then
Workbooks.Open Filename:= _
ThisWorkbook.Path & "/" & code
End If
Dim 行数 As Long
行数 = Range("a2").End(xlDown).Row
Dim 先頭 As String
Dim x, y As Long
Dim 保存 As String
Dim 置換 As String
Dim ax, ay As String
Dim folen As Integer
folen = Len(fold)
Dim ループ As Long
For ループ = 2 To 行数
Do Until Cells(ループ, 2) = ""
先頭 = Mid(Cells(ループ, 2), 1, folen + 2)
If 先頭 = "\" & fold & "[" Then
'一致するなら次の4文字を3文字と1文字で取得
ay = Mid(Cells(ループ, 2), folen + 3, 3) '+1
ax = Mid(Cells(ループ, 2), folen + 6, 1) 'folen +2 + 3 +1
'先頭を]までに置き換える
先頭 = Mid(Cells(ループ, 2), 1, folen + 7) 'folen + (2+4+1)
Windows(code).Activate
Range("a2", Range("a2").End(xlDown)).Select
Cells.Find(What:=ay, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= ＿
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False ＿
, MatchByte:=False, SearchFormat:=False).Activate
y = ActiveCell.Row
'0が入る場合に正常に処理されないので例外
If ax <> "0" Then
Range("b1", Range("b1").End(xlToRight)).Select
Cells.Find(What:=ax, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= ＿
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False ＿
, MatchByte:=False, SearchFormat:=False).Activate
x = ActiveCell.Column
Else
x = 2
End If
保存 = Cells(y, x).value
Windows("呼出元.xlsm").Activate
'機種依存文字を置き換える
Range("A2", Range("a2").End(xlDown)).Offset(0, 2).Select
Selection.Replace What:=先頭, Replacement:=保存, LookAt:=xlPart, ＿
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ＿
ReplaceFormat:=False
Else
'異なるなら1文字だけ取得し削除
先頭 = Mid(Cells(ループ, 2), 1, 1)
End If
'処理済みの文字を消す
Range("A2", Range("a2").End(xlDown)).Offset(0, 1).Select
Selection.Replace What:=先頭, Replacement:="", LookAt:=xlPart, ＿
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ＿
ReplaceFormat:=False
Loop
Next
Application.ScreenUpdating = True
End Sub
上のコードは、例として\chs[FFF0]という変換用の記号を復号する場合に、『\』、『chs』、『[』、『FFF』、『0』、『]』という6つのブロックに分けて置換を行うというやり方です。
実際に動かすとこんな風になります。（置換）
あとはウディタ側で\chs[ と \cht[ を\img[(ファイルパス) へ置き換えるように書いて文章を表示させる前に処理を挟めば完成です。
以上ですが、全部の文字を入れると約38MBになり、また1度の暗号化作業に30分ほど掛かります。
とても扱いにくい代物ですので、先にゲーム名を合わせた状態で暗号化フォルダを限定するからフォントが入っているフォルダを.wolf形式に変換し、その.wolfファイルを開発用フォルダに入れ元のフォルダは別の所に移しておく事をお勧めします。
ゲーム内ではちゃんと表示され、またゲームデータの作成に掛かる時間も短縮できます。
この記事にはコメントできません。