2012年8月10日金曜日

現場で使える VBScript 25選


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