ソースコード - 変換EUCtoSJIS

これは文字コードをEUCからSJISへ変換するスクリプトです。

変換EUCtoSJISは以下の二つのファイルから構成されています。

• 文字コード.vbs 文字コードクラス定義ファイル
• 変換EUCtoSJIS.wsf 変換スクリプト

動作要件

• Windows Script Host 2.0 (Microsoft Windows 98、Windows NT オプション パック、Windows 2000に含まれている・・・らしい。^^;)
• VBScript Ver 5.5 (IE5以上)

諸注意

エラー処理は特にしていません。ソースコードを読んだ上でお使いください。
このスクリプトの改変・再配布等は自由です。

文字コード.vbs

Option Explicit 
Class KUTENCode
	Private kuCode,tenCode
	Public Property Let ku(value)
		If value>=1 and value<=120 Then
			kuCode=Cbyte(value)
		Else
			Err.Source="クラス KUTENCode"
			Err.Description="区番号が範囲外です。区番号は1〜120の範囲で指定してください。"
			Err.Raise 5021
		End If
	End Property
	Public Property Get ku
		ku=kuCode
	End Property
	Public Property Let ten(value)
		If value=>1 and value<=94 Then
			tenCode=Cbyte(value)
		Else
			Err.Source="クラス KUTENCode"
			Err.Description="点番号が範囲外です。点番号は1〜94の範囲で指定してください。"
			Err.Raise 5021
		End If
	End Property
	Public Property Get ten
		ten=tenCode
	End Property

	Function toJIS()
		'jis1stを左へ8ビットシフトしてjis2ndを加える
		toJIS=(ku+&H20) * &H100 Or ten+&H20
	End Function
	Function toCharAsJIS()
		toJIS=Chr(ku+&H20) & Chr(ten+&H20)
	End Function

	Function toSJIS()
		Dim sjis1st,sjis1st_base
		Dim sjis2nd,sjis2nd_base

		'1区〜62区の場合
		If ku<63 Then
			sjis1st_base=&H80

		'63区以降の場合
		Else
			sjis1st_base=&HC0
		End If

		'偶数区の場合
		If ku Mod 2=0 Then  
			sjis2nd_base=&H9E

		'奇数区の場合
		Else
			'1点〜63点の場合
			If ten<64 Then
				sjis2nd_base=&H3F

			'64点〜94点の場合
			Else
				sjis2nd_base=&H40
			End If
		End If

		sjis1st=sjis1st_base+(ku+1)\2
		sjis2nd=sjis2nd_base+ten

		'sjis1stを左へ8ビットシフトしてsjis2ndを加える
		toSJIS=sjis1st * &H100 Or sjis2nd
	End Function
	Function toChr()
		toChr=Chr(toSJIS())
	End Function

	Function toEUC()
		'euc1stを左へ8ビットシフトしてeuc2ndを加える
		toEUC=(ku+&HA0) * &H100 Or ten+&HA0
	End Function
	Function toCharAsEUC()
		toCharAsEUC=Chr(ku+&HA0) & Chr(ten+&HA0)
	End Function

	Sub fromChr(char)
		Dim tmpChar
		Dim sjis1st,sjis2nd

		tmpChar=Clng("&H" & Hex(Asc(char))) 'tmpCharはlong型（符号付き32ビット）ただし下位16ビット部分だけ使い、符号なし16ビットとして扱う
		'右8ビットシフト
		sjis1st=tmpChar \ &H100
		'先頭8ビットをマスクして消す
		sjis2nd=tmpChar Or &HFF00 Xor &HFF00

		fromSJIS sjis1st,sjis2nd
	End Sub

	Sub fromJIS(jis1st,jis2nd)
		ku=jis1st-&H20
		ten=jis2nd-&H20
	End Sub

	Sub fromSJIS(sjis1st,sjis2nd)
		Dim sjis1st_base,sjis1st_capital
		Dim sjis2nd_base

		'偶数区の場合
		If sjis2nd > &H9E Then
			sjis1st_capital=0			
			sjis2nd_base=&H9E
		'奇数区の場合
		Else
			sjis1st_capital=1

			'1点〜63点の場合
			If sjis2nd < &H7F Then
				sjis2nd_base=&H3F
			'64点〜94点の場合
			Else
				sjis2nd_base=&H40
			End If
		End If

		'1区〜62区の場合
		If sjis1st < &HA0 Then
			sjis1st_base=&H80
		'63区以降の場合
		Else
			sjis1st_base=&HC0
		End If

		ku=(sjis1st-sjis1st_base)*2-sjis1st_capital
		ten=sjis2nd-sjis2nd_base
	End Sub

	Sub fromEUC(euc1st,euc2nd)
		ku=euc1st - &HA0
		ten=euc2nd -&HA0
	End Sub

	Sub fromKANA(kanaCode)
		If kanaCode<1 Or kanaCode>63 Then
			Err.Source="クラス KUTENCode"
			Err.Description="codeの値が範囲外です。カナコードは1〜63の範囲で指定してください。"
			Err.Raise 5021
		Else
			fromChr Mid("。「」、・ヲァィゥェォャュョッーアイウエオカキクケコサシスセソタチツテトナニヌネノハヒフヘホマミムメモヤユヨラリルレロワン゛°",kanaCode,1)
		End If
	End Sub
End Class
Class KANACode
	Private kanaCode
	Public Property Let code(value)
		If value>=1 and value<=63 Then
			kanaCode=Cbyte(value)
		Else
			Err.Source="クラス KANACode"
			Err.Description="codeの値が範囲外です。カナコードは1〜63の範囲で指定してください。"
			Err.Raise 5021
		End If
	End Property
	Public Default Property Get code 
		code=kanaCode
	End Property

	Function toJIS
		toJIS=code+&H20
	End Function
	Function toSJIS
		toSJIS=code+&HA0
	End Function
	Function toChr
		toChr=Chr(toSJIS())
	End Function
	Function toEUC
		toEUC=&H8E00 Or code+&HA0
	End Function

	Sub fromJIS(charCode)
		code=charCode-&H20
	End Sub
	Sub fromSJIS(charCode)
		code=charCode-&HA0
	End Sub
	Sub fromChr(char)
		Dim tmpChar
		tmpChar=Clng("&H" & Hex(Asc(char))) 'tmpCharはlong型（符号付き32ビット）ただし下位16ビット部分だけ使い、符号なし16ビットとして扱う
		fromSJIS tmpChar
	End Sub
	Sub fromEUC(euc1st,euc2nd)
		code=euc2nd-&HA0
	End Sub
End Class

変換EUCtoSJIS.wsf

<job id="EUCtoSJIS">
<script language="VBScript" src="文字コード.vbs"/>
<script language="VBScript">

'文字コードをEUCからSJISへ変換するスクリプト
'制作者 clone_01@yahoo.co.jp
'最終更新 午後 05:00 00/11/10

'使用上の注意
'このスクリプトを使った事により発生したいかなる損害についても制作者は一切責を負いません。
'	ソースコードを読んだ上で、自己責任において使ってください。
'
'このスクリプトの実行には 文字コード.vbs が必要です。
'	同じフォルダに文字コード.vbsをおくか、src属性を書き換えてパスを通してください。
'
'文字コードの自動判別機能は付いていません。
'	EUC以外のコードで保存されたファイルを変換すると意味不明な文字列になります。(^^;
'
'元になるファイルのサイズ(単位：バイト)が奇数の場合は一時的に作業用ファイルを生成します。
'	これはユニコードとしてファイルからデータを読み込むためファイルサイズが奇数だと最後の1バイトが読み込めないので、
'	作業用ファイルの最後尾にスペース(ASCIIコード)を付加し、ファイルのサイズを偶数にするからです。
'
'実行後に スクリプトと同じフォルダに "SJIS_元のファイル名.txt" という名前のファイルを生成します。
'	同名のファイルがあった場合は上書きします。
'
'ファイルサイズが大きいと処理できない事があります。
'	ReadAllでデータを全部読み込んでいるからです。

'使い方
'EUCのテキストファイルをこのスクリプトのアイコンにドラッグ＆ドロップするだけ。
'処理が終わると"完了"のメッセージボックスがでます。

Option Explicit
Dim WshShell
Dim i
For i = 0 to WScript.Arguments.Count - 1
	ConvertEUCtoSJIS WScript.Arguments(i)
Next

Set WshShell = WScript.CreateObject("WScript.Shell")
WshShell.AppActivate "EUCtoSJIS.wsf"

MsgBox "変換完了",vbOKOnly,"EUCtoSJIS"

'ファイルの操作、改行文字の置換はこのプロシージャで処理する。
Sub ConvertEUCtoSJIS(filePath)
	Const ForReading = 1, ForWriting = 2, ForAppending = 8
	Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
	Const TMP_FILE_NAME="TMP_EUCtoSJIS.tmp"
	Dim fso,file,textStream
	Dim fName,fPath
	Dim oddFlg,tmpStr

	'メモ帳をひらいて表示する場合
	Dim WshShell

	Set fso = CreateObject("Scripting.FileSystemObject")
	Set file=fso.GetFile(filePath)
	'名前を取得しておく
	fName=file.Name
	fPath="SJIS_" & file.Name

	If file.size>0 Then
		'ファイルサイズが奇数の場合はテンポラリファイルにコピーし、ファイルの最後尾にスペース(ASCIIコード)を付加する
		If file.size mod 2 =1 Then
			file.Copy TMP_FILE_NAME,True
			Set file=fso.GetFile(TMP_FILE_NAME)
			Set textStream = file.OpenAsTextStream(ForAppending,TristateFalse)
			textStream.Write Chr(&H20)
			textStream.Close
			oddFlg=True
		Else
			oddFlg=False
		End If

		'ユニコードで文字列取得
		Set textStream = file.OpenAsTextStream(ForReading,TristateTrue)
		tmpStr=textStream.ReadAll
		textStream.Close

		If oddFlg Then file.Delete

		'EUCからSJISへ変換
		tmpStr = EUCtoSJIS(tmpStr,oddFlg)
		
		'改行文字をそろえる。
		tmpStr = replaceMatches(tmpStr,"(?!\r)\n|\r(?!\n)|\r\n",vbNewLine)
	End If

	'ASCIIファイルとしてデータを保存。
	Set textStream=fso.CreateTextFile(fPath,True,TristateFalse)
	textStream.Write tmpStr
	textStream.Close

	'メモ帳を開いて表示する。
	Set WshShell = WScript.CreateObject("WScript.Shell")
	WshShell.Run ("notepad.exe " & fPath)

	'ワードパッドの場合
	'WshShell.Run ("wordpad.exe " & fPath)
End Sub

'汎用正規表現置換関数(サンプルコードをパクっただけ^^;
Function replaceMatches(mainStr,patrn, replaceStr)
   Dim regEx ' 変数を作成します。
   Set regEx = New RegExp   ' 正規表現を作成します。
   regEx.Pattern = patrn   ' パターンを設定します。
   regEx.Global = True   ' 文字列全体を検索するように設定します。
   replaceMatches = regEx.Replace(mainStr,replaceStr)   ' 置換を実行します。
End Function

Function getByte(mainStr,index)
	getByte=AscB(MidB(mainStr,index,1))
	index=index+1
End Function

'変換関数
Function EUCtoSJIS(mainStr,oddFlg)
	Dim length,bufStr,index,tmpStr
	Dim kuten,kana
	Dim char1st,char2nd

	Set kuten=new KUTENCode
	Set kana=new KANACode

	length=lenB(mainStr)
	If oddFlg Then length=length-1

	index=1
	Do While index<=length
		char1st=getByte(mainStr,index)

		If char1st<&H20 Or char1st=&H7F Then '制御コード
			tmpStr=Chr(char1st)
		ElseIf char1st<&H7F Then 'ASCII文字/JISローマ字
			tmpStr=Chr(char1st)
		ElseIf char1st>&HA0 And char1st<&HFF Then '漢字 第一バイト
			'第二バイトを取得
			If index<=length Then
				char2nd=getByte(mainStr,index)
				If char2nd>&HA0 And char2nd<&HFF Then '漢字 第二バイト
					kuten.fromEUC char1st,char2nd
					tmpStr=kuten.toChr()
				Else'不正な文字コード
					tmpStr="%" & Hex(char1st)
					index=index-1 '再検討
				End If
			Else '不正な文字コード
					tmpStr="%" & Hex(char1st)
			End If
		ElseIf char1st=&H8E Then 'SS2(半角カナ)
			If index<=length Then
				char2nd=getByte(mainStr,index)
					If char2nd > &HA0 And char2nd < &HE0 Then
						kana.fromEUC char1st,char2nd
						tmpStr=kana.toChr()
					Else'不正な文字コード
						tmpStr="%SS2%" & Hex(char2nd)
				End If
			Else '不正な文字コード
				tmpStr="%SS2"
			End If			
		ElseIf char1st=&H8F Then 'SS3(補助漢字)
			'手抜きです(^^;
			tmpStr="■"
			index=index+2
		Else '不正な文字コード
			tmpStr="%" & Hex(char1st)
		End If

		bufStr=bufStr & tmpStr
	Loop

	EUCtoSJIS=bufStr
End Function
</Script>
</Job>