If　r = ""　Then　　　'「キャンセル」 ボタンがクリックされたら
　Wscript.Quit　　　　　'スクリプトを終了する
End If

If　IsNumeric ( r )　Then　　'正しく入力された場合
　　ensyu = 2 * PI * r
　　menseki = PI * (r^2)
　　kyumen = 4 * PI * (r^2)
　　taiseki = 4 * PI * (r^3) / 3
　　msg = "半径"　&　r　&　"の円の円周 = "　&　ensyu　&　vbCr _
　　　　 　　　　　&　"円の面積 = "　&　menseki　&　vbCr _
　　　　　　　　　 &　"球の表面積 = "　&　kyumen　&　vbCr _
　　　 　　　　　　&　"球の体積 = "　&　taiseki
　　Msgbox msg ,  , "計算結果"

　Else　　　　'何も入力されないか数字でない場合
　　MsgBox　"InputBoxには数字を入力してください。" ,　, "calcr.vbs"
End If

On Error Resume Next

'ドラッグアンドドロップされたファイルのフルパス名を取得
Set objArgs = Wscript.Arguments
strfname = objArgs(0)
Set objArgs = Nothing

'使い方を間違えてファイル名が取得できなかった場合のヘルプ
'個人だけで使うのであれば必要ない
If strfname = "" Then
WScript.Echo "テキストの文字数を数えて表示するスクリプトです。" & vbCr & _
　　　　　　　　　"数えるテキストファイルのアイコンをこの上にドラッグ&ドロップします。"

WScript.Quit
End If

'FileStreamオブジェクトを用意する。
Set objFSys = CreateObject ("Scripting.FileSystemObject")
Set objFileStream = objFsys.OpenTextfile (strfname)

str = ""
linenum = 0
'FileStreamオブジェクトから一行づつ読みこむ
Do Until objFileStream.AtEndofStream
str = str & objFileStream.ReadLine
linenum = linenum + 1
Loop

'文字数を計算して表示
WScript.Echo "行数 = " &　linenum　&　vbcr　& _
　　　　　　　　　"文字数 = "　&　Len (str)

Set objFileStream = Nothing
Set objFsys = Nothing
WScript.Quit

'editerに編集に使用するテキストエディタを指定する。パスが通っていないときはパスも指定する。
editer = "notepad.exe"

Set objFsys = CreateObject ("Scripting.FilesystemObject")

Do　While　True　　　'正しいファイル名が入力されるまで繰り返す処理
filename = InputBox ("作成するスクリプトファイル名を指定して下さい" 　&　 vbCr & _
　　　　　　　　　　　　"(拡張子 vbs は付けないで下さい)", "新規スクリプトの作成", "無題")

If 　filename = ""　 Then　　　　　　'キャンセルボタンがクリックされたら終了
　　Set objFsys = Nothing
　　Wscript.Quit
Else
　　filename = filename　 &　 ".vbs"

If 　objFsys.FileExists (filename)　Then
　MsgBox "この名前は使用済みです。別の名前を指定して下さい。",　vbInformation,　"newvbs.vbs"
Else　　　　　　　　'正しくファイル名が入力されたら
　Exit Do　　　　　'Do ～ Loop を抜ける命令
End If

End If

Loop

'ファイルを新規作成
objFsys.CreateTextfile filename
Set objFsys = Nothing

'ShellオブジェクトのRunメソッドでエディタを起動する
Set objShell = Wscript.CreateObject ("Wscript.Shell")
objShell.Run　editer　&　" "　&　filename　　'エディタ実行ファイル名とファイル名の間の半角空白は必須

Wscript.Sleep 200 '次の行を実行するのを200ミリ秒遅らせる

Set objShell = Nothing
Wscript.Quit

'次の定数 FORMAT，EXTER を換えれば他の形式に変換するように作り変えることが出来る。
Const FORMAT = -4158　　'text形式定数
Const EXTER = "txt"　　'拡張子
Const MSGTITLE = "convfromxls.vbs"

On Error Resume Next　　'途中でエラーが発生してもメモリにExcelを残さないように

Set objArgs = WScript.Arguments
fpname = objArgs.Item(0)　　　'ファイルのフルパス名取得
Set objArgs = Nothing　　　　　'用が済んだので早めに削除

'間違った使い方したときのメッセージ
If fpname = "" Then
MsgBox　"xlsファイルのアイコンをドラッグ&ドロップして下さい。", , MSGTITLE
WScript.Quit
End If

'WorkBookオブジェクトから必要な情報を取得
set objXs = WScript.CreateObject("Excel.Application")
objXls.Visible=True　　　　　　　　'エラーが発生しないと確認できたら外してもよい
set objBook = objXxls.WorkBooks.Open (fpname)
bookpath=objBook.Path　　　　　'ブックのディレクトリ取得
bookname=objBook.Name　　　　'ブック名を取得
base_ext=split (bookname,".") 　'ブック名をベース名と拡張子に分割
basename=base_ext(0)　　　　　 'ベース名
exten=base_ext(1) 　　　　　　　　'拡張子

'xls形式ではないファイルをドロップされた場合を想定して
If 　Lcase(exten) <> "xls"　Then
　　MsgBox "Excelのファイルではありません。終了します。", , MSGTITLE
　　objXls.Quit
　　Set objXls = Nothing
　　WScript.Quit
End If

'保存するファイルのフルパス名を決定
savefile = bookpath　& "\" & basename　& "." & EXTER

'保存するファイルと同名のファイルが存在する場合いったんそれを削除する
Set objFsys = CreateObject ("Scripting.FileSystemObject")

If 　bjFsys.FileExists (savefile) = True　Then
　　ret = MsgBox ("保存するファイルと同名のファイルが既に存在します。" & vbCr & _
　　　　　　　　"削除して続行します。", vbOkCancel+vbCritical, MSGTITLE)
　　If ret = vbOk　Then
　　　　objFsys.DeleteFile savefile
　　　Else
　　　　MsgBox "変換をしないで終了しました。", , MSGTITLE
　　　　Set objFsys = Nothing
　　　　objXls.Quit
　　　　Set objXls = Nothing
　　　　WScript.Quit
　　End If
End If

objBook.SaveAs savefile, FORMAT　　'変換ファイルの作成を実行

'変換元のファイルを削除するかどうかたずねてから削除を実行する
ret = MsgBox ("xlsファイルを同名の" & exter & "ファイルとして保存しました。" & vbCr _
　　　　　& "元のxlsファイルを削除しますか。", vbYesNo+vbQuestion+vbDefaultButton2, MSGTITLE)

If　ret = vbYes　Then
　　objFsys.DeleteFile fpname
End If

'終了処理(使ったオブジェクトを開放)
'Closeの引数Falseを付けないとExcel側からメッセージが出る
objBook.Close False
Set objFsys = Nothing
objXls.Quit
Set objXls = Nothing
WScript.Quit

'strtypeの値を他のものに変えるとその一覧表ができる
'そのときは保存ファイル名も変えておく

On Error Resume Next 　　'エラーに備えて入れておく

XLSNAME = "tableofvbs.xls" 　　　'保存ファイル名
strtype = "VBScript Script File"　'vbsファイルのTypeプロパティ

Set objFsys = CreateObject ("Scripting.FilesystemObject")
strDir = objFsys.GetParentFolderName (Wscript.ScriptFullName)　　'本スクリプトのフォルダ
Set objFolder = objFsys.GetFolder (strDir)　　　　　　　　　　　　　 'Folderオブジェクトの取得
Set objFiles = objFolder.Files　　　'Filesオブジェクト－Fileオブジェクトの集合

'Excelアプリケーションオブジェクトの生成
Set objXls = Wscript.CreateObject ("Excel.Application")
objXls.Visible = True　　　　'Excelを表示する(最後は自分で閉じる必要がある)
objXls.WorkBooks.Add　　　'新規にワークブックを追加(ここに表を作成する)

'表の体裁を整える
With objXls
　　.Columns(1).ColumnWidth = 15
　　.Columns(2).ColumnWidth = 40
　　.Columns(3).ColumnWidth = 30
　　.Columns(4).ColumnWidth = 15
　　.Columns(5).ColumnWidth = 15
　　'一行目に項目名を記入する
　　.Cells(1, 1).Value = "ファイル名"
　　.Cells(1, 2).Value = "説明"
　　.Cells(1, 3).Value = "起動方法"
　　.Cells(1, 4).Value = "最終更新日"
　　.Cells(1, 5).Value = "作成日"
End With

rowi = 2 　　　　'２行目から書き始める

For　Each　fi　in　objFiles 　　'おのおののFileオブジェクト( fi で受ける)から情報を取り出して記入

　　If　fi.Type = strtype　Then　　'他のタイプのファイルは除外する
　　　Set　objFst = objFsys.OpenTextFile (fi.Name,　1)　'読み出しモードでTextStreamオブジェクトを取得　　

　　　'次の2行は読み込む行がないとき(たとえば新規のファイル)エラーが発生する。
　　　firstline = objFst.ReadLine　　　　'１行目を読み出す
　　　secondline = objFst.ReadLine　　'２行目を読み出す
　　　 　　　'先頭にOn Error … あるのでエラーあったとしても次の行を実行してくれる。
　　　If Err.Number <> 0 Then
　　　　　firstline = ""　　　　'ぎょうがないときは空白を表示するようにする
　　　　　secondline = ""　　'ぎょうがないときは空白を表示するようにする
　　　　　Err.Clear
　　　End If

　　'データの記入
　　With objXls.ActiveSheet
　　　.Cells(rowi, 1).value = fi.Name
　　　.Cells(rowi, 2).value = firstline
　　　.Cells(rowi, 3).value = secondline
　　　.Cells(rowi, 4).value = fi.DateLastModified
　　　.Cells(rowi, 5).value = fi.DateCreated
　　End with
　　rowi = rowi + 1　　　'次の行へ移動
　End　If
　Set　objFst = Nothing 　　'次のFileオブジェクトに備えて削除
Next

'保存ディレクトリがルートディレクトリのときは "\" は初めから付いている
If　objFolder.isRootFolder = False　Then
　strDir = strDir　&　"\"
End If　　　

'同一フォルダに，用意した名前(XLSNAME)で保存する
objXls.ActiveWorkBook.SaveAs　strDir　&　XlSNAME

'Excel を手動で閉じるときの問い合わせメッセージが出ないようにする
objXls.ActiveWorkBook.Saved = True
Set objFiles = Nothing
Set objFolder = Nothing
Set objFsys = Nothing
Wscript.Quit