3流プログラマのメモ書き

元開発職→現社内SEの三流プログラマのIT技術メモ書き。 このメモが忘れっぽい自分とググってきた技術者の役に立ってくれれば幸いです。(jehupc.exblog.jpから移転中)

OpenOffice3.41を展開するためのVBScript

現在、LAN内の端末はOpenOffice3.2や3.3を使っています。 これを一斉に3.41にアップグレードする必要が生じました。
設定もデフォルトだったので、こちらである程度設定したものを展開したいと思っています。

グループポリシー等の自動展開機能を使わず、ユーザがスクリプトを開いたらインストール/アップグレードが始まるようにするという要件です。 なお、OpenOffice内の設定については、予め設定したユーザから、設定ファイル郡(ユーザプロファイル\Application Data\OpenOffice.org)をコピーし、それをインストール直後に存在するユーザプロファイルにコピーするという手法をとっています。
また、インストールが完了すれば、このコンピュータ名のテキストファイルを、\hogeserver\ooo341setup\ooo_installflg\ 配下に保存するようにしています。 インストール中はプログレスバーは見せるものの、キャンセルは出来ないようにしています。
スクリプトはこんな感じです。

Option Explicit
Const vbHide = 0             'ウィンドウを非表示
Const vbNormalFocus = 1      '通常のウィンドウ、かつ最前面のウィンドウ
Const vbMinimizedFocus = 2   '最小化、かつ最前面のウィンドウ
Const vbMaximizedFocus = 3   '最大化、かつ最前面のウィンドウ
Const vbNormalNoFocus = 4    '通常のウィンドウ、ただし、最前面にはならない
Const vbMinimizedNoFocus = 6 '最小化、ただし、最前面にはならない

'設定ファイルのコピー元フォルダ(ユーザプロファイル\Application Data\OpenOffice.orgからコピーしたフォルダ群)
Const  cstrSourcePath = "\\hogeserver\ooo341setup\ooo_config\OpenOffice.org"
'製品名
Const  cstrOeeName = "OpenOffice3.41"
'インストールexeのパス(\\hogeserver\ooo341setup\ooo配下にダウンロードしたOpenOfficeインストーラの展開されたファイルを置きます。)
Const  cstrPackagePath = "\\hogeserver\ooo341setup\ooo\setup.exe"
'インスト済みホスト名を保存するフォルダ
Const  cstrInstFlagSaveFolder = "\\hogeserver\ooo341setup\ooo_installflg\"

Dim objWShell
Set objWShell = CreateObject("WScript.Shell")

'ooo32プロダクトコード
Const  cstrOoo32ProductCode = "{B0501912-8B9F-47CA-9CEC-DCA247BFE205}"
Dim  strOoo32UninstPath 
strOoo32UninstPath= objWShell.ExpandEnvironmentStrings( "%windir%\Installer\" & cstrOoo32ProductCode )
'ooo33プロダクトコード
Const  cstrOoo33ProductCode = "{489F2D20-B590-4CB0-AB11-F01024225187}"
Dim  cstrOoo33UninstPath 
cstrOoo33UninstPath = objWShell.ExpandEnvironmentStrings( "%windir%\Installer\" & cstrOoo33ProductCode )


Dim objNet 
Set objNet = CreateObject("WScript.Network")
Dim objFileSys
Set objFileSys = CreateObject("Scripting.FileSystemObject")

'戻り値
Dim iRtnCode
iRtnCode = 0

'インストール前チェック プロシージャ呼び出し
InstallCheck objWShell , objNet , objFileSys

'On Error Resume Nextの効果を解除
On Error Goto 0


'既存のバージョン削除
'過去バージョン確認(ooo32)
If objFileSys.FolderExists(strOoo32UninstPath) = True Then
    MsgBox "過去バージョンをアンインストールします。",vbInformation+vbOKOnly , cstrOeeName & "インストーラー"
    'qb! でキャンセルボタンを非表示にできる
    iRtnCode = objWShell.Run( "msiexec /x " & """" & cstrOoo32ProductCode & """" & " /qb! " , vbNormalFocus, True )
    ReturnCodeCheck iRtnCode
    'IE開くまで待つ
    WScript.sleep(5000)
    'IEを閉じる(アンインストール後になぜかIEが開くのでそれを閉じる。)
    TerminateProcess("iexplore.exe")
End IF
'過去バージョン確認(ooo33)
If objFileSys.FolderExists(cstrOoo33UninstPath) = True Then
    MsgBox "過去バージョンをアンインストールします。",vbInformation+vbOKOnly , cstrOeeName & "インストーラー"
    'qb! でキャンセルボタンを非表示にできる
    iRtnCode = objWShell.Run( "msiexec /x " & """" & cstrOoo33ProductCode & """" & " /qb! " , vbNormalFocus, True)
    ReturnCodeCheck iRtnCode
    'IE開くまで待つ
    WScript.sleep(5000)
    'IEを閉じる
    TerminateProcess("iexplore.exe")
End IF



'If Err.Number <> 0 Then
'   MsgBox "エラーが発生しました。インストールを中断します。" & VbCrLf & "エラー番号:" & Err.Number & VbCrLf & "エラー詳細:" &  Err.Description
'   WScript.Quit
'End If 
'Err.Clear
'On Error Goto 0

'セットアップ実行
iRtnCode = objWShell.Run( """" & cstrPackagePath & """"  & " /qb!", vbNormalFocus, True)
ReturnCodeCheck iRtnCode

'設定ファイルを全ユーザにコピーする  プロシージャ呼び出し
ConfigToUserProfile

'インスト済みホスト名を保存  プロシージャ呼び出し
WriteInstFlgFile objNet
MsgBox "インストールが正常に完了しました。" , vbOKOnly+vbInformation , cstrOeeName & "インストーラー"
WScript.Quit 0




'-------------------------------------------------------------------------------
' インストール前チェック。ホスト名、既に最新版が入ってるかチェック
'-------------------------------------------------------------------------------
Sub InstallCheck(objWShell , objNet , objFileSys)
    'OSが2000以下なら実行させない
    Dim osVer
    osVer = GetOSType()
    If osVer < 5.1 Then 
        '2000以前
        MsgBox "このバージョンのWindowsではインストールはできません。処理を終了します。", vbCritical+vbOKOnly , cstrOeeName & "インストーラー"
        WScript.Quit 0
    End If

    'コンピュータ名取得 ココに列挙したコンピュータには実行させない
    IF StrComp(objNet.ComputerName , "server01" ,1 ) = 0 OR _
       StrComp(objNet.ComputerName , "server02" ,1 ) = 0 OR _
       StrComp(objNet.ComputerName , "server03" ,1 ) = 0 OR _
       StrComp(objNet.ComputerName , "server04" ,1 ) = 0 Then
        
        MsgBox cstrOeeName & "のインストールはこのコンピュータでは実行する必要はありません。" ,vbExclamation+vbOKOnly , cstrOeeName & "インストーラー"
        WScript.Quit 0

    End If

    '既に最新版が入っていればインストールしない
    Dim strKey
    strKey = "HKLM\SOFTWARE\OpenOffice.org\OpenOffice.org\3.4.1\"
    On Error Resume Next 'エラーを無視する
    If  IsNull(objWShell.RegRead( strKey )) Then  'notを使うと動きが怪しくなる
    Else
        Msgbox "既に" & cstrOeeName & "がインストールされています。" & VbCrLf & "インストールの必要はないので処理を終了します。" , vbinformation+vbOKOnly , cstrOeeName & "インストーラー"
        WScript.Quit 0
    End If
    
    'インストールファイルの存在確認 
    If objFileSys.FileExists(cstrPackagePath) = False Then
        MsgBox "エラー:インストールファイルが存在しないかアクセスできません。インストールできませんでした。" , vbCritical+vbOKOnly , cstrOeeName & "インストーラー"
        WScript.Quit
    End IF

    IF MsgBox(cstrOeeName & "のインストールを開始しますか?" & VbCrLf & VbCrLf & _
        "インストールには10~30分程度かかります。" & VbCrLf & "インストール中は全てのプログラを閉じ、指示が出るまで操作をしないでください。(キャンセルボタンは押さないでください) " & VbCrLf & _
        "また、ネットワークを切断しないでください。" ,vbQuestion+vbOKCancel , cstrOeeName & "インストーラー") = vbCancel Then
        WScript.Quit 0
    End If

End Sub



'-------------------------------------------------------------------------------
' 呼び出し先エラー発生時の処理
'-------------------------------------------------------------------------------
Sub ReturnCodeCheck(iRtnCode)
    If iRtnCode <> 0 Then
        MsgBox "エラーが発生したため処理を続行できません。Win32エラーコード:0x" & Hex(iRtnCode) , vbCritical+vbOKOnly , cstrOeeName & "インストーラー"
        WScript.Quit 0
    End If
End Sub

'-------------------------------------------------------------------------------
' 指定した名前のプロセスを強制終了
'-------------------------------------------------------------------------------
Sub TerminateProcess(ProcessName)
    Dim objProcList,objProcess
    Set objProcList = GetObject("winmgmts:").InstancesOf("win32_process")
    For Each objProcess In objProcList
        If LCase(objProcess.Name) = LCase(ProcessName) Then
            objProcess.Terminate
            Exit For
        End If
    Next
End Sub

'-----------------------------------------------------------
'処理内容:設定ファイルを全ユーザのユーザプロファイルフォルダにコピーする
'-----------------------------------------------------------
Sub ConfigToUserProfile()
    On error resume next
    Err.Clear

    Dim strProfleFolder , aryProfileFolders , objFileSys , objFolder , osVer , strDstCopyPath
    aryProfileFolders = GetUserProfileFolders()
    osVer = GetOSType()

    Set objFileSys=CreateObject("Scripting.FileSystemObject")

    For Each strProfleFolder In aryProfileFolders 
        'Wscript.Echo strProfleFolder 
        Set objFolder = objFileSys.GetFolder(strProfleFolder)
        'WScript.Echo " - " & objFolder.Name
        
        If osVer < 6.0 Then 
            'XP以前
            strDstCopyPath = objFolder.Path & "\Application Data\"  
        Else 
            'Vista以降
            strDstCopyPath = objFolder.Path & "\AppData\Roaming\"  
        End If
        
        'ユーザプロファイルフォルダ名が以下の名前ではなく、存在した場合のみコピー
        If objFolder.Name <> "Administrator" AND _
           objFolder.Name <> "administrator.DOMAINNAME" AND _
           objFolder.Name <> "All Users" AND _
           objFolder.Name <> "Default User" AND _
           objFolder.Name <> "LocalService" AND _
           objFolder.Name <> "Public" AND _
           objFolder.Name <> "Default" AND _
           objFolder.Name <> "NetworkService" AND _
           objFolder.Name <> "systemprofile" OR _
           objFileSys.FileExists(strDstCopyPath)  = True Then
        
            'WScript.Echo "コピー先:" & strDstCopyPath
            'コピー処理
            objFileSys.CopyFolder cstrSourcePath , strDstCopyPath
        End If
    Next
End Sub


'-----------------------------------------------------------
'処理内容:'ユーザプロファイルフォルダの配列を取得
'戻り値:ユーザプロファイルフォルダの配列
'-----------------------------------------------------------
Function GetUserProfileFolders()
    'On Error Resume Next 
    Dim strComputer , objRegistry , strKeyPath , arrSubkeys
    Const HKEY_LOCAL_MACHINE = &H80000002 
    strComputer = "." 

    Set objRegistry=GetObject("winmgmts:\\" & strComputer & "\root\default:StdRegProv") 

    strKeyPath = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\ProfileList" 
    objRegistry.EnumKey HKEY_LOCAL_MACHINE, strKeyPath, arrSubkeys 

    Dim aryProfileFolders() , i , strValueName , strSubPath , strValue
    ReDim aryProfileFolders(UBound(arrSubkeys) ) 

    For i = 0 To UBound(arrSubkeys) 
        strValueName = "ProfileImagePath" 
        strSubPath = strKeyPath & "\" & arrSubkeys(i) 
        objRegistry.GetExpandedStringValue HKEY_LOCAL_MACHINE,strSubPath,strValueName,strValue 
    '   Wscript.Echo strValue 
        aryProfileFolders(i) = strValue
    Next
    GetUserProfileFolders = aryProfileFolders
End Function


'-----------------------------------------------------------
'処理内容:OS情報の取得(NTx.xの情報のみ)
'戻り値:NTのバージョン情報(小数点)
'-----------------------------------------------------------
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 = CSng( Mid(szTmp,1,3) )
      'WScript.Echo OsVal
    Next
    GetOSType = OsVal
    Err.Clear
End Function


'-----------------------------------------------------------
'インスト済みフラグファイル書込
'-----------------------------------------------------------
Sub WriteInstFlgFile( objNet )
    On error resume next
    Err.Clear

    Dim objTextStream , objFileSys
    Set objFileSys=CreateObject("Scripting.FileSystemObject")
    'バージョンファイル書き込み
    'ファイル開く(上書きモード)
    Set objTextStream = objFileSys.OpenTextFile(cstrInstFlagSaveFolder & objNet.ComputerName , 2 )
    objTextStream.WriteLine  objNet.ComputerName 
    objTextStream.Close()
    Set objTextStream = Nothing
End Sub