Dragon-Ark

vbscriptでmsxmlを利用してhttpアクセスする例です。
第一引数はアクセスするURL、第二引数はアクセスした内容を保存するファイル名です。

「Set OBJ_Http = WScript.CreateObject(“MSXML2.ServerXMLHTTP”)」の部分は、
「Set OBJ_Http = WScript.CreateObject(“Microsoft.XMLHTTP”)」としてもアクセス出来ます。

違いについてはMicrosoftのサポート情報を参照して下さい。
http://support.microsoft.com/kb/290761/ja

Option Explicit


  Dim OBJ_Args

  Set OBJ_Args = WScript.Arguments


  If OBJ_Args.Count <> 2 Then

    WScript.Echo "Usage: httpget URL Path"
    WScript.Quit 1


  Else

    HttpGet OBJ_Args(0),OBJ_Args(1)


  End If




Sub HttpGet(ByVal STR_URL, ByVal STR_Path)


  Const adTypeBinary = 1 'Binary
  Const adTypeText   = 2 'Text

  Const adSaveCreateNotExist  = 1
  Const adSaveCreateOverWrite = 2


  Dim OBJ_Http
  Dim OBJ_ADO

  Set OBJ_Http = WScript.CreateObject("MSXML2.ServerXMLHTTP")

  Call OBJ_Http.Open("GET", STR_URL, False)

  If Err.Number <> 0 Then

      WScript.Echo "エラー:" & Err.Description
      WScript.Quit 1

  End If

  OBJ_Http.Send

  If Err.Number <> 0 Then

    WScript.Echo "エラー:" & Err.Description
    WScript.Quit 1

  End If

  If OBJ_Http.status <> 200 Then

    WScript.Echo "Return Coad:" & OBJ_Http.status
    WScript.Quit 1

  End If


  Set OBJ_ADO = WScript.CreateObject("ADODB.Stream")
  
  OBJ_ADO.Type = adTypeBinary
  OBJ_ADO.Open
  OBJ_ADO.Position = 0

  OBJ_ADO.Write OBJ_Http.responseBody
  OBJ_ADO.SaveToFile STR_Path, adSaveCreateNotExist
  OBJ_ADO.Close

  Set OBJ_Http = Nothing
  Set OBJ_ADO  = Nothing


End Sub

Windows 7 64bit + Office 2010 64Bit ベータにて確認。

*.mdb(～Access2003) へのアクセスには jet(Microsoft.Jet.OLEDB.4.0) によるアクセス、
*.accdb(Access2007～) へのアクセスには ACE(Microsoft.ACE.OLEDB.12.0) を使用する。

jetは、c:\Windows\SysWOW64\cscript.exe (32bit) にて、
ACEは、c:\Windows\system32\cscript.exe (64bit) にて実行する。

vbscriptを利用してOutlook Expressのメールルールをバックアップする例です。
このスクリプトはバックアップファイル(レジストリファイル)の保存先、ファイル名を引数で渡します。

例:
(script名) c:\test.reg

バックアップしたファイルは、ダブルクリックすることでインポートが可能です。
ここでの注意点として、OSを再インストールする度にGUIDが変わってしまいます。
バックアップした時とインポートする時の状況が違う時は、バックアップしたファイルをメモ帳などで開き、
GUIDを置き換える必要があります。

例:
バックアップ元のGUID　{xxxxxxxx-xxxx-xxxx-xxxx-xxxxxxxxxxxx}
インポート先のGUID　　{zzzzzzzz-zzzz-zzzz-zzzz-zzzzzzzzzzzz}
1.インポート先のGUIDを調べる。
2.バックアップ元のファイルを開き、{xxx～}を置き換える。
メモ帳の場合は「検索する文字列」にバックアップ元のGUIDを、「置換後の文字列」にインポート先のGUIDを入れましょう。

また、このスクリプトでは、reg.exeというファイルを利用しています。Windows XPから標準でインストールされているものになります。
Windows 2000ではreg.exeが入っていないため、使えません…

ソースのダウンロードは こちら です。

Option Explicit

'#######################################################
'# Global-Configration #
'#######################################################

Const OpenTextFileForReading = 1
Const OpenTextFileForWriting = 2
Const OpenTextFileForAppending = 8

Const REG_SZ = 1
Const REG_EXPAND_SZ = 2
Const REG_BINARY = 3
Const REG_DWORD = 4
Const REG_MULTI_SZ = 7

'*************************
' Call Main Program
'*************************
Main()

'*************************
' Start Main Program
'*************************

Sub Main()

'#######################################################
'# Local-Configration #
'#######################################################

Dim OBJ_WshShell 'WSH Shell Object
Dim OBJ_FSO 'File System Object
Dim OBJ_Folders 'Folder Object
Dim OBJ_Args 'Argument Object

Dim COL_Folders 'Collection Object

Dim STR_FileName 'String Object
Dim STR_StoreOwner 'String Object
Dim STR_RulePath 'String Object
Dim STR_LogFolder 'String Object
Dim STR_LogFile 'String Object
Dim STR_Temp 'String Object
Dim i

Set OBJ_WshShell = WScript.CreateObject("WScript.Shell")
Set OBJ_FSO = WScript.CreateObject("Scripting.FileSystemObject")
Set OBJ_Args = WScript.Arguments

'引数チェック
If OBJ_Args.Count = 1 Then

STR_FileName = OBJ_Args(0)

If Right(LCase(STR_FileName), 4) = ".reg" Then

Else

STR_FileName = STR_FileName & ".reg"

End If

If OBJ_FSO.FileExists(STR_FileName) Then

WScript.Echo "エラー:出力先に同名のファイルが存在します。処理を続行出来ません。"
WScript.Quit 1

End If

Else

WScript.Echo "エラー:引数の数が不正です。処理を続行出来ません。プログラムを中止します。"
WScript.Quit 1

End If

'【Get Mail Store Owner & Mail Store Path】
STR_StoreOwner = OBJ_WshShell.RegRead("HKEY_CURRENT_USER\Identities\Last User ID")
If Err.Number <> 0 Then

WScript.Echo "エラー:処理実行中にエラーが発生しました。処理を続行出来ません。プログラムを中止します。"
Err.Clear
Set OBJ_FSO = Nothing
WScript.Quit 1

End If

STR_RulePath = """HKEY_CURRENT_USER" & "\Identities\" & STR_StoreOwner & "\Software\Microsoft\Outlook Express\5.0\Rules"""
If Err.Number <> 0 Then

WScript.Echo "エラー:処理実行中にエラーが発生しました。処理を続行出来ません。プログラムを中止します。"
Err.Clear
Set OBJ_FSO = Nothing
WScript.Quit 1

End If

'レジストリのExport
OBJ_WshShell.Run "reg.exe export " & STR_RulePath & " " & STR_FileName, 0, True
If Err.Number = 0 Then

WScript.Echo "レジストリのバックアップは正常に完了しました。出力したファイルは " & STR_FileName & " です。"
WScript.Quit 0

Else

WScript.Echo "エラー:レジストリのバックアップに失敗しました。"
WScript.Quit 1

End If

End Sub

vbscriptにてOutlook Exressのメールファイル(.dbx)の一覧とサイズを出力する例です。

Option Explicit
'On Error Resume Next

'#######################################################
'# Global-Configration #
'#######################################################

Const OpenTextFileForReading = 1
Const OpenTextFileForWriting = 2
Const OpenTextFileForAppending = 8

Const HKEY_CURRENT_USER = &H80000001

'*************************
' Call Main Program
'*************************
Main()

'*************************
' Start Main Program
'*************************

Sub Main()

'#######################################################
'# Local-Configration #
'#######################################################

Dim OBJ_WshShell 'WSH Shell Object
Dim OBJ_FSO 'File System Object
Dim OBJ_Folders 'Folder Object

Dim COL_Folders 'Collection Object

Dim STR_FileName 'String Object
Dim STR_StoreOwner 'String Object
Dim STR_StorePath 'String Object
Dim STR_LogFolder 'String Object
Dim STR_LogFile 'String Object
Dim STR_Temp 'String Object
Dim i

Set OBJ_WshShell = WScript.CreateObject("WScript.Shell")
Set OBJ_FSO = WScript.CreateObject("Scripting.FileSystemObject")

'【Get Mail Store Owner & Mail Store Path】
STR_StoreOwner = OBJ_WshShell.RegRead("HKEY_CURRENT_USER\Identities\Last User ID")
If Err.Number <> 0 Then

STR_Work = MsgBox("処理実行中にエラーが発生しました。処理を続行出来ません。プログラムを中止します。" & vbCrLf & "Error Code: RegRead Error-001" ,vbOkOnly + vbCritical,"エラーが発生しました")
Err.Clear
Set OBJ_FSO = Nothing
WScript.Quit 1

End If

STR_StorePath = OBJ_WshShell.RegRead("HKEY_CURRENT_USER\Identities\" & STR_StoreOwner & "\Software\Microsoft\Outlook Express\5.0\Store root")
If Err.Number <> 0 Then

STR_Work = MsgBox("処理実行中にエラーが発生しました。処理を続行出来ません。プログラムを中止します。" & vbCrLf & "Error Code: RegRead Error-002" ,vbOkOnly + vbCritical,"エラーが発生しました")
Err.Clear
Set OBJ_FSO = Nothing
WScript.Quit 1

End If

WScript.Echo "No,ファイル名,ファイルサイズ(MB)"

'【Get MailBox Folder & File-Size】
Set OBJ_Folders = OBJ_FSO.GetFolder(STR_StorePath)
Set COL_Folders = OBJ_Folders.Files
i = 1

For Each STR_FileName In COL_Folders

If LCase(Right(STR_FileName,4)) = ".dbx" Then

WScript.Echo i & "," & STR_FileName & "," & Round(STR_FileName.Size / 1000000,1)
i = i + 1

End If

Next

End Sub

WSHを使用して、OSの起動時間と起動してからの経過時間を表示する例です。
WMIで各値を取得するのですが、UTCで値が返ってきますので、このサイトで紹介した
UTCを変換する関数を利用しています。

Option Explicit

Call Uptime()

'===========================================================================

Sub Uptime()

Dim OBJ_WMIService
Dim OBJ_Item
Dim COL_Item

Dim STR_Computer
Dim STR_NameSpace

Dim STR_BootUpTime
Dim STR_LocalTime
Dim STR_Work
Dim STR_Day
Dim STR_Hour
Dim STR_Min

STR_Computer = "."
STR_NameSpace = "/root/cimv2"

Set OBJ_WMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & STR_Computer & STR_NameSpace)

If Err.Number <> 0 Then

WScript.Echo "Error=" & Err.Number
WScript.Echo "ERROR Code=" & Err.Number & " Description=" & Err.Description
Err.Clear
Exit Sub

End If

Set COL_Item = OBJ_WMIService.ExecQuery("SELECT * FROM Win32_OperatingSystem")

For Each OBJ_Item In COL_Item

STR_BootUpTime = OBJ_Item.LastBootUpTime
STR_LocalTime = OBJ_Item.LocalDateTime

Next

STR_BootUpTime = ConvertUTCToDate(STR_BootUpTime)
STR_LocalTime = ConvertUTCToDate(STR_LocalTime)

STR_Work = DateDIff("n", STR_BootUpTime, STR_LocalTime)

STR_Day = Fix((STR_Work / 60 ) / 24)
STR_Hour = (STR_Work / 60) Mod 24
STR_Min = STR_Work Mod 60

WScript.Echo "起動時刻: " & STR_BootUpTime
WScript.Echo "経過時間: " & STR_Day & " 日 " & STR_Hour & " 時間 " & STR_Min & " 分"

End Sub

'===========================================================================

Function ConvertUTCToDate(STR_DateTime)

ConvertUTCToDate = CDate(Mid(STR_DateTime, 5, 2) & "/" & _
Mid(STR_DateTime, 7, 2) & "/" & Left(STR_DateTime, 4) & " " & _
Mid(STR_DateTime, 9, 2) & ":" & _
Mid(STR_DateTime, 11, 2) & ":" & _
Mid(STR_DateTime, 13, 2))

End Function

WSHを利用してメールを送信する例です。
今時のメール送信はSMTP Authなどが実装されている例が多いのですが、
今回の例は、SMTP Authには対応していません。(別途、紹介します)

パラメータは以下の通り。

Send_Msg “SMTPモード”,”SMTPサーバ”,”SMTPポート”,”送信元メールアドレス”,”宛先メールアドレス”,”CC宛先”,”BCC宛先”,”件名”,”本文”

Dim STR_SmtpHost
Dim STR_SmtpPort
Dim STR_MsgFrom
Dim STR_MsgTo
Dim STR_MsgCc
Dim STR_MsgBcc
Dim STR_MsgSubject
Dim STR_MsgBody

STR_SmtpHost = "xxx"
STR_SmtpPort = "xx"
STR_MsgFrom = "xxx@xxx.com"
STR_MsgTo = "xxx@yyy.com"
STR_MsgCc = ""
STR_MsgBcc = ""
STR_MsgSubject = "aaaa"
STR_MsgBody = "bbb"

Call Send_Msg(STR_SmtpHost, STR_SmtpPort, STR_MsgFrom, STR_MsgTo, STR_MsgCc, STR_MsgBcc, STR_MsgSubject, STR_MsgBody)

Function Send_Msg(STR_SmtpHost, STR_SmtpPort, STR_MsgFrom, STR_MsgTo, STR_MsgCc, STR_MsgBcc, STR_MsgSubject, STR_MsgBody)

Set OBJ_EMail = CreateObject("CDO.Message")

OBJ_EMail.From = STR_MsgFrom
OBJ_EMail.Subject = STR_MsgSubject
OBJ_EMail.TextBody = STR_MsgBody

OBJ_EMail.To = STR_MsgTo
OBJ_EMail.Cc = STR_MsgCc
OBJ_EMail.Bcc = STR_MsgBcc

OBJ_EMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
OBJ_EMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = STR_SmtpHost
OBJ_EMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = STR_SmtpPort

OBJ_EMail.Configuration.Fields.Update
OBJ_EMail.Send

Set OBJ_EMail = Nothing

End Function

以前にSystemアカウントでプログラムを起動する投稿をしましたが、
WSHにて書いてみました。(以外にあっさりでしたが…)

今回のコードはとりあえず、コマンドプロンプトを起動します。
コマンドプロンプトさえ起動すれば、そこで実行するコマンドは全てSystemアカウントで実行されます。

Option Explicit
  Dim OBJ_WshShell    'WSH Shell Object
  Dim STR_Time        'String Object

  Set OBJ_WshShell = WScript.CreateObject("WScript.Shell")
  STR_Time = DateAdd("n", 1 , Time())

  OBJ_WshShell.run "at " & STR_Time & " /interactive" & " cmd /K",0

Scriptのダウンロードは こちら です。

Shellを利用し、WindowsXP、Vistaでファイル圧縮を行います。

例では、”C:\test.txt” を”C:\test.zip” に圧縮しています。

Option Explicit

 
  MakeZip "C:\test.txt", "C:\test.zip"

Sub MakeZip(STR_TargetFile ,STR_SaveFile)
  Dim OBJ_FSO
  Dim OBJ_ZIP
  Dim OBJ_Shell
  Dim ARR_Hex
  Dim STR_Temp
  Dim i

  Set OBJ_FSO = CreateObject("Scripting.FileSystemObject")
  ARR_Hex = Array(80, 75, 5, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0)

  For i = 0 To UBound(ARR_Hex)

    STR_Temp = STR_Temp & Chr(ARR_Hex(i))

  Next

  Set OBJ_Zip = OBJ_FSO.CreateTextFile(STR_SaveFile, True)
  OBJ_Zip.Write STR_Temp
  OBJ_Zip.Close

  Set OBJ_Shell = CreateObject("Shell.Application")
  OBJ_Shell.NameSpace(STR_SaveFile).CopyHere(STR_TargetFile)

  WScript.Sleep 3000
  Set OBJ_Shell = Nothing
End Sub

Scriptのダウンロードは こちら です。

Winhttpでhttpリクエストを行い、Cドライブ直下に”test.gif”というファイルにリクエスト結果を保存する例です。

Option Explicit

  Const OpenFileForReading   = 1
  Const OpenFileForWriting   = 2
  Const OpenFileForAppending = 8

  Const adTypeBinary = 1 'Binary
  Const adTypeText   = 2 'Text

  Const adSaveCreateNotExist  = 1
  Const adSaveCreateOverWrite = 2
  HTTPDownload "http://dragon-ark.com/wp-content/uploads/2008/12/20081231_1-300x166.gif" , "c:\test.gif"

 Sub HTTPDownload(ByVal STR_URL, ByVal STR_Path )
    Dim OBJ_ADO
    Dim OBJ_HTTP
    Dim STR_Temp

    Set OBJ_ADO  = CreateObject("ADODB.Stream")

    OBJ_ADO.Type = adTypeBinary
    OBJ_ADO.Open
    OBJ_ADO.Position = 0

    Set OBJ_HTTP = CreateObject("WinHttp.WinHttpRequest.5.1")

    OBJ_HTTP.Open "GET", STR_URL, False
    OBJ_HTTP.Send

    STR_Temp = OBJ_HTTP.ResponseBody
    OBJ_ADO.Write STR_Temp
    OBJ_ADO.SaveToFile STR_Path, adSaveCreateNotExist
    OBJ_ADO.Close
End Sub

Scriptのダウンロードは こちら です。

Winhttpでhttpリクエストを行い、Cドライブ直下に”test.txt”というファイルにリクエスト結果を保存する例です。

Option Explicit

  Const OpenFileForReading   = 1
  Const OpenFileForWriting   = 2
  Const OpenFileForAppending = 8

  HTTPDownload "http://google.co.jp/index.html" , "c:\text.txt"
Sub HTTPDownload(ByVal STR_URL, ByVal STR_Path )
    Dim OBJ_File
    Dim OBJ_FSO
    Dim OBJ_HTTP

    Set OBJ_FSO  = CreateObject("Scripting.FileSystemObject")
    Set OBJ_File = OBJ_FSO.OpenTextFile(STR_Path, OpenFileForWriting, True)
    Set OBJ_HTTP = CreateObject("WinHttp.WinHttpRequest.5.1")

    OBJ_HTTP.Open "GET", STR_URL, False
    OBJ_HTTP.Send

    OBJ_File.Write  OBJ_HTTP.ResponseText
    OBJ_File.Close( )
End Sub

Scriptのダウンロードは こちら です。