[VBScript]CABファイルの作成

'* VBScript ********************************************************************
'
' 名称: sample_create_cab.vbs
'
' 作成者:
'
' 履歴:
'
' 説明: CABファイルの作成。
'
'*******************************************************************************

Option Explicit

'===============================================================================
'
' 名称: CreateCab
'
' 説明: CABファイルの作成
'
' 引数: sSrcPath 圧縮元のファイル
' sDstPath 圧縮先のファイル(CABファイル)
'
' 戻り値: 成功...True 失敗...True
'
'===============================================================================
Function CreateCab(sSrcPath, sDstPath)

Dim oCAB
Dim oShell

CreateCab = False

Set oCAB = WScript.CreateObject("MakeCab.MakeCab.1")
Set oShell = WScript.CreateObject("WScript.Shell")

On Error Resume Next

Call oCAB.CreateCab(sDstPath,False,False)
If Err.Number <> 0 Then
If Err.Number = 450 Then
Call oCAB.CreateCab(sDstPath,False,False,False)
Err.Clear
Else
Call oShell.LogEvent( 1, Err.Number & " " & Err.Description )
Err.Clear
Exit Function
End If
End If
Call oCAB.AddFile(sSrcPath,sSrcPath)
Call oCAB.CloseCab()


On Error GoTo 0

Set oShell = Nothing
Set oCAB = Nothing

CreateCab = True

End Function

Const cSrcPath = "c:\sample.txt"
Const cDstPath = "c:\sample.cab"

If CreateCab(cSrcPath, cDstPath) Then
WScript.Echo("成功")
Else
WScript.Echo("失敗")
End If

[VBScript]インターネットエクスプローラでWebページを開きます。

Option Explicit

'===============================================================================
'
' 名称: OpenIE
'
' 説明: sURLを開く
'
' 引数: sURL
'
' 戻り値: 成功...True 失敗...True
'
'===============================================================================
Function OpenIE(sURL)

Dim oIE
Dim oShell

OpenIE = False

Set oIE = WScript.CreateObject("InternetExplorer.Application")
Set oShell = WScript.CreateObject("WScript.Shell")

With oIE
.Visible = True

On Error Resume Next
.Navigate(sURL)

If Err.Number <> 0 Then
Call oShell.LogEvent( 1, Err.Number & " " & Err.Description )
Err.Clear
Exit Function
End If

On Error GoTo 0

Do While .Busy = True
WScript.Sleep( 100 )
Loop

End With

Set oShell = Nothing
Set oIE = Nothing

OpenIE = True

End Function

Const cURL = "http://www.yahoo.co.jp"

If OpenIE(cURL) Then
WScript.Echo("成功")
Else
WScript.Echo("失敗")
End If

[VBScript]メールの送信サンプル(CDO)

'
' メールの送信サンプル(CDO)
'

Option Explicit

Const cSMTPServer = "SMTPサーバー"
Const cSMTPPort = 25
Const cSMTPConnectionTimeout = 10
Const cSMTPAuthenticate = 1

Const cSendUserName = "ユーザー名"
Const cSendPassWord = "パスワード"

'==============================================================================
'
' メール送信
'
' 引数
' sFrom 送信元メールアドレス
' sTo 送信先メールアドレス
' sSubject 件名
' sTextBody 本文
' 戻り値
' 成功 True 失敗 False
'==============================================================================
Function SendMail(sFrom, sTo, sSubject, sTextBody)

Const cKeywdSendusing = "http://schemas.microsoft.com/cdo/configuration/sendusing"
Const cKeywdSMTPServer = "http://schemas.microsoft.com/cdo/configuration/smtpserver"
Const cKeywdSMTPPort = "http://schemas.microsoft.com/cdo/configuration/smtpserverport"
Const cKeywdSMTPConnectionTimeout = "http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout"
Const cKeywdSMTPAuthenticate = "http://schemas.microsoft.com/cdo/configuration/smtpauthenticate"
Const cKeywdSendUserName = "http://schemas.microsoft.com/cdo/configuration/sendusername"
Const cKeywdSendPassword = "http://schemas.microsoft.com/cdo/configuration/sendpassword"

Dim oMsg

SendMail = False

Set oMsg = CreateObject("CDO.Message")

With oMsg

.From = sFrom
.To = sTo
.Subject = sSubject
.TextBody = sTextBody

.Configuration.Fields.Item(cKeywdSendusing) = 2
.Configuration.Fields.Item(cKeywdSMTPServer) = cSMTPServer
.Configuration.Fields.Item(cKeywdSMTPPort) = cSMTPPort
.Configuration.Fields.Item(cKeywdSMTPConnectionTimeout) = cSMTPConnectionTimeout
.Configuration.Fields.Item(cKeywdSMTPAuthenticate) = 1
.Configuration.Fields.Item(cKeywdSMTPPort) = cSMTPPort
.Configuration.Fields.Item(cKeywdSendUserName) = cSendUserName
.Configuration.Fields.Item(cKeywdSendPassword) = cSendPassWord

.Configuration.Fields.Update

End With

On Error Resume Next

' 送信
oMsg.Send

If Err.Number <> 0 Then
With Err
Dim oShell
Set oShell = WScript.CreateObject("WScript.Shell")
Call oShell.LogEvent( 1,_
"エラー発生!!" & vbCRLF &_
"番号: " & .Number & vbCRLF &_
"内容: " & .Description )
Set oShell = Nothing
.Clear
End With
Else

SendMail = True

End If

On Error GoTo 0

Set oMsg = Nothing

End Function


Dim sFrom, sTo, sSubject, sTextBody

sFrom = "送信元メールアドレス"
sTo = "送信先メールアドレス"
sSubject = "テストメール"
sTextBody = "本文"

If SendMail(sFrom, sTo, sSubject, sTextBody) = True Then
WScript.Echo("メール送信成功。")
Else
WScript.Echo("メール送信失敗！！")
End If

[VBScript]インストール済みソフトウェアの一覧

'
' インストール済みソフトウェアの一覧
'

Option Explicit

Dim oWMIService, oItems, oItem
Dim sComputer

sComputer = "."
Set oWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & sComputer & "\root\cimv2")
Set oItems = oWMIService.ExecQuery("Select * from Win32_Product")

For Each oItem in oItems

WScript.Echo ""
WScript.Echo "Caption: ", oItem.Caption
WScript.Echo "Description: ", oItem.Description
WScript.Echo "IdentifyingNumber: ", oItem.IdentifyingNumber
WScript.Echo "InstallLocation: ", oItem.InstallLocation
WScript.Echo "InstallState: ", oItem.InstallState
WScript.Echo "Name: ", oItem.Name
WScript.Echo "PackageCache: ", oItem.PackageCache
WScript.Echo "SKUNumber: ", oItem.SKUNumber
WScript.Echo "Vendor: ", oItem.Vendor
WScript.Echo "Version: ", oItem.Version

Next

Set oItem = Nothing
Set oItems = Nothing
Set oWMIService = Nothing