エクセル表から罫線文字の表を作成するvbスクリプト

エクセルの表をコピーして テキストベースの表を作成
します
Excel表を罫線文字の表に変換、エクセルだけじゃなく 改行タブ区切りならテキストの表になります。


   Dim objHTML
    Set objHTML = CreateObject("htmlfile")
 	Set objRegExp = New RegExp

dim tblText
dim lines
dim fields
Dim line_lens()
Dim field_lens()
dim field_max

dim hankaku
dim zenkaku

dim hankaku_len
dim zenkaku_len
dim colLen
field_max=0

	Set objRegExp = New RegExp

'クリップボードのテキストを取得する
tblText=GetClipboardText()
	objRegExp.Pattern = "[\r\n]+$" '半角以外をリプレース 半角が残る
	tblText=objRegExp.Replace(tblText,"")

'改行で分割する
lines=split(trim(tblText),vbCrLf)
'書くセル文字列分割とカラム数最大値を取得する
MsgBox(UBound(lines))
for i=0 to UBound(lines)
	
	fields=split(lines(i),vbTAB)
	lines(i)=fields
	'カラム最大値を取得
	if field_max<UBound(fields) then
		field_max=UBound(fields)
	end if
next

Redim field_lens(field_max)

for i=0 to UBound(field_lens) 
	 field_lens(i)=0
next

'各カラム幅最大値を取得する	
for i=0 to UBound(lines)
	fields=lines(i)
	for j=0 to UBound(fields)
		colLen=LengthByHankaku(fields(j))
		'偶数化
		colLen=colLen+(colLen Mod 2)
		'MsgBox(fields(j) &"="&colLen)
		if field_lens(j)<colLen then
			field_lens(j)=colLen
		end if
	next
next

'lefttop="┏"
'lefttop="┏"
'leftbottom="┗"
'vline="┃"
'hline="━"
'midtop="┳"
'midbottom="┻"
'midmid="╋"
'righttop="┓"
'rightbottom="┛"
'┣

'-------------------------------------------------------上線
outStr="┏"

for i=0 to UBound(field_lens)
	outStr=outStr & String(field_lens(i)/2, "━")
	if i< UBound(field_lens) then
		outStr=outStr & "┳"
	else
		outStr=outStr & "┓"
	end if
next
	
'-------------------------------------------------------出力
'
for i=0 to UBound(lines)
	fields=lines(i)
	outStr=outStr & vbCr
	for j=0 to UBound(fields)
		outStr=outStr & String(1, "┃")
		outStr=outStr & fields(j) & String(field_lens(j)-LengthByHankaku(fields(j)), " ")
		'MsgBox(field_lens(j))
	next
	'右端
	outStr=outStr & String(1, "┃") 
	
	if i < UBound(lines) then
		LT="┣"
		MD= "╋"
		RT="┫"
	else
		LT="┗"
		MD= "┻"
		RT="┛"
	end if
	
	'罫線
	outStr=outStr & vbCr
	outStr=outStr & String(1, LT)
	for j=0 to UBound(fields) 
		outStr=outStr & String(field_lens(j)/2, "━")
		'MsgBox(field_lens(j))
		if j<UBound(fields) then
			outStr=outStr & String(1, MD)
		else
		end if
	next
	'右端
	outStr=outStr & String(1, RT) 
next

	
	MsgBox("クリップボードでコピーします。クリップボードアクセスを許可してね。")
	
	SetClipboardText(outStr)


'-----------------------------------------------------------------------------------
'
' 半角換算文字数
'
'-----------------------------------------------------------------------------------
Function LengthByHankaku(str)
	'半角文字数
	objRegExp.Pattern = "[^\x01-\x7E]+" '半角以外をリプレース 半角が残る
	hankaku=objRegExp.Replace(str,"")
	'MsgBox("半角:" & hankaku)
	'全角文字数
	objRegExp.Pattern = "[\x01-\x7E]+" '半角をリプレース 全角が残る
	zenkaku=objRegExp.Replace(str,"")
	'MsgBox("全角:"& zenkaku)
	'各フィールドの半角換算文字数を取得する
	colLen=Len(zenkaku)*2+Len(hankaku)
	LengthByHankaku = colLen
End Function


'-----------------------------------------------------------------------------------
'
' クリップボード取得
'
'-----------------------------------------------------------------------------------
Function GetClipboardText()
    GetClipboardText = Trim(objHTML.ParentWindow.ClipboardData.GetData("text"))
End Function

Function SetClipboardText(text)
	Set objIE = CreateObject("InternetExplorer.Application")
	objIE.Navigate("about:blank")
	Do While objIE.Busy
	' 100 ミリ秒
	Wscript.Sleep 100
	Loop
	 
	Call objIE.document.parentWindow.clipboardData.SetData( "Text",text )
	objIE.Quit

End Function