** CE CODE SERV A KOI ???? **

cs_Heny Messages postés 125 Date d'inscription samedi 25 octobre 2003 Statut Membre Dernière intervention 19 avril 2007 - 30 juin 2004 à 15:57
cs_ITALIA Messages postés 2169 Date d'inscription vendredi 20 avril 2001 Statut Membre Dernière intervention 30 juin 2009 - 30 juin 2004 à 16:50
Salut
Ce code qui est entre
Public Sub StartSysInfo()
et
END SUB
et celui qui est juste apres la declaration pour la connection a ADODB

Option Explicit

Dim connectionADO As New ADODB.Connection ' Connection base de données
Dim commandeADO As New ADODB.Command ' Commande base de données
Dim resultatADO As New ADODB.Recordset ' Résultat de la commande

' Options de sécurité des clés de base de registres...
Const READ_CONTROL = &H20000
Const KEY_QUERY_VALUE = &H1
Const KEY_SET_VALUE = &H2
Const KEY_CREATE_SUB_KEY = &H4
Const KEY_ENUMERATE_SUB_KEYS = &H8
Const KEY_NOTIFY = &H10
Const KEY_CREATE_LINK = &H20
Const KEY_ALL_ACCESS = KEY_QUERY_VALUE + KEY_SET_VALUE + _
KEY_CREATE_SUB_KEY + KEY_ENUMERATE_SUB_KEYS + _
KEY_NOTIFY + KEY_CREATE_LINK + READ_CONTROL

' Types racines des clés de base de registres...
Const HKEY_LOCAL_MACHINE = &H80000002
Const ERROR_SUCCESS = 0
Const REG_SZ = 1 ' Chaîne terminée par un caractère nul Unicode.
Const REG_DWORD = 4 ' Nombre 32 bits.

Const gREGKEYSYSINFOLOC = "SOFTWARE\Microsoft\Shared Tools Location"
Const gREGVALSYSINFOLOC = "MSINFO"
Const gREGKEYSYSINFO = "SOFTWARE\Microsoft\Shared Tools\MSINFO"
Const gREGVALSYSINFO = "PATH"

Public SwitchVal As Boolean

Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, ByRef phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, ByVal lpData As String, ByRef lpcbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long

Private Sub cmdSysInfo_Click()
Call StartSysInfo
End Sub

Private Sub CmdExit_Click()
Dim Cancel As String
Dim cl$, MSG, Style, Title, Help, Ctxt, Response, MyString
cl$ = Chr$(13) + Chr$(10)
MSG = "Voulez vous vraiment quitter?" ' Définit le message.
Style = vbYesNo + vbInformation + vbDefaultButton1 ' Définit les boutons.
Title = "Fermeture de l'application" ' Définit le titre.
Response = MsgBox(MSG, Style, Title, Help, Ctxt)
If Response = vbYes Then ' L'utilisateur a choisi Oui.
MyString = "Oui" ' Effectue une action.

End
Else ' L'utilisateur a choisi Non.
MyString = "load" ' Effectue une action.
Cancel = 1
End If
End Sub

Private Sub cmdOK_Click()

'Condition du chargement

If Option1.Value = True Then

'Affichage feuille principale
Form1.Show
'Désactivation feuille "about"
frmAbout.Visible = False

ElseIf Option2.Value = True Then

'Affichage feuille principale
Form2.Show
'Désactivation feuille "about"
frmAbout.Visible = False

ElseIf Option3.Value = True Then

'Affichage feuille principale
Gest.Show
'Désactivation feuille "about"
frmAbout.Visible = False

End If


End Sub

Public Sub StartSysInfo()
On Error GoTo SysInfoErr

Dim rc As Long
Dim SysInfoPath As String

' Essaie d'obtenir le chemin et le nom du programme Infos système dans la base de registre...
If GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEYSYSINFO, gREGVALSYSINFO, SysInfoPath) Then
' Essaie d'obtenir uniquement le chemin du programme Infos système dans la base de registre...
ElseIf GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEYSYSINFOLOC, gREGVALSYSINFOLOC, SysInfoPath) Then
' Valide l'existence de la version du fichier 32 bits connu.
If (Dir(SysInfoPath & "\MSINFO32.EXE") <> "") Then
SysInfoPath = SysInfoPath & "\MSINFO32.EXE"

' Erreur - Impossible de trouver le fichier...
Else
GoTo SysInfoErr
End If
' Erreur - Impossible de trouver l'entrée de la base de registre...
Else
GoTo SysInfoErr
End If

Call Shell(SysInfoPath, vbNormalFocus)

Exit Sub
SysInfoErr:
MsgBox "Les informations système ne sont pas disponibles actuellement", vbOKOnly
End Sub

Public Function GetKeyValue(KeyRoot As Long, KeyName As String, SubKeyRef As String, ByRef KeyVal As String) As Boolean
Dim I As Long ' Compteur de boucle.
Dim rc As Long ' Code de retour.
Dim hKey As Long ' Descripteur d'une clé de base de registres ouverte.
Dim hDepth As Long '
Dim KeyValType As Long ' Type de données d'une clé de base de registres.
Dim tmpVal As String ' Stockage temporaire pour une valeur de clé de base de registres.
Dim KeyValSize As Long ' Taille de la variable de la clé de base de registres.
'------------------------------------------------------------
' Ouvre la clé de base de registres sous la racine clé {HKEY_LOCAL_MACHINE...}.
'------------------------------------------------------------
rc = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_ALL_ACCESS, hKey) ' Ouvre la clé de base de registres.

If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError ' Gère l'erreur...

tmpVal = String$(1024, 0) ' Alloue de l'espace pour la variable.
KeyValSize = 1024 ' Définit la taille de la variable.

'------------------------------------------------------------
' Extrait la valeur de la clé de base de registres...
'------------------------------------------------------------
rc = RegQueryValueEx(hKey, SubKeyRef, 0, _
KeyValType, tmpVal, KeyValSize) ' Obtient/Crée la valeur de la clé.

If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError ' Gère l'erreur.

If (Asc(Mid(tmpVal, KeyValSize, 1)) = 0) Then ' Win95 ajoute une chaîne terminée par un caractère nul...
tmpVal = Left(tmpVal, KeyValSize - 1) ' Caractère nul trouvé, extrait de la chaîne.
Else ' WinNT ne termine pas la chaîne par un caractère nul...
tmpVal = Left(tmpVal, KeyValSize) ' Caractère nul non trouvé, extrait la chaîne uniquement.
End If
'------------------------------------------------------------
' Détermine le type de valeur de la clé pour la conversion...
'------------------------------------------------------------
Select Case KeyValType ' Recherche les types de données...
Case REG_SZ ' Type de données chaîne de la clé de la base de registres.
KeyVal = tmpVal ' Copie la valeur de la chaîne.
Case REG_DWORD ' Type de données double mot de la clé de base de registres.
For I = Len(tmpVal) To 1 Step -1 ' Convertit chaque bit.
KeyVal = KeyVal + Hex(Asc(Mid(tmpVal, I, 1))) ' Construit la valeur caractère par caractère.
Next
KeyVal = Format$("&h" + KeyVal) ' Convertit le mot double en chaîne.
End Select

GetKeyValue = True ' Retour avec succès.
rc = RegCloseKey(hKey) ' Ferme la clé de base de registres
Exit Function ' Quitte.

GetKeyError: ' Réinitialise après qu'une erreur s'est produite...
KeyVal = "" ' Affecte une chaîne vide à la valeur de retour.
GetKeyValue = False ' Retour avec échec.
rc = RegCloseKey(hKey) ' Ferme la clé de base de registres.
End Function

Private Sub Form_Load()

'On cache le label
Label5.Visible = False

'Désactivation du bouton 'OK'
cmdOK.Visible = False
CmdExit.Visible = False
End Sub
Private Sub Option1_Click()

'Activation du label5 chargement
Label5.Visible = True

'Définition du temps
Timer1.Interval = 400

'Définition du temps
Timer2.Interval = 2000

'Désactivation des boutons options
Option2.Enabled = False
Option3.Enabled = False

End Sub

Private Sub Option2_Click()
'Activation du label5 chargement
Label5.Visible = True

'Définition du temps
Timer1.Interval = 400

'Définition du temps
Timer2.Interval = 2000

'Désactivation des boutons options
Option1.Enabled = False
Option3.Enabled = False

End Sub

Private Sub Option3_Click()
'Activation du label5 chargement
Label5.Visible = True

'Définition du temps
Timer1.Interval = 400

'Définition du temps
Timer2.Interval = 2000

'Désactivation des boutons options
Option1.Enabled = False
Option2.Enabled = False

End Sub

Private Sub Timer1_Timer()
If ChangeDeTexte(SwitchVal) = True Then
Label5.Caption = "Chargement de la base en cours . . ."
Else
Label5.Caption = ""
End If
End Sub

Public Function ChangeDeTexte(Switch As Boolean) As Boolean
Select Case Switch
Case True
ChangeDeTexte = True
SwitchVal = False
Case False
ChangeDeTexte = False
SwitchVal = True
End Select
End Function

Private Sub Timer2_Timer()

'Condition

If Timer2.Interval = 2000 Then

'Préchargement de la base terminée
Timer1.Interval = 0
cmdOK.Visible = True
CmdExit.Visible = True
Label5.Caption = ""
End If

End Sub

MERCI DE ME REPONDRE

1 réponse

cs_ITALIA Messages postés 2169 Date d'inscription vendredi 20 avril 2001 Statut Membre Dernière intervention 30 juin 2009 9
30 juin 2004 à 16:50
Ce code vous permet de créer une routine DE FEUILLE About 'A propos de...).

Cette feuille "About" permet à l'utilisateur d'ouvrir une feuille Windows qui le renseigne sur les caractéristiques de sa machine.

It@li@
0