• FAQ
• テクニック
• アップローダー
• リンク

• WSH Lab.
• 掲示板
• winscript.jp

最新の10件

Windows Script テクニック集 ↑

※特に注釈が無い場合は、WshShell?はWshShell?オブジェクト、FsまたはFSOはFileSystemObject?、ShellはShell.Applicationを指すものとします。

• Windows Script テクニック集
  • WSH
    • 引数が存在しない場合は処理を中断する
    • DOS用アプリケーションの起動
    • コマンドライン(cscript)で強制実行 (VBScript)
    • コマンドライン(cscript)で強制実行 (JScript)
  • 文字列処理
    • URLエンコード
    • URLデコード
    • Base64エンコード/デコード
    • 半角英数文字を1byteとカウントするLen関数
  • 配列
    • バイト配列操作
    • 配列に要素を追加する
  • OS
    • OSの種類判別
  • ファイルシステム
    • フォルダ作成
    • ファイルサイズ整形表示
    • ごみ箱にファイル移動
    • タイムスタンプ（更新日時）更新
  • ネットワーク
    • ping(手抜き版)
    • メール送信(添付ファイル付き)
  • レジストリ
    • サブキーを含むレジストリキーの削除
  • Shell
    • アプリケーションから起動
    • ウィンドウの整列
  • WMI
    • ログオンユーザー名取得処理
  • ADSI
    • ドメイン配下のコンピュータ一覧出力
    • アカウントユーザーがグループに所属しているか？

WSH ↑

引数が存在しない場合は処理を中断する ↑

 If WScript.Arguments.Count <= 0 Then
     ''    必要に応じてメッセージを出力
     WScript.Echo "引数を指定して下さい。"
     ''    スクリプト処理を中断
     WScript.Quit
 End If 
 ''以下、処理を記述する...

DOS用アプリケーションの起動 ↑

 WSHShell.Run "command.com /c dosapp.com"

実行後もプロンプトを開いたままにしておきたい場合は、/kオプションを使用する。

 WSHShell.Run "command.com /k dosapp.com"

コマンドライン(cscript)で強制実行 (VBScript) ↑

 // Set Fs = WScript.CreateObject("Scripting.FileSystemObject")
 // Set WshShell = WScript.CreateObject("WScript.Shell")

 If LCase(Fs.GetFileName(WScript.FullName)) = "wscript.exe" Then
     WshShell.Run "cscript """ & WScript.ScriptFullName & """",1,False
     WScript.Quit
 End If
 '以下、処理を記述する...

コマンドライン(cscript)で強制実行 (JScript) ↑

 // var Fs = new ActiveXObject('Scripting.FileSystemObject');
 // var WshShell = new ActiveXObject('WScript.Shell');
 
 if (/^wscript\.exe$/i.test(Fs.getFileName(WScript.fullName))) {
 	WshShell.run('cscript.exe ' + WScript.scriptFullName, 1, false);
 	WScript.quit();
 }
 // 以下、処理を記述する...

文字列処理 ↑

URLエンコード ↑

 Function UrlEncode(Source)
     On Error Resume Next
     Dim I
     sTmp=""
     For I = 1 To Len(Source)
         sChr = Mid(Source,I,1)
         iAsc = Asc(sChr)
         If iAsc = &H20 Then '空白
             sChr = "+"
         ElseIf (iAsc >= &H40 And iAsc <= &H5A) Or _
         (iAsc >= &H61 And iAsc <= &H7A) Or _
         (iAsc >= &H30 And iAsc <= &H39) Or _
         iAsc = &H2A Or iAsc = &H2D Or _
         iAsc = &H2E Or iAsc = &H5F Then '未変換
         Else
             sHex = Hex(iAsc)
             lHexLen = Len(sHex)
             If lHexLen = 4 Then '2バイト
                 sChr = "%" & Left(sHex,2) & "%" & Right(sHex,2)
             ElseIf lHexLen = 2 Then '1バイト
                 sChr = "%" & sHex
             Else '1バイト（Hexで1桁）
                 sChr = "%" & "0" & sHex
             End If
         End If
         sTmp=sTmp & sChr
     Next
     UrlEncode = sTmp
 End Function

URLデコード ↑

 Function UrlDecode(Source)
     On Error Resume Next
     sTmp=""
     iCount = 1
     lSrcLen=Len(Source)
     Do Until iCount > lSrcLen
         sChr = Mid(Source,iCount,1)
         iCount = iCount+1
         If sChr="+" Then
             sChr = " "
         ElseIf sChr="%" Then
             sHex = Mid(Source,iCount,2)
             iCount = iCount + 2
             iAsc = CByte("&H" & sHex)
             If (&H00 <= iAsc And iAsc <= &H80) Or _
                (&HA0 <= iAsc And iAsc <= &HDF) Then
                 '1バイト文字
                 sChr=Chr(iAsc)
             ElseIf (&H81 <= iAsc And iAsc <= &H9F) Or _
                (&HE0 <= iAsc And iAsc <= &HFF) Then
                 '2バイト文字
                 sChr = Mid(Source,iCount,1)
                 iCount = iCount + 1
                 If sChr="%" Then
                     sHex2 = Mid(Source,iCount,2)
                     iCount = iCount + 2
                 Else
                     sHex2 = Hex(Asc(sChr))
                     If Len(sHex2) = 1 Then
                         sHex2 = "0" & sHex2
                     End If
                 End If
                 sChr=Chr(CInt("&H" & sHex & sHex2))
             End If
         End If
         sTmp=sTmp & sChr
     Loop
     UrlDecode = sTmp
 End Function

Base64エンコード/デコード ↑

 Const adTypeBinary = 1
 Const adTypeText = 2 
 
 Dim str(2)
 str(0) = "雨が降ってゐる荘厳だとか悲壮だとか言へば言へる・・・"
 str(1) = EncodeB64(str(0))
 str(2) = DecodeB64(str(1))
 MsgBox Join(str, vbNewLine)
 
 Function EncodeB64(PlainText)
      Dim ST, DM, EL, bin
  
      Set ST = CreateObject("ADODB.Stream")
      ST.Type = adTypeText
      ST.Charset = "Shift-JIS"
      ST.Open
      ST.WriteText PlainText
      ST.Position = 0
      ST.Type = adTypeBinary
      bin = ST.Read
      ST.Close
 
      Set DM = CreateObject("Microsoft.XMLDOM")
      Set EL = DM.CreateElement("tmp")
      EL.DataType = "bin.base64"
      EL.NodeTypedValue = bin
      EncodeB64 = EL.Text
 End Function
 
 Function DecodeB64(Base64Text)
      Dim ST, DM, EL
      Dim bin
 
      Set DM = CreateObject("Microsoft.XMLDOM")
      Set EL = DM.createElement("tmp")
      EL.DataType = "bin.base64"
      EL.Text = Base64Text
      bin = EL.NodeTypedValue
 
      Set ST = CreateObject("ADODB.Stream")
      ST.Open
      ST.Charset = "Shift-JIS"
      ST.Type = adTypeBinary
      ST.Write bin
      ST.Position = 0
      ST.Type = adTypeText
      DecodeB64 = ST.ReadText
      ST.Close
 End Function

半角英数文字を1byteとカウントするLen関数 ↑

 Function Len2(strString)
      nCount = 0
      For I = 1 To Len(strString)
           nCode = Asc(Mid(strString,I,1))
           If nCode >= 0 And nCode <= 255 Then
                nCount = nCount + 1
           Else
                nCount = nCount + 2
           End If
      Next
      Len2 = nCount
 End Function 

配列 ↑

バイト配列操作 ↑

VBScriptで、内部形式Byte型配列のVariant値を作る方法。 （VBAでいう、Dim B() As Byte な型のデータ） MSXML使用。

 Function HexTextToByteArray(HexText) 
     With CreateObject("Microsoft.XMLDOM").createElement("tmp") 
         .DataType = "bin.hex" 
         .Text = HexText 
         HexTextToByteArray = .NodeTypedValue 
     End With 
 End Function 
 
 
 HexText = "3100320033003400" 
 Text = HexTextToByteArray(HexText) 
 MsgBox CStr(Text), vbInformation, TypeName(Text) 
 
 HexText = "b530f330d730eb30" 
 Text = HexTextToByteArray(HexText) 
 MsgBox CStr(Text), vbInformation, TypeName(Text) 

配列に要素を追加する ↑

一次元配列の末尾に要素を追加する関数です。戻り値はなく、引数に与えた配列そのものに追加されます。オブジェクトでもそれ以外でもどちらでも追加できます。

 Sub AddElementToArray(arr,element)
 	Redim Preserve arr(UBound(arr)+1)
 	If IsObject(element) Then
 		Set arr(UBound(arr))=element
 	Else
 		arr(UBound(arr))=element
 	End If
 End Sub

OS ↑

OSの種類判別 ↑

Win98SEではIE5.5 or Windows Script 5.1以上のインストールが必要

 Function GetOSName()
      Const SystemFolder = 1
      Set Fs = WScript.CreateObject("Scripting.FileSystemObject")
      sVer = Fs.GetFileVersion(Fs.BuildPath(Fs.GetSpecialfolder _
      (SystemFolder).Path,"kernel32.dll"))
      Select Case sVer
           Case "4.10.2222" : GetOSName = "Windows 98SE"
           Case "4.90.0.3000" : GetOSName = "Windows ME"
           Case "5.0.2191.1" : GetOSName = "Windows 2000"
           Case "5.1.2600.2180" : GetOSName = "Windows XP"
           Case "5.2.3790.0" : GetOSName = "Windows Server 2003"
           Case Else : GetOSName = sVer
      End Select
 End Function

ファイルシステム ↑

フォルダ作成 ↑

親フォルダが無い場合でも、再帰的に親フォルダを作成していきます。

 Sub CreateFolderEx(Path)
 	sParent=Fs.GetParentFolderName(Path)
 	If Fs.FolderExists(sParent) And Not Fs.FolderExists(Path) Then
 		Fs.CreateFolder Path
 	ElseIf Fs.FolderExists(Path) Then
 	Else
 		CreateFolderEx sParent
 		Fs.CreateFolder Path
 	End If
 End Sub

ファイルサイズ整形表示 ↑

szにバイト数を指定すると、サイズに応じてGB、MBなどの表記に変換した文字列を返します。

 Function ModifySize(sz)
     If sz >= 1073741824 Then
         ModifySize = CSng(Left(sz/1073741824,4)) & "GB"
     ElseIf sz >= 1048576 Then
         ModifySize = CSng(Left(sz/1048576,4)) & "MB"
     ElseIf sz >= 1024 Then
         ModifySize = CSng(Left(sz/1024,4)) & "KB"
     Else
         ModifySize = FormatNumber(sz,0) & "バイト"
     End If 
 End Function 

ごみ箱にファイル移動 ↑

 Sub RemoveFile(FolderName,FileName)
     Const ssfBITBUCKET=10
     Set Folder=Shell.NameSpace(FolderName)
     Set FolderItem=Folder.ParseName(FileName)
     Shell.NameSpace(ssfBITBUCKET).MoveHere FolderItem
     Do
         Set FolderItem=ParseName(Folder,FileName)
         If FolderItem Is Nothing Then Exit Do
         WScript.Sleep 100
     Loop
     'WScript.Sleep 200
 End Sub
 
 Function ParseName(Folder,Name) 'For Windows98
     Set ParseName=Nothing
     On Error Resume Next
     Set ParseName=Folder.ParseName(Name)
 End Function

タイムスタンプ（更新日時）更新 ↑

 Sub ModifyDate(path,ddate)
 'path=ファイルのパス 'ddate=更新日時
 	Shell.NameSpace(Fs.GetParentFolderName(path)).ParseName(Fs.GetFileName(path)).ModifyDate=CDate(ddate)
 End Sub

ネットワーク ↑

ping(手抜き版) ↑

 Function Ping(sComputerName)
     Const PING_CMD = "ping -n 1 -w 100 "
     Const PING_OK_STR = "Packets: Sent = 1, Received = 1, Lost = 0 (0% loss),"
     Dim sCmdLine
     sCmdLine = PING_CMD & sComputerName
     Ping = CBool(InStr(WshShell.Exec( sCmdLine ).StdOut.ReadAll, PING_OK_STR))
 End Function

メール送信(添付ファイル付き) ↑

 Const AttachFileName="ファイル名"
 Const MailFrom="from@example.com"
 Const MailTo="to@example.com"
 Const MailSubject="Test mail"
 
 Set oMsg = CreateObject("CDO.Message")
 oMsg.From = MailFrom
 oMsg.To = MailTo
 oMsg.Subject = MailSubject
 oMsg.TextBody = "このメールは、メール送信WSHで自動送信されたメールです。" & vbCrLf & Now
 oMsg.AddAttachment AttachFileName
 oMsg.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
 oMsg.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "localhost"
 oMsg.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
 oMsg.Configuration.Fields.Update
 oMsg.Send

• 参考：@IT Windows標準機能とWSHを使ってメールを送信する
• なお、この方法でメールを送るためにはSMTPサーバが必要です。自分のPCだけで実行するのなら、SAPPOROWORKSさんのradishがオススメ。

レジストリ ↑

サブキーを含むレジストリキーの削除 ↑

WshShell?.RegDelete?では、サブキーが存在するレジストリキーは削除できませんが、WMIを使った以下の方法で可能です。

 Const HKEY_CLASSES_ROOT = &H80000000
 Const HKEY_CURRENT_USER = &H80000001
 Const HKEY_LOCAL_MACHINE = &H80000002
 Const HKEY_USERS = &H80000003
 Const HKEY_PERFORMANCE_DATA = &H80000004
 Const HKEY_CURRENT_CONFIG = &H80000005
 Const HKEY_DYN_DATA = &H80000006
 
 Set oReg=GetObject("winmgmts:{impersonationLevel=impersonate}" & _
 "!\\.\root\default:StdRegProv")
 
 'HKEY_LOCAL_MACHINE\SOFTWARE\WshRegDeleteExSampleキーを削除する
 Call RegDeleteEx (HKEY_LOCAL_MACHINE, "SOFTWARE\WshRegDeleteExSample")
 
 Sub RegDeleteEx(iRootKey,sKey)
     oReg.EnumKey iRootKey, sKey, aSubKeys 'サブキーの列挙
     If IsArray(aSubKeys) Then 'もし、サブキーが存在するなら
         For Each sSubKey In aSubKeys '各サブキーに対して再帰呼び出し
             Call RegDeleteEx(iRootKey,sKey & "\" & sSubKey)
         Next
     End If
     oReg.DeleteKey iRootKey,sKey '削除
 End Sub

Shell ↑

アプリケーションから起動 ↑

メモ帳を実行する例

 WScript.CreateObject("WScript.Shell").Run "C:\Windows\notepad.exe"

テキストファイルを開く例

 WScript.CreateObject("WScript.Shell").Run "tips.txt"

こちらはドキュメントに対して、関連付けられたアプリケーションで実行される。よって起動されるアプリケーションは絶対メモ帳という訳ではなく、環境によっては秀丸だったりする。

ウィンドウの整列 ↑

 With CreateObject("Shell.Application")
     .MinimizeAll         '全ウィンドウを最小化
     .UndoMinimizeALL     'ウィンドウ操作を元にもどす
     .TileVertically      'ウィンドウを左右に並べて表示
     .TileHorizontally    'ウィンドウを上下に並べて表示
     .CascadeWindows      'ウィンドウを重ねて表示
 End With

WMI ↑

ログオンユーザー名取得処理 ↑

 Function GetLogonUserName(sComputerName) '=== 要権限
     Const SQL = "SELECT * FROM Win32_ComputerSystem"
     Set WMI = CreateObject("WbemScripting.SWbemLocator")
     Set Services = WMI.ConnectServer(sComputerName, "root/cimv2")
     GetLogonUserName = ""
     For Each Info In Services.ExecQuery(SQL)
         GetLogonUserName =  CStr(Info.UserName & "")
     Next
 End Function

ADSI ↑

ドメイン配下のコンピュータ一覧出力 ↑

1.通常版

 Set oComputers = GetObject("WinNT://" & CreateObject("WScript.Network").UserDomain)
 oComputers.Filter = Array("Computer")
 For Each oComputer In oComputers
     Call WScript.Echo(CStr(oComputer.Name & ""))
 Next

2.ADO版

 Set oADOCon = CreateObject("ADODB.Connection")
 Set oADOCmd =   CreateObject("ADODB.Command")
 oADOCon.Provider = "ADsDSOObject"
 Call oADOCon.Open("Active Directory Provider")
 Set oADOCmd.ActiveConnection = oADOCon
 oADOCmd.CommandText = _
    "SELECT NAME " & _
    " FROM 'LDAP://" & _
    GetDC(CreateObject("WScript.Shell").Environment("PROCESS")("USERDNSDOMAIN")) & _
    "'" & _
    " WHERE ObjectClass='computer'"
 Set oADORS = oADOCmd.Execute
 Call oADORS.MoveFirst
 Do Until oADORS.EOF
     Call Wscript.Echo(oADORS.Fields("Name").Value)
     Call oADORS.MoveNext
 Loop
 Function GetDC(sDNSDomainName)
     GetDC = "DC=" & Join(split(sDNSDomainName, "."),",DC=")
 End Function

アカウントユーザーがグループに所属しているか？ ↑

 Private Function IsMemberInGroup(sUserPath, sGroupPath)
    Dim oMember
    Dim sMemberPathName
  REM WScript.Echo "======" & sUserPath & vbTab & sGroupPath & "====="
    IsMemberInGroup = False
    For Each oMember In GetObject(sGroupPath).Members
        sMemberPathName = ""
        sMemberPathName = CStr(oMember.AdsPath & "")
        If oMember.class = "Group" Then
            IsMemberInGroup = IsMemberInGroup(sUserPath, oMember.AdsPath)
        End If
        If sMemberPathName = sUserPath Then
            IsMemberInGroup = True
        End If
        If IsMemberInGroup = True Then
            Exit For
        End If
 Rem WScript.Echo oMember.AdsPath & vbTab & oMember.Name
    Next
 End Function

使い方

 Private Sub Main
    Dim sUserPath, sGroupPath
    With CreateObject("WScript.Network")
        sUserPath = "WinNT://" & .UserDomain & "/" & .UserName
        sGroupPath = "WinNT://" & .ComputerName & "/Administrators"
    End With
    Msgbox IsMemberInGroup(sUserPath, sGroupPath)
 End Sub