[Résolu][Basic] Lire la base de registre Windows

[rvboni]

Bonjour,

pour mémoire, je cherche à trouver le chemin du browser par défaut pour le passer en paramètre de la commande "Shell" dans un code comme celui-ci:

Code : Tout sélectionner

Sub AideTirages
Dim URL As String
	URL = URLCheminAide & "#mozTocId331465" 'Tirages
	Shell(CheminBrowser,2,URL)
End sub

A force d'essais et d'erreurs j'ai fini par trouver du code qui fonctionne pour lire dans le registre (registry) de Windows.
J'ai copié l'essentiel depuis le module API de la bibliothèque ImportWizard fournie par OpenOffice, avec deux ajouts :
1.

Code : Tout sélectionner

Public Const KEY_QUERY_VALUE = &H1

utilisé comme paramètre dans la fonction "RegOpenKeyEx", au lieu de "KEY_ALL_ACCESS". Je pense que certaines clefs sont protégées en écriture, ce qui expliquerait l'absence de réponse de la fonction dans certains cas ?
2. "Case 2:" dans la fonction "QueryValueEx". La valeur "2" correspond apparemment au type "REG_EXPAND_SZ" que j'ai trouvé dans mon registre (nécessaire pour afficher la valeur "DevPath" de la clef "HKEY_LOCAL_MACHINE,SOFTWARE\Wow6432Node\Microsoft\Windows\CurrentVersion").

Le code complet donne ceci :

Code : Tout sélectionner

Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" _
 (ByVal hKey As Long, _
  ByVal lpSubKey As String, _
  ByVal ulOptions As Long, _
  ByVal samDesired As Long, _
  phkResult As Long) As Long

Declare Function RegQueryValueExString Lib "advapi32.dll" Alias "RegQueryValueExA" _
 (ByVal hKey As Long, _
  ByVal lpValueName As String, _
  ByVal lpReserved As Long, _
  lpType As Long, _
  lpData As String, _
  lpcbData As Long) As Long

Declare Function RegQueryValueExLong Lib "advapi32.dll" Alias "RegQueryValueExA" _
 (ByVal hKey As Long, _
  ByVal lpValueName As String, _
  ByVal lpReserved As Long, _
  lpType As Long, _
  lpData As Long, _
  lpcbData As Long) As Long

Declare Function RegQueryValueExNULL Lib "advapi32.dll" Alias "RegQueryValueExA" _
 (ByVal hKey As Long, _
  ByVal lpValueName As String, _
  ByVal lpReserved As Long, _
  lpType As Long, _
  ByVal lpData As Long, _
  lpcbData As Long) As Long

Declare Function RegCloseKeyA Lib "advapi32.dll" Alias "RegCloseKey" _
 (ByVal hKey As Long) As Long

Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_USERS = &H80000003

Public Const KEY_QUERY_VALUE = &H1
Public Const KEY_ALL_ACCESS = &H3F

Public Const REG_OPTION_NON_VOLATILE = 0
Public Const REG_SZ As Long = 1
Public Const REG_DWORD As Long = 4
Public Const ERROR_NONE = 0
Public Const ERROR_BADDB = 1
Public Const ERROR_BADKEY = 2
Public Const ERROR_CANTOPEN = 3
Public Const ERROR_CANTREAD = 4
Public Const ERROR_CANTWRITE = 5
Public Const ERROR_OUTOFMEMORY = 6
Public Const ERROR_INVALID_PARAMETER = 7
Public Const ERROR_ACCESS_DENIED = 8
Public Const ERROR_INVALID_PARAMETERS = 87
Public Const ERROR_NO_MORE_ITEMS = 259
'Public Const KEY_READ = &H20019

Function OpenRegKey(lBaseKey As Long, sKeyName As String) As Variant
Dim LocKeyValue
Dim hKey as Long
Dim lRetValue as Long
	lRetValue = RegOpenKeyEx(lBaseKey, sKeyName, 0, KEY_QUERY_VALUE, hKey)
	MsgBox "hKey " & hKey & " lRetValue " & lRetValue
'	lRetValue = QueryValue(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Outlook Express\5.0\Default Settings", "Revocation Checking")
	If hKey <> 0 Then
	    RegCloseKeyA (hKey)
	End If
	OpenRegKey() = lRetValue
End Function

Function QueryValueEx(ByVal lhKey, ByVal szValueName As String, vValue As String) As Long
Dim cch As Long
Dim lrc As Long
Dim lType As Long
Dim lValue As Long
Dim sValue As String
Dim Empty

    On Error GoTo QueryValueExError

    lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch)
    MsgBox "lrc " & lrc & " ltype " & ltype & " cch " & cch 
    If lrc <> ERROR_NONE Then Error 5
    Select Case lType
        Case REG_SZ:
            sValue = String(cch, 0)
            lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, sValue, cch)
            MsgBox "REG_SZ, lrc " & lrc & " ltype " & ltype & " cch " & cch 
            If lrc = ERROR_NONE Then
                vValue = Left$(sValue, cch)
            Else
                vValue = Empty
            End If
        Case 2:
            sValue = String(cch, 0)
            lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, sValue, cch)
            MsgBox "REG_EXPAND_SZ, lrc " & lrc & " ltype " & ltype & " cch " & cch 
            If lrc = ERROR_NONE Then
                vValue = Left$(sValue, cch)
            Else
                vValue = Empty
            End If
        Case REG_DWORD:
            lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, lValue, cch)
            If lrc = ERROR_NONE Then
                vValue = lValue
            End If
        Case Else
            lrc = -1
    End Select
QueryValueExExit:
    QueryValueEx = lrc
    Exit Function
QueryValueExError:
    Resume QueryValueExExit
End Function

Function QueryValue(BaseKey As Long, sKeyName As String, sValueName As String) As Variant
Dim lRetVal As Long         ' Returnvalue API-Call
Dim hKey As Long            ' Onen key handle
Dim vValue As String        ' Key value

    lRetVal = RegOpenKeyEx(BaseKey, sKeyName, 0, KEY_QUERY_VALUE, hKey)
    MsgBox "hKey " & hKey & " lRetVal " & lRetVal
    lRetVal = QueryValueEx(hKey, sValueName, vValue)
    RegCloseKeyA (hKey)
    QueryValue = vValue
End Function

Sub VersionValue
Dim sVersion as String, Ret As Long
sVersion = QueryValue(HKEY_LOCAL_MACHINE, "SOFTWARE\Wow6432Node\Microsoft\Windows\CurrentVersion","DevicePath")
MsgBox "DevPath " & sVersion
End Sub

Sub DefaultBrowser
        Dim chemin as String, ret as long
        chemin = QueryValue(HKEY_LOCAL_MACHINE,"Software\Classes\http\shell\open\command","")
rem        chemin = QueryValue(HKEY_CLASSES_ROOT,"http\shell\open\command","")  ' fonctionne également
        MsgBox "Browser : " & chemin
End Sub

La macro "VersionValue" affiche correctement la valeur "DevicePath". Je n'ai pas trouvé dans mon registre pour la clef correspondant la valeur "Version" du système.

la macro "DefaultBrowser" affiche correctement le chemin du browser par défaut. A noter, toutefois, qu'il y a probablement d'autres clefs susceptibles de fournir l'information. A noter, également, que la mise à jour de la clef n'a pas l'air immédiate (j'ai changé plusieurs fois de browser par défaut sur mon ordinateur), mais au moins je suis sûr que le browser renvoyé existe sur ma machine. Je n'ai donc peut-être pas trouvé la clef optimale ?

A voir en complément :
http://support.microsoft.com/kb/145679/fr
http://superuser.com/questions/287313/w ... lt-browser

Ce post fait suite aux posts :
https://forum.openoffice.org/fr/forum/v ... f=8&t=1941
https://forum.openoffice.org/fr/forum/v ... =3&t=41410

Cordialement

[bm92]

Bonjour,
Le Windows Script Host fournit l'objet WshShell qui simplifie l'accès à divers rouages de Windows. Dans sa doc de référence on trouve la méthode RegRead pour lire un élément de registre. Le WSH est accessible depuis OpenOffice. Microsoft donne des exemples en VBScript, en général transposables en OpenOffice Basic.

L'extension donne un pointeur vers l'application liée. Ensuite l'application donne la manière de l'appeler avec un argument.

Code : Tout sélectionner

Dim wsh As Object
Dim Key As String, appli As String, cmdAppli As String

wsh = CreateObject("WScript.Shell")
Key = "HKCR\.html\"  ' extension à rechercher
appli = wsh.RegRead(Key) ' nom de l'appli appelée
if Len(appli) > 0  then
  Key = "HKCR\" & appli & "\shell\open\command\"
  cmdAppli = wsh.RegRead(Key)
  MsgBox(cmdAppli, 0, "Comment lancer xxx.html")
else
  MsgBox("Pas d'application liée")
end if

[rvboni]

Bonjour,

merci Bernard, c'est effectivement beaucoup plus simple (et donc très bien Résolu ).

Je ne connaissais pas le Windows Script Host, merci pour les références.

Cordialement