Option Explicit '------------------------------------------------------------------------------- 'logon.vbs '共有フォルダとプリンタを割り当てる 'マップファイルの定義を見て、共有フォルダ、プリンタのマッピングを行う 'Version 2.0.2 2007/03/17 'Version 2.0.1 2007/02/27 '------------------------------------------------------------------------------- 'マップファイルの書式 'タブ区切りのテキストファイル。マップファイルはローカルPCのWindowsフォルダまたは 'スクリプトファイルと同じフォルダに置く。 '1列目: 対象オブジェクトの種類 ' all 全て ' group グループ ' ip IPアドレス ' user ユーザ ' pc コンピュータ '2列目: 対象とするオブジェクト ' オブジェクト名。user,pcの場合は末尾に*をつけると前方一致。 ' IPアドレスの場合は10.20.30.0/255.255.255.0の形式でアドレス範囲指定できる。 ' 1列目がallの場合はここの値は無視されるがタブの入れ忘れ防止のため,この列 ' には,*を入れることを推奨する。 '3列目: コマンド ' alert 4列目で指定した文字列をポップアップ表示する(テスト用) ' exec 外部コマンドを実行する ' exit 処理を終了する(以降のマップファイルを評価しない) ' includeされたマップファイルでは現在のマップファイルの処理を ' 終了し上位のマップファイルに戻る ' prn 共有プリンタをマッピングする ' defprn 共有プリンタを通常使うプリンタにする ' include 別のマップファイルをインクルードする ' log 成功ログの記録 ' <ドライブ名>: 共有フォルダのドライブを割り当てる '4列目: パス名など ' prn,defprnや<ドライブ名>:の場合は,共有名のUNCパス ' alartの場合は表示する文字列 ' execの場合は実行するコマンド ' includeの場合は,読み込むマップファイル名。 ' logの場合はonで記録する,offで記録しない ' ファイル名は絶対パスまたはスクリプトファイルからの相対パスで記述できる。 '5列目: オプション ' prnの場合にforceが指定されていると割り当て済みでも割り当てる ' prnや<ドライブ名>:の場合にdeleteが指定されていると割り当てを解除する '------------------------------------------------------------------------------- Const MAP_FILE = "mapfile.txt" 'マップファイル名 Const ForReading = 1 Dim wshNetwork, sUser, Groups, sPrinters, sScriptPath Dim FSO Dim isMatch Dim sMapFileName Dim SuccessLog SuccessLog = False '成功ログの記録フラグ(初期値は記録しない) Set FSO = CreateObject("Scripting.FileSystemObject") Set wshNetwork = CreateObject("WScript.Network") GetUserName '所属グループを得る Groups = GetGroups 'インストール済みプリンタを得る sPrinters = GetPrinterShareNames 'ローカルのmapfile.txtを調べる sScriptPath = FSO.GetSpecialFolder(0) & "\" sMapFileName = sScriptPath & MAP_FILE If not FSO.FileExists(sMapFileName) Then sScriptPath = ExtructPath(WScript.ScriptFullName) sMapFileName = sScriptPath & MAP_FILE End If '実行 On Error Resume Next Mapping sMapFileName '*** End of Script '/** ' * ユーザ名を得る ' * ' * ユーザ名が空の時はログインされるまで待つ。 ' * 30秒以上ダメならスクリプト自体をやめる ' */ Sub GetUserName Dim startTime sUser = wshNetwork.UserName startTime = Now Do While sUser = "" If DateDiff("s", startTime, Now) > 30 Then WriteLog -1, "ユーザ名の取得に失敗しました" Wscript.Quit End If Wscript.Sleep 500 wshNetwork = wshNetwork.UserName Loop End Sub '/** ' * マップファイルを読んでマッピングを実行する ' * ' * @param AMapName マップファイル名 ' */ Sub Mapping(AMapName) Dim Stream, sBuf, sKind, sObj, sCommand, sPath, sOpt Set Stream = FSO.OpenTextFile(AMapName, ForReading) WriteLog Err.Number, "(Open)" & AMapName & Err.Description Do While not Stream.AtEndOfStream sBuf = LTrim(Stream.ReadLine) If Left(sBuf,2) = "//" Then 'コメント行 ElseIf Trim(sBuf) = "" Then '空行 Else isMatch = False '1行からパラメータを抽出 If ReadLine(sBuf, sKind, sObj, sCommand, sPath, sOpt) Then 'WriteLog Err.Number, Err.Description '処理対象かどうかを判断 Select Case sKind Case "all", "*" isMatch = True Case "user" isMatch = IsLike(LCase(sUser), sObj) Case "group","grp" isMatch = IsInGroup(sObj) Case "pc","computer" isMatch = IsLike(LCase(wshNetwork.ComputerName), sObj) Case "ip","address" isMatch = isInNet(MyIPAddress, sObj) Case Else isMatch = False End Select '処理 If isMatch Then Select Case sCommand case "alert" WScript.Echo sPath case "exec" ShellExecute sPath case "exit" '以後の処理はしない Exit Do case "include" Mapping sScriptPath & sPath case "prn" MapPrinter sPath, sOpt case "defprn" '通常使うプリンタにする wshNetWork.SetDefaultPrinter sPath case "log" If LCase(sPath) = "on" Then SuccessLog = True ElseIf LCase(sPath) = "off" Then SuccessLog = False End If case else If IsDrive(sCommand) Then MapDrive sCommand, sPath, sOpt Else WriteLog -1, "コマンドが正しくありません" & " : [" & sBuf & "]" End If End Select WriteLog Err.Number, Err.Description & " : [" & sBuf & "]" End If End If End If Loop Stream.Close End Sub '/** ' * ドライブを割り当てる ' * 既に割り当てられているときには切断してから接続しなおす ' * ' * @param ADrive ドライブ名 ' * @param APath ネットワークドライブのUNCパス ' * @param AOpt オプション deleteが指定されていたら切断するのみ ' */ Sub MapDrive(ADrive, APath, AOpt) Dim oldPath '削除 If LCase(AOpt) = "delete" Then If not IsNull(GetDriveUNC(ADrive)) Then wshNetwork.RemoveNetworkDrive ADrive, True, True End If Exit Sub End If '追加 oldPath = GetDriveUNC(ADrive) If IsNull(oldPath) Then 'ドライブ割り当て無しの場合は割り当てる wshNetwork.MapNetworkDrive ADrive, APath ElseIf UCase(OldPath) <> UCase(APath) Then '違うパスが割り当てられている場合は切断してから割り当て wshNetwork.RemoveNetworkDrive ADrive, True, True wshNetwork.MapNetworkDrive ADrive, APath End If WriteLog Err.Number, "(function MapDrive)" & Err.Description & " : [" & ADrive & "-" & APath & "-" & AOpt & "]" End Sub '/** ' * プリンタを割り当てる ' * プリンタが未割り当ての時にだけ割り当てる ' * ' * @param APath ネットワークプリンタのUNCパス ' * @param AOpt deleteが指定されていたら切断する ' * forceが指定されていたら既に割り当てられていても割り当てを実行する ' */ Sub MapPrinter(APath, AOpt) ' Dim isExsist isExsist = InStr(sPrinters, APath) > 0 If LCase(AOpt) = "delete" Then If isExsist Then wshNetWork.RemovePrinterConnection APath, true WriteLog 0, "Delete Printer " & APath End If Else If Not(isExsist) Or LCase(AOpt) = "force" Then wshNetwork.AddWindowsPrinterConnection APath WriteLog 0, "Add Printer " & APath End If End If WriteLog Err.Number, "(function MapPrinter)" & Err.Description & " : [" & APath & "-" & AOpt & "]" End Sub '/** ' * ドライブに割り当てられたUNCパスを得る ' * ' * @param ADrive ドライブ名 ' * @return 割り当て済みならUNCパス,割り当てがなければNull ' */ Function GetDriveUNC(ADrive) Dim Drives, Drive, i Set Drives = wshNetwork.EnumNetworkDrives For i = 0 to Drives.Count - 1 Step 2 Drive = Drives.Item(i) If Drive = UCase(ADrive) Then GetDriveUNC = Drives.Item(i+1) Exit Function End If Next GetDriveUNC = Null End Function '/** ' * エラー時にイベントログを記録する ' * SuccessLogがTrueの時は成功ログも記録する ' * ' * @param ENumber エラー番号 ' * @param EMessage エラーメッセージ ' */ Sub WriteLog(ENumber, EMessage) Dim objShell Set objShell = WScript.CreateObject("WScript.Shell") If ENumber <> 0 Then objShell.LogEvent 1, WScript.ScriptName & " : (" & ENumber & ")" & EMessage Err.Clear ElseIf SuccessLog Then objShell.LogEvent 0, WScript.ScriptName & " : (成功)" & EMessage End If End Sub '/** ' * グループ名リストを得る ' * ' * @return グループ名のリスト ' */ Function GetGroups Dim ADSysInfo, CurrentUser, sType Set ADSysInfo = CreateObject("ADSystemInfo") Set CurrentUser = GetObject("LDAP://" & ADSysInfo.UserName) sType = TypeName(CurrentUser.MemberOf) If sType = "String" Then GetGroups = LCase(CurrentUser.MemberOf) ElseIf sType = "Empty" Then GetGroups = "" Else GetGroups = LCase(Join(CurrentUser.MemberOf)) End If WriteLog Err.Number, "(function GetGroups)" & Err.Description End Function '/** ' * グループに所属しているかどうかをチェック ' * ' * @param AGroup グループ名 ' * @return グループに所属している場合はTrue ' */ Function IsInGroup(AGroup) IsInGroup = InStr(Groups, "cn=" & LCase(AGroup) & ",") End Function '/** ' * 1行を読み取り分解して値を返す ' * ' * @param ABuf ファイルから読み取った1行の文字列 ' * @param AKind 1列目: 対象オブジェクトの種類 ' * @param AObj 2列目: 対象とするオブジェクト ' * @param ACommand 3列目: コマンド ' * @param APath 4列目: パス ' * @param AOpt 5列目: オプション ' * @return True=正常 False=エラー ' */ Function ReadLine(ABuf, AKind, AObj, ACommand, APath, AOpt) Dim sLine, i, isErr sLine = Split(ABuf, vbTab) i = UBound(sLine) If i < 2 Then isErr = True Else AKind = LCase(sLine(0)) AObj = LCase(sLine(1)) ACommand = LCase(sLine(2)) If i = 2 Then If ACommand <> "exit" Then isErr = True Else isErr = False End If Else isErr = False APath = sLine(3) End If End If If i = 4 Then AOpt = sLine(4) Else AOpt = "" End If If isErr Then WriteLog -1, "パラメータが不足しています : [" & ABuf & "]" End If ReadLine = not isErr 'WriteLog Err.Number, "(function ReadLine)" & Err.Description End Function '/** ' * ドライブ指定かかどうかをチェック ' * ' * @param ACommand コマンド ' * @return ドライブ指定の場合はTrue ' */ Function IsDrive(ACommand) Dim sDrive sDrive = UCase(Trim(ACommand)) If Len(sDrive) <> 2 Then IsDrive = false Else If Right(sDrive, 1) = ":" And sDrive >="A" AND sDrive <="Z" Then IsDrive = true Else IsDrive = false End If End If End Function '/** ' * Like関数 前方一致・後方一致のみサポート ' * ワイルドカードは先頭・末尾の*のみ使用可能。 ' * ' * @param ASource 文字列 ' * @param APattern 比較するパターン ' * @return True=一致する ' */ Function IsLike(ASource, APattern) Dim sSource, sPattern Dim L If Left(APattern, 1) = "*" Then L = Len(APattern) - 1 sPattern = Right(APattern, L) sSource = Right(ASource, L) ElseIf Right(APattern, 1) = "*" Then L = Len(APattern) - 1 sPattern = Left(APattern, L) sSource = Left(ASource, L) Else sPattern = APattern sSource = ASource End If IsLike = sPattern = sSource End Function '/** ' * プリンタの共有名リストを得る ' * ワイルドカードは先頭・末尾の*のみ使用可能。 ' * ' * @return プリンタの共有名を;でつなげた文字列 ' */ Function GetPrinterShareNames Dim objWMIService, objItem, colItems, sR, sShareName Set objWMIService = GetObject("winmgmts:\\.\root\cimv2") Set colItems = objWMIService.ExecQuery("Select * from Win32_Printer",,48) sR = "" For Each objItem in colItems sShareName = objItem.ServerName & "\" & objItem.ShareName If Len(sShareName)>0 Then sR = sR & sShareName & ";" End If 'WriteLog 0, "(PrinterShareName)" & sShareName Next GetPrinterShareNames = sR WriteLog Err.Number, "(function PrinterShareNames)" & Err.Description End Function '/** ' * ファイル名の中からパス部分を取り出す ' * ' * @param sFullPath フルパスのファイル名 ' * @return パス ' */ Function ExtructPath(sFullPath) Dim p Dim result p = InStrRev(sFullPath, "\") If p = 0 Then p = InStr(sFullPath, ":") If p = 0 Then result = "" Else result = Left(sFullPath, p) & "\" End If Else result = Left(sFullPath, p) End If ExtructPath = result End Function '/** ' * IPアドレスが指定した範囲内かどうかをチェックする ' * ' * @param AAddress IPアドレス ' * @param ARange ネットワーク範囲 ' * ネットワークアドレス/サブネットの形式で指定 ' * 例)10.20.30.0/255.255.255.0 ' * @return 範囲内であればTrue ' */ Function isInNet(AAddress, ARange) Dim sRange, aAddrs, aSubNets, aRanges Dim i aAddrs = Split(AAddress, ".") If InStr(ARange, "/") = 0 Then sRange = ARange & "/255.255.255.255" Else sRange = ARange End If aRanges = Split(sRange, "/") aSubNets = Split(aRanges(1), ".") For i = 0 To 3 aAddrs(i) = aAddrs(i) And aSubNets(i) Next isInNet = Join(aAddrs, ".") = aRanges(0) End Function '/** ' * ローカルマシンのIPアドレスを得る ' * ' * @return 複数ある場合は先頭のIPアドレス ' */ Function MyIPAddress() Dim WMI Dim Item, Items, IP Dim result Dim results Set WMI = GetObject("winmgmts:\\.\root\cimv2") Set Items = WMI.ExecQuery _ ("Select * From Win32_NetworkAdapterConfiguration " & _ "Where IPEnabled = True") For Each Item In Items For Each IP In Item.IPAddress result = result & IP & ";" Next Next results = Split(Left(result, Len(result) - 1), ";") MyIPAddress = results(0) End Function '/** ' * 外部コマンドの実行 ' * ' * @param ACommand 実行するコマンド ' */ Sub ShellExecute(ACommand) Dim objShell Set objShell = WScript.CreateObject("WScript.Shell") objShell.Run ACommand End Sub