Trucs et astuces

Soyez le premier à donner votre avis sur cette source.

Vue 38 958 fois - Téléchargée 2 523 fois

Télécharger le projet
Commenter

Description

Une base de donnée sur les trucs et astuces de windows

Source / Exemple : 


Private Sub Command1_Click()
Dim Recherche As String
     Dim Expression As String
     Expression = InputBox("Tapez la première lettre de la rubique a rechercher :", "Recherche d'enregistrement")
     Recherche = "Titre LIKE" & "'" & Expression & "*" & "'"
    Data1.Recordset.FindFirst Recherche
     Do While Not Data1.Recordset.NoMatch
         If MsgBox("Continuer une recherche ?", vbYesNo, "Rechercher") <> vbYes Then Exit Do
         Data1.Recordset.FindNext Recherche
     Loop
     MsgBox "Il n'y a plus d'enregistrement répondant au mot spécifié !", vbOKOnly, "Recherche"
End Sub-

Private Sub Command2_Click()
 'Fin du programme
  M$ = "Voulez-vous vraiment quitter le programme Truc&Astuce ?"
  Réponse% = MsgBox(M$, vbYesNo + vbQuestion, "Quitter Truc&Astuce")
  If Réponse% = vbYes Then
    End
  End If
'Unload Me
End Sub

Private Sub Command3_Click()
' Attribue à CancelError la valeur True
    CommonDialog2.CancelError = True
    On Error GoTo ErrHandler
    ' Définit la propriété Flags
    CommonDialog2.Flags = cdlOFNHideReadOnly
    ' Définit les filtres
    CommonDialog2.Filter = "Bases de donnée" & _
    "(*.mdb)|*.mdb"
    ' Définit le filtre par défaut
    CommonDialog2.FilterIndex = 1
    ' Affiche la boîte de dialogue Ouverture
    CommonDialog2.ShowOpen
    ' Affiche le nom du fichier sélectionné
    MsgBox CommonDialog2.filename
    Exit Sub
    
ErrHandler:
    'L'utilisateur a cliqué sur Annuler
    Exit Sub
End Sub

Private Sub Command4_Click()
Aide.Show
End Sub

Private Sub Data1_Reposition()
  Screen.MousePointer = vbDefault
 On Error Resume Next
  Data1.Caption = "Astuce N°" & (Data1.Recordset.AbsolutePosition + 1)
   End Sub

Option Explicit

' 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 = "SOFTWAREMicrosoftShared Tools Location"
Const gREGVALSYSINFOLOC = "MSINFO"
Const gREGKEYSYSINFO = "SOFTWAREMicrosoftShared ToolsMSINFO"
Const gREGVALSYSINFO = "PATH"

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 cmdOK_Click()
  Unload Me
End Sub

Private Sub Form_Load()
    Me.Caption = "À propos de " & App.Title
    lblVersion.Caption = "Version " & App.Major & "." & App.Minor & "." & App.Revision
    lblTitle.Caption = App.Title
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

Conclusion :


Il suffit juste de laisser la base de donnée dans le meme repertoire que l'exécutable
Télécharger le projet

Codes Sources

A voir également

Ajouter un commentaire

Commentaires

Signaler Commenter la réponse de cs_fring
cs_fring
Messages postés
21
Date d'inscription
mardi 5 juillet 2005
Statut
Membre
Dernière intervention
25 mars 2006
 -
Trop b1 un banc!!! pour toi
Signaler Commenter la réponse de e0091
e0091
Messages postés
30
Date d'inscription
mardi 23 septembre 2003
Statut
Membre
Dernière intervention
29 mars 2007
 -
Salutation j'aimerais que tu m'aide dans mon programme qui a une base de donné. Elle faut qu'elle calcule selon l'expérience que le joueur possède et qu'il veut avoir. Il faut qu'elle affiche le nombre arrondi de ce qu'il y reste à faire selon l'expérience gagné par item.
Signaler Commenter la réponse de zouhair6666
zouhair6666
Messages postés
3
Date d'inscription
lundi 14 juillet 2003
Statut
Membre
Dernière intervention
17 octobre 2003
 -
c'est trés bien ce que t'as fait Mr mais ....
Signaler Commenter la réponse de men
-
je vous filicite des effort que vous faite.
je suis un débutant et j'ai une application à faire qui consiste à donner l'inventaire des pc qui se trouve dans un centre et aussi de faire la gestion des operation de maintenance
j'aimerai bien que vous me donner un coup de main
et merci d'avance
Signaler Commenter la réponse de simo
-
je veux recevoire ces codes dans ma boite
Afficher les 7 commentaires
S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (pitrack)