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

もう簡単に今ちょっと使いたいだけというひとは
Excel表テキスト化ツール
こちらが便利です
ただ内部資料を外部にポストするのがまずいってことも。。

昔は  Excel文字罫線変換
http://www.ne.jp/asahi/soft/miday/Excel_Moji/Excel_Moji.html
こちらなど使わせていただいてて便利だったんですが、
フリーとかのインスコが結構厳しい会社とかもあったりして困ったので

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

以下をコピーして tekitoumei.vbs で保存すればダブクリで実行します。
先にエクセル表などを クリップボードにコピーした状態で
実行すると クリップボード内容がテキスト表になります

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)
'書くセル文字列分割とカラム数最大値を取得する
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

'-----------------------------------------------上線
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, "┃")
		'カラムの文字列をセットする
		objRegExp.Pattern = "^[0-9,]+$" '数字とカンマのみ
		if objRegExp.Test(fields(j)) =true then
			'数値のみは右詰
			outStr=outStr  & String(field_lens(j)-LengthByHankaku(fields(j)), " ")& fields(j)
		else
			outStr=outStr & fields(j) & String(field_lens(j)-LengthByHankaku(fields(j)), " ")
		end if
		
		'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

	
	
	SetClipboardText(outStr)
	MsgBox("クリップボードにコピーしました")


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


'-----------------------------------------------
'
' クリップボード取得
'
'-----------------------------------------------
Function GetClipboardText()
   Dim objHTML
   Set objHTML = CreateObject("htmlfile")

    GetClipboardText = Trim(objHTML.ParentWindow.ClipboardData.GetData("text"))
End Function

'-----------------------------------------------
'
' クリップボードコピー
'
'-----------------------------------------------

Function SetClipboardText(text)
	Set WshShell = CreateObject("WScript.Shell")
	WshShell.Exec("clip").StdIn.Write text
	Set WshShell = Nothing
End Function