« 2013年7月 | トップページ | 2013年9月 »

2013年8月

2013年8月25日 (日)

VBScriptでレジストリ操作 その2 (その1の解説編)

Function GetOfficeVer(appName)
...
Function GetOSType()
...
Function GetIEVer()
...

については、他でも使える要素が高そうなので、有用かと。

ただし、「Function GetOfficeVer(appName)」については、既に問題が発覚していて、

複数のOfficeバージョンがインストールされており、 旧バージョン側を開くアプリケーションとして登録されている場合

ただしくそれを把握できなかった(らしい)。

直接そのマシン・状況を再現できないので、改良できるか現時点で不明。

なので、複数バージョンの場合は注意して下さい。

あとレジストリ操作のキモである

Function SetBrowserFlag()
...

については、

「On error resume next」を、削除対象のレジストリがない場合でも問題ないように敢えて記述しているところが、

ポイントといえばポイント。 サンプルには、「RegDelete」がないので、有り難みがないですけど。

※この記述がないと、削除対象のレジストリキーが無い場合、エラーとなります。

さて、スクリプト一番のポイントは

Shell.ShellExecute "wscript.exe","""" & WScript.ScriptFullName & """ uac","","runas"

の部分です。

Windows7(Vista)については、ユーザアカウント制御(UAC)が有効となっている場合、

RegDeleteやRegWriteといったコマンドは、本来管理者権限が必要であるのに、単にスクリプトをダブルクリック

しただけでは、ユーザ権限で実行されてしまうため、正しく処理が行えない、という壁があります。

素直に、

・ユーザアカウント制御の設定を「無効」にする

という方法もありますが、

・セキュリティ上問題があるケースが多い

・その操作の為のマニュアルを作成・配布しないといけない

・その操作中に、ユーザが誤操作をする可能性がある

というデメリットがある為、お勧めできない。

(そもそも、そんな方法でOKなら、レジストリを操作するマニュアルを作成・配布すればいい)

ということで、UACを操作することなく、管理者権限で実行させるために使っているのが

「runas」コマンドです。

do while Shell.ShellExecute "wscript.exe","""" & WScript.ScriptFullName & """ uac","","runas"

つまり上記は、管理者権限で、自分自身を、第1引数「uac」をつけて、再起動を行っているコマンドです。

この第1引数「uac」に意味はありません。

大事なのは、「1つ(以上)引数を付けて起動する」という点です。

1つ以上引数を付けて挙動を変えている部分が、

do while WScript.Arguments.Count=0
...
loop

上記の部分です。

この「do...loop」間に書かれたコマンドは、引数がない場合(0個)のみ実行されるという 意味を持っています。

なので、

・初回起動時(エンドユーザがダブルクリック時)は、引数なし(0個)

 →「runas」にて、管理者権限で自分自身を、第1引数「uac」をつけ起動し直して、終了。

・自分自身が自分自身を起動した場合は、第1引数があるので、

 →更なる自分自身の起動は行わず、以降のレジストリ操作部分に突入

 →レジストリ操作が管理者権限で実行される。

 →正しく実行される

という順になります。

一種の権限昇格を行うサンプルということも出来るかも知れません。

| | コメント (0) | トラックバック (0)

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つくらいは、書き連ねていきたいな。

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

| | コメント (0) | トラックバック (0)

« 2013年7月 | トップページ | 2013年9月 »