現場で使える 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