WSHのページに戻る

少し実用的なスクリプトを書いてみました。未熟さや書き間違えが原因でうまく動作しなかったらごめんなさい。意とするところを汲んでいただいて訂正なり,更なる改良を加えてよりよいものにしていただくことは望むところです。

  スクリプト目次

calcr.vbs

半径から円と球の情報を計算する。If 文使用例

'半径から円と球の情報を計算する
'アイコンをダブルクリックして実行
Const PI = 3.14
r = InputBox ("半径の大きさを入力してください。", "calcr.vbs")

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

 

str_len.vbs

 テキストファイルの文字数を数えて表示する。文字数制限のある原稿を依頼されたとき、書いている途中で今何文字ぐらいになったかをみるのに使おうと書いてみた。Wordで書いたDoc形式のファイルに対応させるには改良が必要である。

'テキストの文字数を数えて表示する。
'文字数を数えたいファイルのアイコンをこの上にドラッグアンドドロップする。

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

 

newvbs.vbs

 何も記述されていないスクリプトファイルを起動するスクリプト。テキストエディタを起動すると何も書かれていないtxtファイルが開かれるように,常用しているテキストエディタで新たにvbsファイルが開くようにできると便利である。 

'vbsファイルを新規に作成する。そのファイル名はInputBoxで指定する。
'ダブルクリックで実行する。

'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

 

convfromxls.vbs

 xls形式のファイルをこのスクリプトのアイコン上にドロップすることによって,txtファイルに変換する。WorkBookに複数のシートがある場合は想定していないので,1枚目のシートのみが変換の対象になる。できあがったテキストは元のシートの記述形式からは大きくくずれるものがある。大事なファイルなら "元のxlsファイルを削除しますか。"と聞かれたら,「 いいえ 」 を選択してください。

(参考) ファイル形式とFORMATの値
HTML形式 ---> 44 ( EXTER = "htmlあるいはhtm" )
 サイズはむしろ大きくなる。

CSV形式 ---> 6 ( EXTER ="csv" )
 テキストがタブ区切りになるのに対して,コンマ ( , ) 区切りになる。テキスト形式よりこちらの方がいいかもしれない。

'xls形式のファイルを他の形式に変換する
'xlsのファイルアイコンをドラッグ&ドロップする

'次の定数 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

 

vbs_table.vbs

 vbsファイルも作成が進んで数が多くなると名前だけでは内容がわかりにくくなる。Excelのシートに一覧表としてしておくことを自動化してみた。そのために,スクリプトは一つのフォルダにまとめておく。それぞれのスクリプトの1行目には説明文を,2行目には起動の仕方をコメント行として入れておく。本スクリプトも同じフォルダに置いてダブルクリックで実行する。

'vbsファイルの一覧表を作成する。一覧にするファイルと本スクリプトを一つのフォルダに置いておく。
'本スクリプトをダブルクリックして実行

'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     '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    '1行目を読み出す
   secondline = objFst.ReadLine  '2行目を読み出す
       '先頭に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

最後にわたしのスクリプト集をダウンロードできるようにしておきます。中途半端なものやテスト用に使用したもの雑多です。 中にはMsAgentの環境が整っていないと実行できないようなものも含んでいます。興味のある方は ここからどうぞ。


最初のページへ