www.pudn.com > pdng22src.zip > Outils.bas

Attribute VB_Name = "Outils" 
' 
' *************************** 
' Boite à outils générale. 
' *************************** 
' 
Option Explicit 
' 
' 
'Declare Function GetFreeSpace Lib "kernel32" Alias "GetFreeSpaceA" (ByVal flag As Integer) As Long 
' La sub GlobalMemoryStatus (ci-dessous) remplace GetFreeSystemResources dans l'API Win16 
'Declare Sub GlobalMemoryStatus Lib "kernel32" (lpBuffer As MemoryStatus) 
'Declare Function sndPlaySound Lib "winmm" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long 
'Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long 
'Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long 
' 
'Declare Function ReleaseDC Lib "User32" (ByVal hWnd As Long, ByVal hDC As Long) As Long 
'Declare Function GetDesktopWindow Lib "User32" () As Long 
' 
' Registration APIs used to check or delete entry. 
' 
'Declare Function RegOpenKey Lib "Shell32" (ByVal HKeyIn As Long, ByVal LPCSTR As String, HKeyOut As Long) As Long 
'Declare Function RegCloseKey Lib "Shell32" (ByVal HKeyIn As Long) As Long 
'Declare Function RegQueryValue Lib "Shell32" (ByVal HKeyIn As Long, ByVal SubKey As String, ByVal KeyValue As String, KeyValueLen As Long) As Long 
'Declare Function RegSetValue Lib "Shell32" (ByVal HKeyIn As Long, ByVal SubKey As String, ByVal lType As Long, ByVal strNewValue As String, ByVal lIngnored As Long) As Long 
'Declare Sub RegDeleteKey Lib "Shell32" (ByVal HKeyIn As Long, ByVal SubKeyName As String) 
' Appel la boite à propos 
 
 
 
 
' Windows API declares and constants 
 
Public Const GWL_WNDPROC = (-4) 
Public Const WM_ENTERMENULOOP = &H211 
Public Const WM_EXITMENULOOP = &H212 
Public Const WM_SYSCOMMAND = &H112 
 
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long 
Public Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long 
Public Declare Function ScreenToClient Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long 
Public Declare Function ClientToScreen Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long 
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long 
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long 
 
Public Type POINTAPI 
        x As Long 
        y As Long 
End Type 
 
Public oldtime 
 
Const conHwndTopmost = -1 
Const conHwndNoTopmost = -2 
Const conSwpNoActivate = &H10 
Const conSwpShowWindow = &H40 
 
Public Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long 
Public Declare Function ExitWindows Lib "user32" (ByVal dwReserved As Long, ByVal uReturnCode As Long) As Long 
Public stamper 
' 
' ***** Constantes de la boite liste 
' 
Global Const BOITE_CHARGE% = 0 
Global Const BOITE_SAUVE% = 1 
Global Const BOITE_COULEUR% = 2 
Global Const OUVRE_NORMAL% = 0    ' Ouvre le fichier normalement 
Global Const OUVRE_BINAIRE% = 1    ' Ouvre le fichier en binaire 
Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long 
Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long 
Function WinDir$() 
Dim temp$, Wlen& 
  'détermine le dossier Windows 
  temp$ = Space$(255) 
  Wlen& = GetWindowsDirectory(temp$, Len(temp$)) 
  WinDir$ = Left$(temp$, Wlen&) 
End Function 
 
 
Public Sub TwipsToPixel(xValeur%, yValeur%) 
  Dim ux%, uy% 
  ux% = Screen.TwipsPerPixelX 
  xValeur% = xValeur% / ux% 
  uy% = Screen.TwipsPerPixelY 
  yValeur% = yValeur% / uy% 
 
End Sub 
 
 
Public Sub FormatHeure(Ctl As Control, MSec&) 
  'Affichage formaté dans le contrôle spécifié 
  Dim sec%, Min% 
  sec% = MSec& \ 1000 
  Min% = sec% \ 60 
  sec% = sec% - (60 * Min%) 
  Ctl.Caption = Format$(Min%, "#0:") + Format$(sec%, "00") 
  'Actualiser l'affichage 
  Ctl.Refresh 
End Sub 
Public Sub FormatHeuretxt(Ctl As Control, MSec&) 
  'Affichage formaté dans le contrôle spécifié 
  Dim sec%, Min% 
  sec% = MSec& \ 1000 
  Min% = sec% \ 60 
  sec% = sec% - (60 * Min%) 
  Ctl.Text = Format$(Min%, "#0:") + Format$(sec%, "00") 
  'Actualiser l'affichage 
  Ctl.Refresh 
End Sub 
 
 
' 
' ******************************* 
' Ajoute une entrée dans la liste 
' ******************************* 
' 
Sub Ajoute_Entree(liste As Control, a$, n%) 
    If n% + 1 > liste.ListCount Then 
        liste.AddItem "[" + Trim$(Str$(n%)) + "] " + a$ 
    Else 
        liste.RemoveItem n% 
        liste.AddItem "[" + Trim$(Str$(n%)) + "] " + a$, n% 
    End If 
End Sub 
 
' 
' ******************************* 
' Additionne p% à la valeur de n% 
' ******************************* 
' 
Sub AJOUTE(n%, p%) 
    n% = n% + p% 
End Sub 
 
' 
' ******************************** 
' Rempli un tableau avec la valeur 
' ******************************** 
' 
Sub ARRAYFILL(Tableau%(), valeur%) 
    Dim i% 
    For i% = 0 To UBound(Tableau%) 
        Tableau%(i%) = valeur% 
    Next i% 
End Sub 
 
' 
' ******************************** 
' Rempli un tableau avec la valeur 
' ******************************** 
' 
Sub ARRAYFILL2(Tableau%(), valeur%) 
    Dim i%, j% 
    For i% = 0 To UBound(Tableau%, 1) 
        For j% = 0 To UBound(Tableau%, 2) 
            Tableau%(i%, j%) = valeur% 
        Next j% 
    Next i% 
End Sub 
 
' 
' ****************** 
' Centre une fenêtre 
' ****************** 
' 
Sub Centre(f As Form) 
    With f 
        .WindowState = 0 
        .Move (Screen.Width - .Width) / 2, (Screen.Height - .Height) / 2 
    End With 
End Sub 
 
' 
' ************************************************* 
' Recherche du premier et dernier objet de la liste 
' adr% = adresse du tableau 
' z%   = chiffre a rechercher 
' min% = adresse min dans tableau 
' max% = adresse max dans tableau 
' r1%  = variable de retour 1 
' r2%  = variable de retour 2 optionelle 
' ************************************************* 
' 
Sub Cherche(adr%(), z%, Min%, MAX%, r1%, Optional r2%) 
    Dim p1%, p2%, t% 
    If MAX% = -1 Then 
        r1% = -1 
    Else 
        ' 
        ' ***** Recherche d'un z dans le tableau adr% 
        ' 
        p1% = Min% 
        p2% = MAX% 
        Do 
            If adr%(p1%) = z% Then 
                r1% = p1% 
                Exit Do 
            End If 
            If adr%(p2%) = z% Then 
                r1% = p2% 
                Exit Do 
            End If 
            If p1% = p2% Or p1% + 1 = p2% Then 
                r1% = -1 
                Exit Do 
            End If 
            t% = (p1% + p2%) / 2 
            If adr%(t%) > z% Then p1% = t% Else p2% = t% 
        Loop 
        ' 
        ' ***** Fin de recherche du z 
        ' ***** Maintenant on élargie 
        ' 
        If r1% = -1 Then 
            If adr%(p1%) < z% Then 
                r2% = p1% 
            Else 
                If adr%(p2%) > z% Then r2% = p2% + 1 Else r2% = p1% + 1 
            End If 
        Else 
            r2% = r1% 
            t% = -1 
            Do 
                If r1% = Min% Then 
                    t% = 0 
                Else 
                    If adr%(r1% - 1) = z% Then r1% = r1% - 1 Else t% = 0 
                End If 
            Loop Until t% = 0 
            ' 
            t% = -1 
            Do 
                If r2% = MAX% Then 
                    t% = 0 
                Else 
                    If adr%(r2% + 1) = z% Then r2% = r2% + 1 Else t% = 0 
                End If 
            Loop Until t% = 0 
        End If 
    End If 
End Sub 
 
' 
' ******************************* 
' Recherche une place en z% 
' adr% = adresse du tableau 
' z%   = chiffre a rechercher 
' min% = adresse min dans tableau 
' max% = adresse max dans tableau 
' ******************************* 
' 
Function Cherche_P%(adr%(), z%, Min%, MAX%) 
    Dim r1%, r2% 
    Call Cherche(adr%(), z%, Min%, MAX%, r1%, r2%) 
    If r1% = -1 Then Cherche_P% = r2% Else Cherche_P% = r1% 
End Function 
 
' 
' ************ 
' Décrémente a 
' ************ 
' 
Sub DEC(a As Variant) 
    a = a - 1 
End Sub 
 
' 
' ************************************** 
' Enlève un élément du tableau caractère 
'*************************************** 
' 
Sub Enleve_Chaine(Tableau$(), ByVal Position%) 
    Dim i%, t% 
    t% = UBound(Tableau$) 
    For i% = Position% To t% - 1 
        Tableau$(i%) = Tableau$(i% + 1) 
    Next i% 
    Tableau$(t%) = "" 
End Sub 
 
' 
' ************************************ 
' Enlève un élément du tableau chiffre 
' ************************************ 
' 
Sub Enleve_Entier(Tableau%(), Position%) 
    Dim i%, t% 
    t% = UBound(Tableau%) 
    For i% = Position% To t% - 1 
        Tableau%(i%) = Tableau%(i% + 1) 
    Next i% 
    Tableau%(t%) = 0 
End Sub 
 
' 
' ********************************************** 
' Recherche l'existance du dossier et du fichier 
' ********************************************** 
' 
Function EXISTE(Fichier$) As Boolean 
    Dim f% 
    On Error GoTo rate 
    f% = FreeFile() 
    Open Fichier$ For Input As #f% 
    Close #f% 
    EXISTE = True 
    On Error GoTo 0 
    Exit Function 
rate: 
    Close #f% 
    EXISTE = False 
    On Error GoTo 0 
End Function 
 
' 
' ************ 
' Incrémente a 
' ************ 
' 
Sub INC(a As Variant) 
    a = a + 1 
End Sub 
 
' 
' ********************************* 
' Insere une valeur dans un tableau 
' ********************************* 
' 
Sub Insere_Chaine(Tableau$(), ByVal valeur$, ByVal Position%) 
    Dim i%, t% 
    t% = UBound(Tableau$) 
    If Position% <> t% Then 
        For i% = t% To Position% + 1 Step -1 
            Tableau$(i%) = Tableau$(i% - 1) 
        Next i% 
    End If 
    Tableau$(Position%) = valeur$ 
End Sub 
 
' 
' ********************************* 
' Insere une valeur dans un tableau 
' ********************************* 
' 
Sub Insere_Entier(Tableau%(), ByVal valeur%, ByVal Position%) 
    Dim i%, t% 
    t% = UBound(Tableau%()) 
    If Position% <> t% Then 
        For i% = t% To Position% + 1 Step -1 
            Tableau%(i%) = Tableau%(i% - 1) 
        Next i% 
    End If 
    Tableau%(Position%) = valeur% 
End Sub 
 
' 
' ***************************************** 
' Retourne la valeur maximum entre a% et b% 
' ***************************************** 
' 
Function MAX%(a%, b%) 
    If a% > b% Then MAX% = a% Else MAX% = b% 
End Function 
 
' 
' ***************************************** 
' Retourne la valeur minimum entre a% et b% 
' ***************************************** 
' 
Function Min%(ByVal a%, ByVal b%) 
    If a% < b% Then Min% = a% Else Min% = b% 
End Function 
 
' 
' ********************** 
' Ouverture d'un fichier 
' ********************** 
' 
Sub Ouvre(Nom$, f%, mode%) 
    Dim r% 
    Do While EXISTE(Nom$) = False 
        If MsgBox("Le fichier " + Nom$ + vbCr + "n'existe pas...", vbQuestion + vbRetryCancel) = vbCancel Then 
            End 
        End If 
    Loop 
    If mode% = OUVRE_BINAIRE% Then 
        Open Nom$ For Binary As #f% Len = 4096 
    Else 
        Open Nom$ For Input As #f% Len = 512 
    End If 
End Sub 
 
' 
' *********************************** 
' Ouvre la boite sélécteur de fichier 
' et réduit le chemin en relatif 
' *********************************** 
' 
Function Ouvre_Boite$(Titre$, Nom$, Filtre$, Libelle$, Ouvre%, Boite As CommonDialog, Optional Dossier$) 
    Dim d$ ' On doit le sauvegarder car la boite modifie cette valeur 
    Dim Fichier$ 
    d$ = CurDir 
    With Boite 
        .DialogTitle = Titre$ 
        If Libelle$ <> "" Then 
            .Filter = Libelle$ + "|" + Filtre$ 
        Else 
            .Filter = "Tous les fichiers " + Filtre$ + "|" + Filtre$ 
        End If 
        .FileName = Nom$ 
        Select Case Ouvre% 
        Case BOITE_CHARGE% 
            .ShowOpen 
        Case BOITE_SAUVE% 
            .ShowSave 
        Case BOITE_COULEUR% 
            .ShowColor 
        End Select 
        Dossier = CurDir 
        ChDir d$ 
        Fichier$ = .FileName 
    End With 
    If Left$(Fichier$, Len(d$)) = d$ Then 
        Ouvre_Boite$ = "." + Right$(Fichier$, Len(Fichier$) - Len(d$)) 
    Else 
        Ouvre_Boite$ = Fichier$ 
    End If 
End Function 
 
' 
' ************** 
' Retire b% à a% 
' ************** 
' 
Sub RETIRE(a%, b%) 
    a% = a% - b% 
End Sub 
 
' 
' ********************************************* 
' Retourne la chaine de commande sans les côtes 
' ********************************************* 
' 
Function Retourne_Commande$() 
    Dim i% 
    Retourne_Commande$ = "" 
    For i% = 1 To Len(Command$) 
        If Mid$(Command$, i%, 1) <> Chr$(34) Then 
            Retourne_Commande$ = Retourne_Commande$ + Mid$(Command$, i%, 1) 
        End If 
    Next i% 
End Function 
 
' 
' ****************** 
' Echange x% avec y% 
' ****************** 
' 
Sub SWAP(x%, y%) 
    Dim z% 
    z% = x% 
    x% = y% 
    y% = z% 
End Sub