« スーパー芝刈り機 | トップページ | VBScriptでレジストリ操作 その2 (その1の解説編) »

2013年8月11日 (日)

VBScriptでレジストリ操作 その1

レジストリ操作をするために、スクリプトなど書かなくても、普通に「regedit」で修正すればいいのですが、

一般ユーザ(というかPCに詳しくない人)にレジストリを触らせるのが嫌な場面は多いです。

まあ、ポリシーの適用で何とかなったりすることもありますが、今回は必要に迫られて書いてみた。

汎用性はそれなりに高めたつもりなので、再利用時の備忘として記録。

ソースは以下に。ファイル名はお好みで。拡張子は、「vbs」とします。

Option Explicit
    Dim strOSType
    Dim strOfficeVer
    Dim strIEVer
    Dim strMsg
    Dim Answer
    Dim Shell
    
    strIEVer = Mid(GetIEVer(),1,4)
    IF strIEVer = "IE 6" Then
    ElseIf strIEVer = "IE 7" Then
    ElseIf strIEVer = "IE 8" Then
    Else
        MsgBox "動作保障外のInternetExploreです。 検出されたIEバージョン = " & GetIEVer()
        WScript.Quit
    End If
    
    strOfficeVer = GetOfficeVer("EXCEL")
    IF strOfficeVer = "EXCEL2003" Then
    Else
        MsgBox "動作保障外のEXCELです。 検出されたEXCELバージョン = " & strOfficeVer 
        WScript.Quit
    End If
    
    strOSType = GetOSType()
    IF strOSType = "Windows XP" Then
    ElseIf strOSType = "Windows 7" Then
        do while WScript.Arguments.Count=0
            strMsg = "「ユーザーアカウント制御」ダイアログ画面で、"
            strMsg = strMsg & vbCrLf & "「次のプログラムにコンピュータへの変更を許可しますか?」"
            strMsg = strMsg & vbCrLf & "と表示される場合は、「はい」を返答してください。"
            Answer = MsgBox(strMsg , vbInformation + vbOKOnly , Wscript.ScriptName)
            Set Shell=CreateObject("Shell.Application")  
            Shell.ShellExecute "wscript.exe","""" & WScript.ScriptFullName & """ uac","","runas"
            WScript.Quit
        loop
    Else
        MsgBox "動作保障外のOSです。 検出されたOSバージョン = " & strOSType
        WScript.Quit
    End If
    
    strMsg = "InternetExplore 及び EXCEL の設定変更を行います。"
    strMsg = strMsg & vbCrLf & "念のため、InternetExplore 及び EXCEL を全て終了し、"
    strMsg = strMsg & vbCrLf & "「OK」を返答してください。"
    Answer = MsgBox(strMsg , vbExclamation + vbOKCancel + vbDefaultButton2 , Wscript.ScriptName)
    If Answer <> vbOK Then
        MsgBox "設定変更処理をキャンセルしました。"
        WScript.Quit
    End If

    Call SetBrowserFlag()
    MsgBox "設定変更処理が正常に終了しました"
    WScript.Quit
'-----------------------------------------------------------
'処理内容: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

'-----------------------------------------------------------
'処理内容:OSのバージョンを取得
'引数:なし
'戻り値:OSのバージョン
'-----------------------------------------------------------
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
'-----------------------------------------------------------
'処理内容:Internet Explorerのバージョンを取得
'戻り値:Internet Explorerのバージョン
'-----------------------------------------------------------
Function GetIEVer()
  On error resume next
  Err.Clear
  Dim strRet
  Dim IEVer
  Dim Shell
  Dim RegKey

  strRet = ""
  IEVer = ""

  Set Shell = CreateObject("WScript.Shell")

  RegKey = "HKLM\SOFTWARE\Microsoft\Internet Explorer\Version"
  IEVer = Shell.RegRead(RegKey)

  IF Err.Number = 0 Then
    strRet = "IE " & IEVer
  Else
    strRet = "未インストール"
  End IF

  GetIEVer = strRet

  Err.Clear

End Function
'-----------------------------------------------------------
'処理内容:Excelをブラウザ外で開くようレジストリを書き換え
'引数:なし
'戻り値:なし
'-----------------------------------------------------------
Function SetBrowserFlag()
    On error resume next
    Err.Clear
    Dim WshShell
    Dim regStr

    Set WshShell = CreateObject("WScript.Shell")

    regStr = "HKEY_CLASSES_ROOT\Excel.Sheet.8\BrowserFlags"
    WshShell.RegWrite regStr, 8, "REG_DWORD"

    regStr = "HKEY_LOCAL_MACHINE\SOFTWARE\Classes\Excel.Sheet.8\BrowserFlags"
    WshShell.RegWrite regStr, 8, "REG_DWORD"

    Err.Clear

End Function

内容は、

『「OS」と「Excel」のバージョンを判定し、OKだったら、レジストリを修正』

というものです。

今日はとりあえず、ソースアップまで。内容説明は、日を改めます。

最近、疲れているのかホームページ更新が遅れ気味。

義務感でやっている訳じゃないから、全然OKだが、週に1つくらいは、書き連ねていきたいな。

ネタがないからなのか、それとも夏バテ気味なのか。。

|

« スーパー芝刈り機 | トップページ | VBScriptでレジストリ操作 その2 (その1の解説編) »

パソコン・インターネット」カテゴリの記事

コメント

コメントを書く



(ウェブ上には掲載しません)


コメントは記事投稿者が公開するまで表示されません。



トラックバック

この記事のトラックバックURL:
http://app.cocolog-nifty.com/t/trackback/538346/57973398

この記事へのトラックバック一覧です: VBScriptでレジストリ操作 その1:

« スーパー芝刈り機 | トップページ | VBScriptでレジストリ操作 その2 (その1の解説編) »