現場で使える VBScript 25選
始めに：
アプリケーションの仮想化の仕事に携わっていると様々な事があります。その中で、PCの情報を取得したり
ログを出力したりと、ちょっとした事は
自動化したいですよね。
そんなときに私は、VBScriptで処理を書いています。
メモ帳さえあれば、どんな環境でもOKな手軽さがイイですね。
はやりのPowerShellで書けばいいんですが、Windows 2000 / XP / Vista / 7で
動くとなると、やはりVBScriptに頼るのが簡単です。
もちろんJScriptもOKですけどね。
これまでに、いろいろと書き貯めてきたVBScriptを備忘録を兼ねて、公開してみたいと思います。
同じ事をするにも、様々なアプローチがあるので、一例として眺めてもらえると嬉しいです。
Windows XP 7で動作確認していますが、
環境によって、うまく動かない場合があるかもしれません。
くれぐれも自己責任でお願いします。
目次：
1.プログラムの実行ファイル名を指定して実行に似ています。
2.ネットワーク接続画面を開く[ncpa.cpl]
コントロールパネルの情報を開く事ができます。
inetcpl.cplにするとインターネット接続画面を表示できたりもします。
3.コンピュータ名の取得
コンピュータ名を取得します。
4.ユーザー名の取得
このVBScriptを実行した、ユーザー名を取得します。
5.NETBIOSドメイン名の取得
NETBIOS形式のドメイン名を取得します。DOMAIN等
6.DNSドメイン名の取得
DNSドメイン名を取得します。Domain.local等
7.PC所属ドメイン名の取得
PC自体が所属しているドメイン名を取得します。
8.OS種類の取得
Windows 2000 XP Vista 7 8 2003 2008 2008R2 2012等の情報
9.Windowsフォルダーのパス取得
Windowsがインストールされているパスを取得します。
10.Windowsインストール日時情報取得
Windowsをインストールした日時を取得します。
どのくらい前からそのPCが利用されているかを判断したい時に使います。
インストールされた時期が分かれば、どのくらい使われているのかわかります。
11.Windows登録者情報取得
Windowsをインストールした時に、設定した登録者を取得します。
12.Windows登録組織情報取得
Windowsをインストールした時に、設定した登録組織名を取得します。
Windows7では空白になります。
13.CPU情報の取得
WMIで取得されるCPU情報なので、PCのカタログなんかに書かれている
名前とは、一致しないかもしれません。
14.物理メモリサイズの取得
PCに割り当てられているメモリのサイズを取得します。
15.PC製造元情報とモデル名の取得
WMIで取得される情報なので、PCのカタログなんかに書かれている
情報とは、一致しないかもしれません。
16.IPアドレス、NIC名の取得
NICの名前とIPアドレスを取得します。
17.接続状態のNIC名の取得
NICがアクティブな状態(接続されている)の物を取得します。
18.ドライブ情報の取得
ドライブの情報を取得します。
FDD HDD CD-ROM DVD-ROMの種類とフォーマットの種類
総容量と空き容量
19.ネットワークドライブ情報の取得
ネットワークドライブ割り当てされた、
ドライブ文字と接続先のファイル共有のUNCパスを取得します。
20.特殊フォルダーの取得
デスクトップ等の特別なフォルダのパスを取得します。
21.プリンター情報の取得
インストールされているプリンタの情報を取得します。
通常使うプリンタの情報も合わせて取得します。
22.イベントビューアーへの登録
イベントビューアーに情報を登録します。
23.ログファイルへの登録
自前のログファイルに、内容を追加します。
24.Officeバージョンの取得
インストールされているOfficeのバージョンを取得します。
Excelを例にしています。
25.IEバージョンの取得
インストールされているIEのバージョンを取得します。
※ソースコードのコピー方法
ソース上でダブルクリックすると全体が選択されるのでCtrl+C等でコピーしてください。
1.プログラムの実行
Option Explicit
Dim strCommand
Dim strErr
strCommand = """C:\Program Files\Internet Explorer\iexplore.exe"" http://www.yahoo.co.jp"
'エラー確認
strErr = ExecCommand(strCommand,1,True)
IF strErr <> "" Then
MsgBox strErr
End IF
'-----------------------------------------------------------
'処理内容：コマンドラインの実行
'引数：
' strCommand:実行するコマンド ライン
' IntWindowStyle:ウインドウの状態を設定
' bWaitOnReturn
' True:プログラムの実行が終了するまでスクリプトの実行は中断
' False:プログラムが開始すると Run メソッドは即座に復帰
'戻り値：エラーコード
'http://msdn.microsoft.com/ja-jp/library/cc364421.aspx
'-----------------------------------------------------------
Function ExecCommand(strCommand,IntWindowStyle,bWaitOnReturn)
On Error Resume Next
Err.Clear
Dim strErr
strErr=""
Dim objShell
Set objShell = CreateObject("WScript.Shell")
Call objShell.Run(strCommand,IntWindowStyle,bWaitOnReturn)
Set objShell = Nothing
IF Err.Number <> 0 Then
strErr = "ErrNumber:0x" & CStr(Hex(Err.Number))
End IF
ExecCommand=strErr
Err.Clear
End Function
2.ネットワーク接続画面を開く[ncpa.cpl]
Option Explicit
MsgBox "ネットワーク接続を開きます。"
Call ExecCmd("RUNDLL32.EXE SHELL32.DLL,Control_RunDLL ncpa.cpl")
'-----------------------------------------------------------
'処理内容：コマンドの実行
'引数：strCMD 実行するコマンド
'-----------------------------------------------------------
Sub ExecCmd(strCMD)
On error resume next
Err.Clear
Dim objShell
Set objShell = CreateObject("WScript.Shell")
Call objShell.Run(strCMD,1,False)
Set objShell = Nothing
Err.Clear
End Sub
3.コンピュータ名の取得
Option Explicit
MsgBox GetComputerName
'-----------------------------------------------------------
'処理内容：コンピュータ名の取得
'戻り値：コンピュータ名
'-----------------------------------------------------------
Function GetComputerName()
On Error Resume Next
Err.Clear
Dim strRet
Dim objNetWork
strRet=""
Set objNetWork = CreateObject("WScript.Network")
strRet = objNetWork.ComputerName
Set objNetWork = Nothing
GetComputerName=strRet
Err.Clear
End Function
4.ユーザー名の取得
Option Explicit
MsgBox GetCurrentUserName()
'-----------------------------------------------------------
'処理内容：ユーザー名の取得
'戻り値：ユーザー名
'-----------------------------------------------------------
Function GetCurrentUserName()
On Error Resume Next
Err.Clear
Dim objNetwork
Dim strRet
strRet = ""
Set objNetwork = CreateObject("WScript.Network")
strRet = objNetwork.UserName
Set objNetwork = Nothing
GetCurrentUserName = strRet
Err.Clear
End Function
5.NETBIOSドメイン名の取得
Option Explicit
MsgBox GetNETBIOSDomainName()
'--------------------------------------------
'処理内容：現在のユーザーがログインしているドメイン名NETBIOSを返す
'戻り値：ドメイン名(NETBIOS)
'--------------------------------------------
Function GetNETBIOSDomainName()
On Error Resume Next
Err.Clear
Dim objWMIService
Dim objComputer
Dim colComputers
Dim szTmp
Dim strRet
Dim ArrayName
strRet = ""
szTmp=""
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colComputers = objWMIService.ExecQuery("Select * from Win32_ComputerSystem")
For Each objComputer in colComputers
szTmp = objComputer.UserName
Next
'\で区切る(Domain\User)
ArrayName = Split(szTmp,"\")
IF UBound(ArrayName) > 0 Then
'0番目はDomain
strRet = ArrayName(0)
End IF
GetNETBIOSDomainName = strRet
Err.Clear
End Function
6.DNSドメイン名の取得
Option Explicit
Dim DomainNameFQDN
Dim NETBIOSDomainName
'NETBIOSドメイン名を取得
NETBIOSDomainName = GetNETBIOSDomainName()
'FQDN名を取得する
DomainNameFQDN = GetFQDNDomainName(NETBIOSDomainName)
MsgBox DomainNameFQDN
'-----------------------------------------------------------
'処理内容：ドメイン名(DNSの設定値)情報の取得
'引数：NETBIOSDomainName
'戻り値：ドメイン名(DNSの設定値)
'-----------------------------------------------------------
Function GetFQDNDomainName(NETBIOSDomainName)
On Error Resume Next
Dim HKEY_LOCAL_MACHINE
HKEY_LOCAL_MACHINE = &H80000002
Err.Clear
Dim objRegProv
Dim HklmV
Dim strRet
strRet = ""
HklmV = "Software\Microsoft\Windows NT\CurrentVersion\Winlogon\DomainCache\"
Set objRegProv = GetObject("winmgmts:{impersonationLevel=Impersonate}" & "!\\.\root\default:StdRegProv")
objRegProv.GetStringValue HKEY_LOCAL_MACHINE, HklmV,NETBIOSDomainName, strRet
Set objRegProv = Nothing
IF Err.Number <> 0 Then
strRet = "N/A"
End IF
Err.Clear
IF strRet = "" Or IsNull(strRet) Then
strRet = "N/A"
End IF
GetFQDNDomainName = strRet
Err.Clear
End Function
'--------------------------------------------
'処理内容：現在のユーザーがログインしているドメイン名NETBIOSを返す
'戻り値：ドメイン名(NETBIOS)
'--------------------------------------------
Function GetNETBIOSDomainName()
On Error Resume Next
Err.Clear
Dim objWMIService
Dim objComputer
Dim colComputers
Dim szTmp
Dim strRet
Dim ArrayName
strRet = ""
szTmp=""
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colComputers = objWMIService.ExecQuery("Select * from Win32_ComputerSystem")
For Each objComputer in colComputers
szTmp = objComputer.UserName
Next
'\で区切る(Domain\User)
ArrayName = Split(szTmp,"\")
IF UBound(ArrayName) > 0 Then
'0番目はDomain
strRet = ArrayName(0)
End IF
GetNETBIOSDomainName = strRet
Err.Clear
End Function
7.PC所属ドメイン名の取得
Option Explicit
MsgBox GetJoinDomainName()
'--------------------------------------------
'処理内容：PCが所属しているドメイン名を返す
'戻り値：ドメイン名
'--------------------------------------------
Function GetJoinDomainName()
On Error Resume Next
Err.Clear
Dim objWMIService
Dim objComputer
Dim colComputers
Dim strRet
strRet = ""
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colComputers = objWMIService.ExecQuery("Select * from Win32_ComputerSystem")
For Each objComputer in colComputers
strRet = objComputer.Domain
Next
GetJoinDomainName = strRet
Err.Clear
End Function
8.OS種類の取得
Option Explicit
MsgBox GetOSType()
'-----------------------------------------------------------
'処理内容：OS情報の取得
'戻り値：OS情報(SP含む)
'-----------------------------------------------------------
Function GetOSType()
On error resume next
Err.Clear
Dim objWMIService
Dim objComputer
Dim colComputers
Dim OsVal
Dim szTmp
Dim strRet
Dim strOSAr
szTmp=""
strRet=""
strOSAr=""
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colComputers = objWMIService.ExecQuery("Select * from Win32_OperatingSystem")
For Each objComputer in colComputers
szTmp = objComputer.Version
OsVal = Mid(szTmp,1,3)
IF OsVal = "5.0" Then
strRet = "Windows 2000 "
ElseIf OsVal = "5.1" Then
strRet = "Windows XP "
ElseIf OsVal = "5.2" Then
strRet = "Windows Server 2003 "
ElseIf OsVal = "6.0" Then
IF InStr(UCase(objComputer.Caption),"SERVER") > 1 Then
strRet = "Windows Server 2008 "
Else
strRet = "Windows Vista "
End IF
ElseIf OsVal = "6.1" Then
IF InStr(UCase(objComputer.Caption),"SERVER") > 1 Then
strRet = "Windows Server 2008 R2 "
Else
strRet = "Windows 7 "
End IF
ElseIf OsVal = "6.2" Then
IF InStr(UCase(objComputer.Caption),"SERVER") > 1 Then
strRet = "Windows Server 2012 "
Else
strRet = "Windows 8 "
End IF
Else
strRet = "Windows " & "(" & szTmp & ") "
End If
strRet = strRet & "SP" & objComputer.ServicePackMajorVersion & "." & objComputer.ServicePackMinorVersion
strOSAr = ""
strOSAr = objComputer.OSArchitecture
IF strOSAr = "" Or IsNull(strOSAr) Then
strOSAr = "32ビット"
End If
strRet = strRet & " " &strOSAr
Next
GetOSType = strRet
Err.Clear
End Function
9.Windowsフォルダーのパス取得
Option Explicit
MsgBox GetWindowsDirectory()
'-----------------------------------------------------------
'処理内容：Windowsフォルダ情報の取得
'戻り値：Windowsフォルダ情報
'-----------------------------------------------------------
Function GetWindowsDirectory()
On error resume next
Err.Clear
Dim objWMIService
Dim objComputer
Dim colComputers
Dim strRet
szTmp=""
strRet=""
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colComputers = objWMIService.ExecQuery("Select * from Win32_OperatingSystem")
For Each objComputer in colComputers
strRet = objComputer.WindowsDirectory
Next
GetWindowsDirectory = strRet
Err.Clear
End Function
10.Windowsインストール日時情報取得
Option Explicit
MsgBox GetWindowsInstallDate()
'-----------------------------------------------------------
'処理内容：Windowsのインストール日時を取得
'戻り値：Windowsのインストール日時
'-----------------------------------------------------------
Function GetWindowsInstallDate()
On error resume next
Err.Clear
Dim strRet
strRet = ""
Dim WindowsInstallDate
Dim time_t
WindowsInstallDate = ""
Dim Shell
Dim RegKey
Set Shell = CreateObject("WScript.Shell")
'WindowsInstallの日付が登録されているレジストリのパス
RegKey = "HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\InstallDate"
time_t = Shell.RegRead(RegKey)
IF time_t <> "" Then
Dim dGMTTime
'日付を補正するために1970-01-01 00:00:00を加えます。GMTでセットします。
dGMTTime = DateAdd("s", time_t, "1970-01-01 00:00:00")
Dim dLocalTime
'タイムゾーンを取得します。
RegKey = "HKLM\SYSTEM\CurrentControlSet\Control\TimeZoneInformation\ActiveTimeBias"
Dim iTZOffset
iTZOffset = Shell.RegRead(RegKey)
IF iTZOffset <> "" Then
Dim HexVal
HexVal = Hex(iTZOffset)
iTZOffset = - CLng("&H" & HexVal)
'GMTにタイムゾーンを加えてローカル日付に変換します。
dLocalTime = DateAdd("n", iTZOffset, dGMTTime)
'日付を文字列に変換
dLocalTime = FormatDateTime(dLocalTime, vbGeneralDate)
IF Err.Number = 0 Then
strRet = dLocalTime
End IF
End IF
End IF
Set Shell = Nothing
Err.Clear
GetWindowsInstallDate = strRet
End Function
11.Windows登録者情報取得
Option Explicit
MsgBox GetWindowsRegisteredOwner()
'-----------------------------------------------------------
'処理内容：Windows登録者名を取得
'戻り値：Windows登録者名
'-----------------------------------------------------------
Function GetWindowsRegisteredOwner()
On error resume next
Err.Clear
Dim strRet
strRet = ""
Dim strRegisteredOwner
strRegisteredOwner = ""
Dim Shell
Dim RegKey
Set Shell = CreateObject("WScript.Shell")
RegKey = "HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\RegisteredOwner"
strRegisteredOwner = Shell.RegRead(RegKey)
IF Err.Number = 0 Then
strRet = strRegisteredOwner
Else
strRet = "N/A"
End IF
GetWindowsRegisteredOwner = strRet
Set Shell = Nothing
Err.Clear
End Function
12.Windows登録組織情報取得
Option Explicit
MsgBox GetWindowsRegisteredOrganization()
'-----------------------------------------------------------
'処理内容：Windows登録組織名を取得
'戻り値：Windows登録組織名
'-----------------------------------------------------------
Function GetWindowsRegisteredOrganization()
On error resume next
Err.Clear
Dim strRet
strRet = ""
Dim strRegisteredOrganization
strRegisteredOrganization = ""
Dim Shell
Dim RegKey
Set Shell = CreateObject("WScript.Shell")
RegKey = "HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\RegisteredOrganization"
strRegisteredOrganization = Shell.RegRead(RegKey)
IF Err.Number = 0 Then
strRet = strRegisteredOrganization
Else
strRet = "N/A"
End IF
GetWindowsRegisteredOrganization = strRet
Set Shell = Nothing
Err.Clear
End Function
13.CPU情報の取得
Option Explicit
MsgBox GetCPU_Description()
'-----------------------------------------------------------
'処理内容：CPU表示情報の取得
'戻り値：CPU表示情報
'-----------------------------------------------------------
Function GetCPU_Description()
On error resume next
Err.Clear
Dim objWMIService
Dim objProcessor
Dim colProcessors
Dim strRet
strRet=""
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colProcessors = objWMIService.ExecQuery("Select * from Win32_Processor")
For Each objProcessor in colProcessors
strRet = strRet & objProcessor.Name & vbCrLf & objProcessor.Description
'CPUが複数ある場合でも始めの1つ目でループを抜けてしまいます。
'全てのCPUを取得する場合は、ループを外してください。
Exit For
Next
GetCPU_Description = strRet
Err.Clear
End Function
14.物理メモリサイズの取得
Option Explicit
MsgBox GetPhysicalMemory()
'-----------------------------------------------------------
'処理内容：物理メモリ情報の取得
'戻り値：物理メモリ情報(MB)
'-----------------------------------------------------------
Function GetPhysicalMemory()
On error resume next
Err.Clear
Dim objWMIService
Dim objComputer
Dim colComputers
Dim strRet
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colComputers = objWMIService.ExecQuery("Select * from Win32_ComputerSystem")
For Each objComputer in colComputers
strRet = objComputer.TotalPhysicalMemory
Next
IF strRet ="" Or strRet = 0 Then
strRet = "N/A"
Else
'小数点以下を四捨五入しMBに変換
strRet = ROUND(strRet/(1024*1024),0) & "MB"
End IF
GetPhysicalMemory = strRet
Err.Clear
End Function
15.PC製造元情報とモデル名の取得
Option Explicit
MsgBox GetSystemManufacturer()
'-----------------------------------------------------------
'処理内容：製造元情報の取得
'戻り値：製造元情報
'-----------------------------------------------------------
Function GetSystemManufacturer()
On error resume next
Err.Clear
Dim objWMIService
Dim objComputer
Dim colComputers
Dim strRet
strRet=""
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colComputers = objWMIService.ExecQuery("Select * from Win32_ComputerSystem")
For Each objComputer in colComputers
strRet = objComputer.Manufacturer & vbCrLf & objComputer.Model
Next
GetSystemManufacturer = strRet
Err.Clear
End Function
16.IPアドレス、NIC名の取得
Option Explicit
MsgBox GetIPAddress()
'-----------------------------------------------------------
'処理内容：IPアドレス、ネットワークインターフェース名の取得
'戻り値：IPアドレス、ネットワークインターフェース名
'-----------------------------------------------------------
Function GetIPAddress()
On error resume next
Err.Clear
Dim objWMIService
Dim colNetCards
Dim objNetCard
Dim strRet
Dim arrIPAddresses
Dim strAddress
Dim strTemp
strTemp = ""
strRet = ""
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colNetCards = objWMIService.ExecQuery("Select * From Win32_NetworkAdapterConfiguration Where IPEnabled = True")
Dim iCnt
iCnt=0
For Each objNetCard in colNetCards
strTemp = ""
strRet = strRet & objNetCard.Caption
arrIPAddresses = objNetCard.IPAddress
'IPアドレスを複数持っている可能性があるのでループ処理/区切りで処理
For Each strAddress in arrIPAddresses
strTemp = strTemp & strAddress & "/"
Next
IF strTemp <> "" Then
'最後の/を削除
strTemp = Mid(strTemp,1,Len(strTemp)-1)
strRet = strRet & vbCrLf &"IPAddress:" & strTemp
End IF
strRet = strRet & vbCrLf
iCnt=iCnt+1
Next
IF strRet <> "" Then
'最後のvbCrLfを削除
strRet = Mid(strRet,1,Len(strRet)-2)
End IF
GetIPAddress = strRet
Err.Clear
End Function
17.接続状態のNIC名の取得
Option Explicit
MsgBox GetConnectedNetworkAdapter()
'-----------------------------------------------------------
'処理内容：接続状態（切断でない、無効でない）状態のネットワーク接続を取得
'戻り値：ネットワーク接続名
'-----------------------------------------------------------
Function GetConnectedNetworkAdapter()
On error resume next
Err.Clear
Dim objWMIService
Dim colNetCards
Dim objNetCard
Dim strRet
strRet = ""
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colNetCards = objWMIService.ExecQuery("Select * From Win32_NetworkAdapter Where NetConnectionStatus=2")
For Each objNetCard in colNetCards
strRet = strRet & "[" & objNetCard.NetConnectionID & "]" & objNetCard.Name
strRet = strRet & vbCrLf
Next
GetConnectedNetworkAdapter = strRet
Err.Clear
End Function
18.ドライブ情報の取得
Option Explicit
MsgBox GetDriveInfo()
'-----------------------------------------------------------
'処理内容：ドライブの情報取得
'戻り値：ドライブの容量(GB)・空き容量(MB/GB)
'-----------------------------------------------------------
Function GetDriveInfo()
On error resume next
Err.Clear
Dim objWMIService
Dim objLogicalDisk
Dim colLogicalDisks
Dim strRet
Dim DiskSize
Dim DiskFreeSpace
strRet=""
DiskSize = 0
DiskFreeSpace = 0
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colLogicalDisks = objWMIService.ExecQuery("Select * from Win32_LogicalDisk where DriveType=3")
For Each objLogicalDisk in colLogicalDisks
DiskSize = objLogicalDisk.Size
IF DiskSize > 0 Then
DiskSize = ROUND(DiskSize/(1024*1024*1024),1) & "GB"
Else
DiskSize = "N/A"
End IF
DiskFreeSpace = objLogicalDisk.FreeSpace
IF DiskFreeSpace > 0 Then
DiskFreeSpace = ROUND(DiskFreeSpace/(1024*1024),0)
IF DiskFreeSpace < 1024 Then
DiskFreeSpace = DiskFreeSpace & "MB"
Else
DiskFreeSpace = ROUND(objLogicalDisk.FreeSpace/(1024*1024*1024),1) & "GB"
End IF
Else
DiskFreeSpace = "N/A"
End IF
strRet = strRet & objLogicalDisk.DeviceID & "(合計:" & DiskSize & " - 空き:" & DiskFreeSpace & ")" & objLogicalDisk.FileSystem & vbCrLf
Next
IF strRet <> "" Then
strRet = Mid(strRet,1,Len(strRet)-2)
End IF
GetDriveInfo = strRet
Err.Clear
End Function
19.ネットワークドライブ情報の取得
Option Explicit
MsgBox GetNetworkDriveInfo()
'-----------------------------------------------------------
'処理内容：ネットワークドライブの情報取得
'戻り値：ネットワークドライブのドライブ文字)・リンク先UNCパス
'-----------------------------------------------------------
Function GetNetworkDriveInfo()
On error resume next
Err.Clear
Dim objWMIService
Dim objLogicalDisk
Dim colLogicalDisks
Dim strRet
strRet=""
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colLogicalDisks = objWMIService.ExecQuery("Select * from Win32_LogicalDisk where DriveType=4")
For Each objLogicalDisk in colLogicalDisks
strRet = strRet & objLogicalDisk.DeviceID & "(" & objLogicalDisk.ProviderName & ")"&vbCrLf
Next
IF strRet <> "" Then
strRet = Mid(strRet,1,Len(strRet)-2)
End IF
GetNetworkDriveInfo = strRet
Err.Clear
End Function
20.特殊フォルダーの取得
'http://msdn.microsoft.com/ja-jp/library/cc364490.aspx
Option Explicit
DIm ArrayData
ArrayData=Array("AllUsersDesktop","AllUsersStartMenu", _
"AllUsersPrograms", "AllUsersStartup","Desktop","Favorites", _
"Fonts","MyDocuments","NetHood","PrintHood", _
"Programs","Recent","SendTo","StartMenu", _
"Startup","Templates")
Dim strMsg
Dim i
For i=0 to UBound(ArrayData)
strMsg = strMsg & "["&ArrayData(i)&"]" & GetSpecialFolderInfo(ArrayData(i))&vbCrLf
Next
IF Not strMsg="" Then
strMsg = Mid(strMsg,1,Len(strMsg)-2)
End IF
MsgBox strMsg
'-----------------------------------------------------------
'処理内容：特殊フォルダ情報取得
'引数：取得フォルダ名
'戻り値：フルパス
'-----------------------------------------------------------
Function GetSpecialFolderInfo(strTarget)
On error resume next
Err.Clear
Dim strRet
strRet = ""
Dim Shell
Set Shell = CreateObject("WScript.Shell")
Dim strFolderPath
strRet = Shell.SpecialFolders(strTarget)
Set Shell = Nothing
Err.Clear
GetSpecialFolderInfo = strRet
End Function
21.プリンター情報の取得
Option Explicit
MsgBox GetPrinterInfo()
'-----------------------------------------------------------
'処理内容：プリンタ情報取得
'戻り値：プリンタ情報
'-----------------------------------------------------------
Function GetPrinterInfo()
On error resume next
Err.Clear
Dim objWMIService
Dim objComputer
Dim colComputers
Dim strRet
Dim strDefaultP
strDefaultP = ""
strRet=""
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colComputers = objWMIService.ExecQuery("Select * from Win32_Printer")
For Each objComputer in colComputers
strRet = strRet & "プリンタ名:" & objComputer.Name
strDefaultP = objComputer.Default
IF UCase(strDefaultP) = "TRUE" Then
strRet = strRet & "(通常使うプリンタ)"
End IF
strRet = strRet & vbCrLf &"Port名:" & objComputer.PortName & vbCrLf & vbCrLf
Next
IF Not strRet="" Then
strRet = Mid(strRet,1,Len(strRet)-4)
End IF
GetPrinterInfo = strRet
Err.Clear
End Function
22.イベントビューアーへの登録
Option Explicit
Call WriteLogEvent(0,"成功しました。")
Call WriteLogEvent(1,"失敗しました。")
Call WriteLogEvent(2,"警告です。")
Call WriteLogEvent(4,"情報です。")
MsgBox "イベントビューアーに書き込みました。"
'--------------------------------------------
'処理内容：イベントログへ登録(アプリケーション)
'引数：
' intType:EventID 0=成功(情報) 1=失敗(失敗) 2=警告(警告) 4=情報(情報)
' strMessage:登録するメッセージ
'--------------------------------------------
Sub WriteLogEvent(intType,strMessage)
On Error Resume Next
Err.Clear
Dim WshShell
'0:成功,1:エラー,2:警告,4:情報
Set WshShell = CreateObject("WScript.Shell")
Call WshShell.LogEvent(intType,strMessage)
Set WshShell = Nothing
Err.Clear
End Sub
23.ログファイルへの登録
Option Explicit
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
'出力するLogファイルのフルパスを設定(事前にフォルダを作成する必要あり)
Const gszLogFilePath = "c:\log\test.log"
Call WriteLog("成功しました。")
Call WriteLog_NonTime("失敗しました。")
MsgBox "Logファイルへの登録が完了しました。"&gszLogFilePath
'--------------------------------------------
'処理内容：Logの登録(処理時間付き)
'引数：ログに追加するメッセージ
'--------------------------------------------
Sub WriteLog(Message)
On Error Resume Next
Dim oTS
Dim sLogFile
sLogFile = gszLogFilePath
Dim oFS
Set oFS = CreateObject("Scripting.FileSystemObject")
Set oTS = oFS.OpenTextFile(sLogFile, ForAppending, True, TristateUseDefault)
oTS.WriteLine "[" & CStr(Now) & "] " & Message
oTS.Close
Set oTS = Nothing
Set oFS = Nothing
End Sub
'--------------------------------------------
'処理内容：Logの登録(処理時間なし)
'引数：ログに追加するメッセージ
'--------------------------------------------
Sub WriteLog_NonTime(Message)
On Error Resume Next
Dim oTS
Dim sLogFile
sLogFile = gszLogFilePath
Dim oFS
Set oFS = CreateObject("Scripting.FileSystemObject")
Set oTS = oFS.OpenTextFile(sLogFile, ForAppending, True, TristateUseDefault)
oTS.WriteLine Message
oTS.Close
Set oTS = Nothing
Set oFS = Nothing
End Sub
24.Officeバージョンの取得
'Excelの例
Option Explicit
MsgBox "Excelのバージョン："&GetOfficeVer("Excel")
'-----------------------------------------------------------
'処理内容：Office製品のバージョンを取得
'引数：アプリケーション名(Excel Word Powerpoint Access)
'戻り値：Office製品のバージョン
'-----------------------------------------------------------
Function GetOfficeVer(appName)
'http://support.microsoft.com/kb/240794/ja
On error resume next
Err.Clear
Dim strRet
strRet = ""
Dim officeVer
officeVer = ""
Dim Obj
Dim Shell
Dim RegKey
Set Shell = CreateObject("WScript.Shell")
Dim KeyG
KeyG = appName & ".Application"
RegKey = "HKLM\SOFTWARE\Classes\" & KeyG & "\CurVer\"
officeVer = UCase(Shell.RegRead(RegKey))
KeyG = UCase(KeyG)
officeVer=Replace(officeVer,KeyG, "", 1, -1, 1)
Set Shell = Nothing
IF Err.Number = 0 Then
Select Case officeVer
Case ".8"
strRet = appName & "97"
Case ".9"
strRet = appName & "2000"
Case ".10"
strRet = appName & "XP"
Case ".11"
strRet = appName & "2003"
Case ".12"
strRet = appName & "2007"
Case ".14"
strRet = appName & "2010"
Case ".15"
strRet = appName & "2013"
Case Else
strRet = appName & "(" & officeVer & ")"
End Select
Else
strRet = appName & ":未インストール"
End IF
GetOfficeVer = strRet
Err.Clear
End Function
25.IEバージョンの取得
Option Explicit
MsgBox "IEのバージョン：" & GetIEVer()
'-----------------------------------------------------------
'処理内容：Internet Explorerのバージョンを取得
'戻り値：Internet Explorerのバージョン
'-----------------------------------------------------------
Function GetIEVer()
On error resume next
Err.Clear
Dim strRet
strRet = ""
Dim IEVer
IEVer = ""
Dim Shell
Dim RegKey
Set Shell = CreateObject("WScript.Shell")
RegKey = "HKLM\SOFTWARE\Microsoft\Internet Explorer\Version"
IEVer = Shell.RegRead(RegKey)
IF Err.Number = 0 Then
strRet = "version" & IEVer
Else
strRet = "未インストール"
End IF
GetIEVer = strRet
Set Shell = Nothing
Err.Clear
End Function
参考：
VBScript ランゲージ リファレンス
http://msdn.microsoft.com/ja-jp/library/cc392193.aspx
WshShell オブジェクト
http://msdn.microsoft.com/ja-jp/library/cc364436.aspx
WshShell.Run
http://msdn.microsoft.com/ja-jp/library/cc364421.aspx
特殊フォルダー
http://msdn.microsoft.com/ja-jp/library/cc364490.aspx
Officeバージョン取得
http://support.microsoft.com/kb/240794/ja