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