Attribute VB_Name = "StrConv" Sub StrConv3() '################################################### ' StrConv 3 〔新旧漢字変換〕(VBA) '  TjSoft-95, Taiju, 2011.3.19 ' 【使い方】 '  文字種の変換を行う。 '  新字体と旧字体について相互変換ができる。 '  各々のリストに文字を追加することができる。 '  Taiju製「漢文エディタ」でMS-Wordに出力した文章の '  書式を変更することなく字体を変換することができる。 '################################################### Dim KyuJitai_Text, ShinJitai_Text As String KyuJitai_Text = "來兩亞惡帶專ョ拜乘奧歸效齊齋雜會佛假條傳" & _ "僞價儉u囘剩劍劑眞區勵壓參豫氣龜囑單號戰嚴獸國" & _ "圓圍團圖殼壹壽臺撓モ壤孃ェ實寫寶寳竊屆屬彈彌峽" & _ "峯嶽巖樂斷廣廢癈應廳貳晝畫肅盡徑從衞恆愼慘懷拂" & _ "拔搖據擇擔擴攝淺溪滯滿澁澀潛濳澤濕濟濱P瀧灣狹" & _ "獨獵陷鱸ャ墮險隱鄰惠戀收ヘ數リ惱膽臟爐棧樞樣" & _ "樓檢櫻權隸歐齒殘毆爲亂鷄辭壯將奬犧與擧譽處戲獻" & _ "莖莊萬舊藝藏藥エ遞遲邊邉壘癡發縣碎祕祿禪禮稱" & _ "稻穗穩穰竝龍當黨對粹峨N經阪s總繪繼續纎變缺" & _ "聰聽覽鹽兒蟲蠶蠻踐蹈觸謠證譯讀讓賣贊輕轉辨瓣辯" & _ "醉釀釋鋪鎭鐵鑄鑛韋杉ヤ靈靜麥顯餘騷驅驛驗髓鬪勞" & _ "榮營豐艷聲醫黏點學覺齡勸歡觀遙卷體Cコ塲舍燒沒" ShinJitai_Text = "来両亜悪帯専頼拝乗奥帰効斉斎雑会仏仮条伝" & _ "偽価倹益回剰剣剤真区励圧参予気亀嘱単号戦厳獣国" & _ "円囲団図殻壱寿台増壊壌嬢寛実写宝宝窃届属弾弥峡" & _ "峰岳巌楽断広廃廃応庁弐昼画粛尽径従衛恒慎惨懐払" & _ "抜揺拠択担拡摂浅渓滞満渋渋潜潜沢湿済浜瀬滝湾狭" & _ "独猟陥隆随堕険隠隣恵恋収教数晴悩胆臓炉桟横枢様" & _ "楼検桜権隷欧歯残殴為乱鶏辞壮将奨犠与挙誉処戯献" & _ "青茎荘万旧芸蔵薬逸逓遅辺辺塁痴発県砕秘禄禅礼称" & _ "稲穂穏穣並靖竜当党対粋精糸経緑縦総絵継続繊変欠" & _ "聡聴覧塩児虫蚕蛮践踏触謡証訳読譲売賛軽転弁弁弁" & _ "酔醸釈舗鎮鉄鋳鉱間関双霊静麦顕余騒駆駅験髄闘労" & _ "栄営豊艶声医粘点学覚齢勧歓観遥巻体清徳場舎焼没" Dim sSelectedMenu As Integer Dim schPattern, repPattern As String sSelectedMenu = InputBox(" 1 旧字体 → 新字体" & vbCr & " 2 新字体 → 旧字体", "新旧漢字変換") Dim chrRange As Range Dim i, j, x, y, MojiCount, posTxt As Long Dim sText As String Select Case UCase(sSelectedMenu) Case 1 '旧字体 → 新字体 MojiCount = Selection.Characters.Count - 1 For j = 1 To MojiCount Set chrRange = Selection.Characters(1) sText = chrRange.Text x = Selection.Range.Start y = Selection.Range.End If InStr(KyuJitai_Text, sText) <> 0 Then posTxt = InStr(KyuJitai_Text, sText) chrRange.Text = Mid(ShinJitai_Text, posTxt, 1) End If Set chrRange = Nothing ActiveDocument.Range(Start:=x + 1, End:=y).Select MojiCount = MojiCount - 1 Next Case 2 '新字体 → 旧字体 MojiCount = Selection.Characters.Count - 1 For j = 1 To MojiCount Set chrRange = Selection.Characters(1) sText = chrRange.Text x = Selection.Range.Start y = Selection.Range.End If InStr(ShinJitai_Text, sText) <> 0 Then posTxt = InStr(ShinJitai_Text, sText) chrRange.Text = Mid(KyuJitai_Text, posTxt, 1) End If Set chrRange = Nothing ActiveDocument.Range(Start:=x + 1, End:=y).Select MojiCount = MojiCount - 1 Next End Select Selection.Collapse Direction:=wdCollapseEnd End Sub