Source / Exemple :
Option Explicit
'//****************************************//
'// Copyright Visual-Basic 5.0 - Patrick CARLIER
'// http://www.Chez.com/pitrack1
'// pitrack1@club-internet.fr
'// Code élaboré en Visual-Basic 5.0
'//**************************************//
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Private Sub Form_Load()
Dim lngC2ITimer As Long
lngC2ITimer = timeGetTime
MakeForm2 Me, picInvisible
Debug.Print "Temps d'exécution : " + CStr(timeGetTime - lngC2ITimer)
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
MoveForm Me
End Sub
Private Sub Label1_Click()
frmAbout.Show
End Sub
Private Sub CEsc_Click()
Unload Me
End Sub
Private Sub COk_Click()
If OptArret.Value = True Then
ExitWindowsEx EWX_SHUTDOWN, 0&
ElseIf OPtDemarre.Value = True Then
ExitWindowsEx EWX_REBOOT, 0&
ElseIf OptMsDos.Value = True Then
Else
ExitWindowsEx EWX_LOGOFF, 0&
End If
Unload Me
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
ExitWindows.Show
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
Option Explicit
'//****************************************//
'// Copyright Visual-Basic 5.0 - Patrick CARLIER
'// http://www.Chez.com/pitrack1
'// pitrack1@club-internet.fr
'// Code élaboré Visual-Basic 5.0
'//**************************************//
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Const RGN_OR = 2
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Sub ReleaseCapture Lib "user32" ()
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Long) As Long
Public Function MakeForm(frm As Form, pic As PictureBox)
Dim iX As Long, iY As Long
Dim hRgn As Long, hRgnTemp As Long
Dim lngDummy As Long
frm.Width = frm.ScaleX(pic.Width, vbPixels, vbTwips)
frm.Height = frm.ScaleY(pic.Height, vbPixels, vbTwips)
DoEvents
For iX = 0 To pic.ScaleWidth
For iY = 0 To pic.ScaleHeight
If pic.Point(iX, iY) <> vbWhite Then
If hRgn = 0 Then
hRgn = CreateRectRgn(iX, iY, iX + 1, iY + 1)
Else
hRgnTemp = CreateRectRgn(iX, iY, iX + 1, iY + 1)
lngDummy = CombineRgn(hRgn, hRgn, hRgnTemp, RGN_OR)
DeleteObject hRgnTemp
End If
End If
Next
Next
Dim lngTH As Long, lngB As Long
lngDummy = SetWindowRgn(frm.hwnd, hRgn, True)
DoEvents
lngDummy = DeleteObject(hRgn)
End Function
Public Function MakeForm2(frm As Form, pic As PictureBox)
Dim iX As Long, iY As Long
Dim iiX As Long, iiY As Long
Dim iiiX As Long, iiiY As Long
Dim hRgn As Long, hRgnTemp As Long
Dim lngDummy As Long
Dim Stat As Boolean
frm.Width = frm.ScaleX(pic.Width, vbPixels, vbTwips)
frm.Height = frm.ScaleY(pic.Height, vbPixels, vbTwips)
DoEvents
Stat = False
For iX = 0 To pic.ScaleWidth
Stat = False
For iY = 0 To pic.ScaleHeight
Select Case Stat
Case False
If pic.Point(iX, iY) <> vbWhite Then
iiX = iX
iiY = iY
iiiX = iX
iiiY = iY
Stat = True
End If
Case True
If pic.Point(iX, iY) = vbWhite Then
iiiX = iX
iiiY = iY
If hRgn = 0 Then
hRgn = CreateRectRgn(iiX, iiY, iiiX + 1, iiiY)
Else
hRgnTemp = CreateRectRgn(iiX, iiY, iiiX + 1, iiiY)
lngDummy = CombineRgn(hRgn, hRgn, hRgnTemp, RGN_OR)
DeleteObject hRgnTemp
End If
Stat = False
End If
End Select
Next
Next
lngDummy = SetWindowRgn(frm.hwnd, hRgn, True)
lngDummy = DeleteObject(hRgn)
End Function
Public Function MoveForm(frm As Form)
ReleaseCapture
SendMessage frm.hwnd, &HA1, 2, 0&
End Function
Option Explicit
Public Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long
' Constantes pour ExitWindowsEx
Public Const EWX_LOGOFF = 0
Public Const EWX_SHUTDOWN = 1
Public Const EWX_REBOOT = 2
Public Const EWX_FORCE = 4
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.