Attribute VB_Name = "TOOLS" 'History ' 16/08/00 Y.M. Added PlaySound Option Explicit Dim Rstring As String * 1024 Global Manquants As String Global GereManque As Boolean Global DureeMsg As Integer Global NivTrace As Integer Global FicTrace As String Global F_INI As String Global INIFILE As String Public Const HFILE_ERROR = -1 Dim S As String Dim Chronos(10) As Long Global Pass As Boolean Private Type LUID UsedPart As Long IgnoredForNowHigh32BitPart As Long End Type Private Type TOKEN_PRIVILEGES PrivilegeCount As Long TheLuid As LUID Attributes As Long End Type Private Const EWX_SHUTDOWN As Long = 1 Private Const EWX_FORCE As Long = 4 Private Const EWX_REBOOT = 2 Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Declare Function ExitWindowsEx Lib "User32" ( _ ByVal dwOptions As Long, ByVal dwReserved As Long) As Long Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long Declare Function GetHandleInformation Lib "kernel32" (ByVal hObject As Long, lpdwFlags As Long) As Boolean Declare Function GetTickCount Lib "kernel32" () As Long Declare Function GetActiveWindow Lib "kernel32" () As Integer 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 WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal SName As String, KName As Any, SString As Any, ByVal FName As String) As Integer Declare Function GetProfileString Lib "kernel32" (ByVal lpAppName As String, lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Integer) As Integer Declare Function lopen Lib "kernel32" Alias "_lopen" (ByVal lpPathName As String, ByVal iReadWrite As Long) As Long Declare Function lread Lib "kernel32" Alias "_lread" (ByVal hFile As Long, lpBuffer As Any, ByVal wBytes As Long) As Long Declare Function lclose Lib "kernel32" Alias "_lclose" (ByVal hFile As Long) As Long Declare Function hread Lib "kernel32" Alias "_hread" (ByVal hFile As Long, lpBuffer As Any, ByVal lBytes As Long) As Long Declare Function LocalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal wBytes As Long) As Long Declare Function LocalFree Lib "kernel32" (ByVal hMem As Long) As Long Declare Function GetProcessVersion Lib "kernel32" (ByVal hModule As Long) As Long Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Single) As Long Declare Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long Declare Function PostMessage Lib "User32" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParams As Long, ByVal lParam As Long) As Long Declare Function IsWindow Lib "User32" (ByVal hWnd As Long) As Long Declare Function GetCurrentProcess Lib "kernel32" () As Long Declare Function OpenProcessToken Lib "advapi32" ( _ ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, _ TokenHandle As Long) As Long Declare Function LookupPrivilegeValue Lib "advapi32" _ Alias "LookupPrivilegeValueA" (ByVal lpSystemName As String, _ ByVal lpName As String, lpLuid As LUID) As Long Declare Function AdjustTokenPrivileges Lib "advapi32" ( _ ByVal TokenHandle As Long, ByVal DisableAllPrivileges As Long, _ NewState As TOKEN_PRIVILEGES, ByVal BufferLength As Long, _ PreviousState As TOKEN_PRIVILEGES, ReturnLength As Long) As Long Public Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long Public Const SND_ASYNC = &H1 ' play asynchronously Type RingBuffer B As String * 32000 Nb As Long Wp As Long Rp As Long End Type Sub ForceLignes(Fichier As String, MaxLignes As Integer, NbLignes As Integer) ' Si plus de MaxLignes, ne garde que les Nblignes dernières lignes du fichier texte Dim Fs As Integer Dim Fo As Integer Dim L As String Dim I As Integer Dim Temp As String If Not FileExists(Fichier) Then Exit Sub If MaxLignes <= NbLignes Then MaxLignes = NbLignes * 2 Fs = FreeFile Open Fichier For Input As Fs Do While Not EOF(Fs) Line Input #Fs, L I = I + 1 'Compte les lignes Loop If I > MaxLignes Then Seek #Fs, 1 'Rewind I = I - NbLignes 'Nombre de lignes à supprimer For NbLignes = 1 To I Line Input #Fs, L Next NbLignes Fo = FreeFile Temp = App.Path & "\" & Format(Now, "ddhhmmss") & "." & Format(Fo, "000") Open Temp For Output As Fo Do While Not EOF(Fs) Line Input #Fs, L Print #Fo, L Loop Close Fs Close Fo Kill Fichier Name Temp As Fichier Else Close Fs End If End Sub Function WriteRb(RB As RingBuffer, C As String) As Long ' Ecrit un caractère dans buffer. ' Retourne le nombre de caractères en attente ou 0 si buffer plein With RB If .Nb < 32000 Then .Nb = .Nb + 1 If .Wp > 32000 Then .Wp = 0 .Wp = .Wp + 1 Mid(.B, .Wp, 1) = C WriteRb = .Nb End If End With End Function Function ReadRb(RB As RingBuffer, N As Integer) As String 'Retourne les N caractères suivants du buffer Dim NN As Integer With RB If N > .Nb Then N = .Nb If .Nb Then .Nb = .Nb - N If .Rp + N > 32000 Then 'On va wrapper avant NN = 32000 - .Rp ReadRb = Mid(.B, .Rp, NN) .Rp = 1 End If N = N - NN ReadRb = ReadRb & Mid(.B, .Rp, N) .Rp = .Rp + N End If End With End Function Function ShowRb(RB As RingBuffer, N As Integer) As String 'Montre les N caractères suivants du buffer sans les retirer Dim Tp As Long 'Pointeur temporaire With RB If N > .Nb Then N = .Nb If .Nb Then Tp = .Rp Do While N > 0 If Tp > 32000 Then Tp = 0 Tp = Tp + 1 ShowRb = ShowRb & Mid(.B, Tp, 1) N = N - 1 Loop End If End With End Function Sub ClearRb(RB As RingBuffer) 'Réinitialse le buffer With RB .Nb = 0 .Wp = 1 .Rp = 1 End With End Sub Sub OpenSection(section As String) S = "[" & UCase(Trim$(section)) & "]" & Chr$(13) & Chr$(10) End Sub Sub AddKey(key As String, Value As String) S = S & Trim$(key) & "=" & Trim$(Value) & Chr$(13) & Chr$(10) End Sub Sub CloseSection(FicNum As Integer) Print #FicNum, S End Sub Function GetFname(FullPath As String) As String 'Retourne le nom du fichier sans le chemin Dim I As Integer Dim J As Integer Dim Sep As String Sep = "\" 'Assume Windows style If InStr(FullPath, "/") Then Sep = "/" 'Set Unix style Do J = InStr(I + 1, FullPath, Sep) If J = 0 Then Exit Do I = J Loop GetFname = Right$(FullPath, Len(FullPath) - I) End Function Function GetParams(section As String, Cle As String) As String Dim S As String Dim Substitute As String S = GetIniString(F_INI, section, Cle) If Len(S) Then GetParams = S Substitute = GetIniString(F_INI, "DEFINE", S) If Len(Substitute) Then GetParams = Substitute Else GetParams = GetIniString(F_INI, "DEFAUT", Cle) End If End Function Function Get_Start_Params() As String Dim S As String Dim P As String S = LCase$(Command$) If Len(S) = 0 Then S = InputBox$("Entrer les parametres", "Pas de parametres") If Len(S) = 0 Then End End If INIFILE = Substring(S, 1, " ") P = GetPath(INIFILE) If InStr(P, ".") = 1 Then INIFILE = App.Path & Mid$(INIFILE, 2) If Len(P) = 0 Then INIFILE = App.Path & "\" & INIFILE Get_Start_Params = S End Function Sub Set_StartParams() Dim S As String S = Command$ If Len(S) Then INIFILE = Substring(S, 1, " ") Exit Sub 'utilise 1er paramètre ligne commande End If INIFILE = App.Path & "\" & App.EXEName & ".INI" 'utilise fichier par défaut End Sub Function GetIniString(Fichier As String, section As String, Cle As String) As String Dim S As String Dim X As Integer If Not FileExists(Fichier) Then Exit Function X = GetPrivateProfileString(ByVal section, ByVal Cle, ByVal "", ByVal Rstring, ByVal Len(Rstring), ByVal Fichier) S = Left$(Rstring, X) If InStr(S, "'") = 1 Then S = Right$(S, Len(S) - 1) GetIniString = S End Function Function GetSystemString(SName As String, section As String, Cle As String) As String Dim Rstring As String Dim X As Integer Rstring = String$(256, 0) X = GetPrivateProfileString(ByVal section, ByVal Cle, ByVal "", ByVal Rstring, ByVal Len(Rstring), ByVal SName) GetSystemString = Left$(Rstring, X) End Function Sub SetTrace() NivTrace = 0 FicTrace = GetIniString(INIFILE, "DEBUG", "Trace") If Len(FicTrace) Then If GetPath(FicTrace) = "." Or Len(GetPath(FicTrace)) = 0 Then FicTrace = App.Path & "\" & GetFname(FicTrace) End If NivTrace = Val(GetIniString(INIFILE, "DEBUG", "Niveau")) End If End Sub Function GetPath(FullPath As String) As String 'Retourne le chemin sans le nom du fichier Dim I As Integer Dim J As Integer Dim Sep As String GetPath = "" If Len(FullPath) Then If InStr(FullPath, "/") Then Sep = "/" 'Set Unix style ElseIf InStr(FullPath, "\") Then Sep = "\" 'May be Windows style Else Exit Function 'None, nothing to return End If Do J = InStr(I + 1, FullPath, Sep) If J = 0 Then Exit Do I = J Loop GetPath = Left$(FullPath, I - 1) End If End Function Function GetExtension(Fichier As String) As String 'Retourne l'extension de fichier (sans le point !) GetExtension = Substring(GetFname(Fichier), 2, ".") End Function Function Substring(Texte As String, Item As Integer, Separateur As String) As String Dim D As Integer Dim F As Integer Dim I As Integer D = 1 I = 1 Do F = InStr(D, Texte, Separateur) If F = 0 Then F = Len(Texte) + 1 If I = Item Then Exit Do I = I + 1 D = F + Len(Separateur) If D > Len(Texte) Then Substring = "" Exit Function End If Loop Substring = Mid$(Texte, D, F - D) ' If Len(Substring) = 0 Then Substring = " " End Function Function SubStringVal(Texte As String, Item As Integer, Separateur As String) As Integer SubStringVal = Val(Substring(Texte, Item, Separateur)) End Function Sub Trace(Niveau As Integer, Message As String) Dim I As Integer Dim F As Integer Dim C As String Dim S As String If (Niveau And NivTrace) = 0 Then Exit Sub Do While Niveau Niveau = Niveau \ 2 Message = " " & Message Loop S = Format(Now, "dd/mm/yyyy hh:mm:ss") & " " & Message F = FreeFile On Error Resume Next Open FicTrace For Append As F If Err Then Exit Sub Print #F, S Close #F End Sub Sub WriteIniString(Fichier As String, section As String, Cle As String, Texte As String) Dim X As Integer ' Debug.Print Texte X = WritePrivateProfileString(ByVal section, ByVal Cle, ByVal Texte, ByVal Fichier) End Sub Function FileCopyDiff(Source As String, Destin As String) As Boolean 'Copie source dans destination seulement si contenus differents Dim Fs As Integer Dim FD As Integer If Not FileExists(Source) Then Exit Function If FileExists(Destin) Then If FileLen(Destin) <> FileLen(Source) Then Copy Source, Destin, 1, True FileCopyDiff = True Else Fs = FreeFile Open Source For Input As Fs FD = FreeFile Open Destin For Input As FD If Input(LOF(Fs), Fs) <> Input(LOF(FD), FD) Then Close Fs Close FD Copy Source, Destin, 1, True FileCopyDiff = True Else Close Fs Close FD End If End If Else Copy Source, Destin, 1, True FileCopyDiff = True End If End Function Sub MarkActivity(MarkFile As String) Dim F As Integer F = FreeFile Open MarkFile For Output As F Print #F, Format(Now, "ddmmyyyyhhmmss") Close F End Sub Function PathExists(ThisPath As String) As Boolean Dim Temp As String PathExists = True Temp = CurDir On Error Resume Next ChDir ThisPath If Err Then PathExists = False End If On Error GoTo 0 ChDir Temp End Function Function GetFileListe(Masque) As String 'Retourne la liste de tous les fichiers correspondants au masque sous ' la forme de chaines séparées par des virgules. Dim S As String On Error Resume Next S = Dir$(Masque, vbHidden + vbSystem + vbReadOnly) Do While Len(S) GetFileListe = GetFileListe & S & "," S = Dir$ Loop End Function Function GetDirListe(Masque As String) As String 'Retourne la liste de tous les sous répertoires correspondant au masque ' sous la forme de chaines séparées par des virgules. Dim S As String S = Dir$(Masque, vbDirectory + vbHidden + vbSystem + vbReadOnly) Do While Len(S) If PathExists(Masque & S) Then GetDirListe = GetDirListe & S & "," S = Dir$ Loop ' #If Win32 Then If Len(Masque) > 3 Then ' GetDirListe = Mid$(GetDirListe, 6) 'Enlève '.' et '..' ' #End If End If End Function Function IsTimeValid(T As String) As Boolean IsTimeValid = False If IsDate(T) Then T = Format$(CDate(T), "hh:mm") IsTimeValid = True End If End Function Function ReplaceString(Source As String, Match As String, Replace As String, NoWhite As Boolean) As Integer 'Remplace dans la chaine source les occurences de 'Match' par 'Replace' et retourne ' le nombre de remplacements effectués. 'Si le flag NoWhite est spécifié, les codes contrôles ( < 31 décimal) sont 'éliminés de la chaine de sortie AVANT l'insertion de 'Replace'. ' Ex: X = ReplaceString(S, Chr$(10), Chr$(10), True) retourne le nombre de lignes ' non vides de S, et remplace les cr/lf par lf. Dim I As Integer Dim J As Integer Dim S As String Dim T As String J = 1 ' Debug.Print Source ' Debug.Print "-------------------" S = Substring(Source, J, Match) Do While Len(S) If NoWhite Then S = TTrim(S) If Len(S) Then T = T & S & Replace I = I + 1 End If Else T = T & S & Replace I = I + 1 End If J = J + 1 S = Substring(Source, J, Match) Loop ReplaceString = I Source = T ' Debug.Print Source End Function Function TTrim(S As String) As String 'Total Trim: Elimine tous les caractères non imprimables ( 0 à 32 décimal) 'Conserve les espaces entre les mots Dim I As Integer Dim C As String S = Trim$(S) 'Supprime espaces de début et de fin For I = 1 To Len(S) C = Mid$(S, I, 1) If C > Chr$(31) Then TTrim = TTrim & C Next I End Function Sub ShowError(ErrDescription As String, Message As String) ' MsgBox "(" & ErrDescription & ")" & vbCrLf & Message MsgBox ErrDescription, , Message End Sub Function IsSameFile(F1 As String, F2 As String) As Boolean 'Compare nom et date de deux fichiers avec chemins '** Rajouter comparaison de la taille ? IsSameFile = False If FileExists(F1) And FileExists(F2) Then If GetFname(F1) = GetFname(F2) And FileDateTime(F1) = FileDateTime(F2) Then IsSameFile = True End If End If End Function Function GetNextInList(List As String, Sep As String) As String ' Retourne la sous chaine suivante de la liste de chaines 'List' séparées par 'Sep' ' Réinitialisé si appelé avec un nom de liste différent ou de longueur nulle ' Retourne une chaine vide quand liste épuisée ' Non reéntrant !!! Static I As Integer Static LastList As String If List <> LastList Then LastList = List I = 0 End If I = I + 1 GetNextInList = Substring(List, I, Sep) End Function Sub MakeDirTree(Tree As String) ' format de Tree: "x:\a\b\c.." ou ".\a\b\c.." ou "a\b\c.." ou "\a\b\c.." ' Crée tout l'arbre avec les sous répertoires i.e. md a, md a\b, md a\b\c, etc... Dim I As Integer Dim S As String Dim T As String I = 1 S = Substring(Tree, I, "\") If InStr(S, ":") Or InStr(S, ".") Or _ (Len(S) = 0 And Len(Tree) > 0) Then 'Récupère le premier chemin complet: "x:\a" I = I + 1 S = S & "\" & Substring(Tree, I, "\") End If T = S On Error Resume Next Do While Len(T) MkDir S If Err = 0 Or Err = 75 Then 'Reussi ou déja créé I = I + 1 T = Substring(Tree, I, "\") S = S & "\" & T Err.Clear Else MsgBox "MakeDirTree " & Tree & " " & S & vbCrLf & _ "Erreur " & Err, vbCritical, App.EXEName End If Loop ' On Error GoTo 0 End Sub Function GetKeysInSection(Fichier As String, section As String) As String 'Retourne la liste des clés trouvées dans la section spécifiée. ' Ignore les entrées commençant par ';' Dim F As Integer Dim Ligne As String Dim InSection As Boolean If FileExists(Fichier) Then F = FreeFile Open Fichier For Input As F Do While Not EOF(F) Line Input #F, Ligne If InSection Then If InStr(Trim(Ligne), "[") = 1 Then Close F Exit Function End If ' S = UCase(Trim$(Substring(Ligne, 1, "="))) S = Trim$(Substring(Ligne, 1, "=")) If Len(S) And InStr(S, ";") = 0 Then GetKeysInSection = GetKeysInSection & S & "," Else If InStr(Ligne, "[" & UCase(section) & "]") = 1 Then InSection = True End If End If Loop Close F End If End Function Function GetSections(Fichier As String) As String 'Retourne la liste des sections trouvées dans le fichier spécifié ' Ignore les entrées commeçant par ';' Dim F As Integer Dim Ligne As String F = IsOpen(Fichier, "Input", 1000) If F Then Do While Not EOF(F) Line Input #F, Ligne If InStr(Trim(Ligne), "[") = 1 Then Ligne = Mid$(Ligne, 2, InStr(Ligne, "]") - 2) GetSections = GetSections & Ligne & "," End If Loop Close F End If End Function Sub Wait(ByVal Millisecs As Double) ' Ne retourne qu'après 'Millisecs' en millisecondes ou si Unsign(GetTickCount) wrappe (le 49 ème jour) Dim Day49 As Double Dim M As Double Day49 = Unsign(GetTickCount) M = Day49 + Millisecs 'Unsign(GetTickCount) + Millisecs Do DoEvents Loop While Unsign(GetTickCount) < M Or Unsign(GetTickCount) < Day49 ' bug du 49 ème jour, tant pis ! End Sub Function WaitFor(Something As Boolean, Delai As Long) As Boolean ' Wait for 'something' be true while 'Delai' milliseconds' ' Returns the value of 'Something' as soon it becomes true or ' False if Delai elapsed Dim Day49 As Double Dim D As Double 'Ne pas modifier le parametre ! Day49 = Unsign(GetTickCount) D = Day49 + Delai 'Unsign(GetTickCount) + Millisecs Do DoEvents If Something Then WaitFor = Something Exit Function End If Loop While Unsign(GetTickCount) < D Or Unsign(GetTickCount) < Day49 ' bug du 49 ème jour, tant pis ! End Function Sub ShowMsg(Message As String, Titre As String) ' Affiche une boite de message pendant 'Duree' x millisecondes Trace 128, Titre & Chr$(9) & Message #If ShowMsg Then If MyMsg.Visible Or DureeMsg = 0 Then Exit Sub MyMsg.LblDelai.Caption = Str$(DureeMsg) MyMsg.Caption = Titre MyMsg.LblMsg.Caption = Message MyMsg.Show 0 #End If End Sub Function Copy(Org As String, Dest As String, Delai As Integer, TouchDate As Boolean) As Boolean 'Recopie Org sous un nouveau nom (duplique) Dim W As Double Dim Day49 As Double Copy = False Day49 = Unsign(GetTickCount) W = Day49 + Delai On Error Resume Next Do Err.Clear FileCopy Org, Dest If Err = 0 Then If TouchDate Then Touch Dest, 0 Copy = True Exit Function End If DoEvents Loop While Unsign(GetTickCount) < W Or Unsign(GetTickCount) < Day49 ShowMsg "Can't copy " & Org & " in " & Dest, "Copy Error N°" & Str(Err) & " " & Err.Description End Function Function IsOpen(File As String, Mode As String, Delai As Integer) As Integer ' Retourne un numéro de fichier si ouverture possible dans les delais, sinon 0 Dim W As Double Dim Day49 As Double Day49 = Unsign(GetTickCount) W = Day49 + Delai On Error Resume Next Select Case UCase(Mode) Case "INPUT", "READ", "R" Do If Not FileExists(File) Then Exit Function Err.Clear IsOpen = FreeFile Open File For Input Access Read As IsOpen If Err = 0 Then Exit Do DoEvents Loop While Unsign(GetTickCount) < W Or Unsign(GetTickCount) < Day49 Case "OUTPUT", "WRITE", "W" Do Err.Clear IsOpen = FreeFile Open File For Output Access Write As IsOpen If Err = 0 Then Exit Do DoEvents Loop While Unsign(GetTickCount) < W Or Unsign(GetTickCount) < Day49 Case "APPEND", "A" Do Err.Clear IsOpen = FreeFile Open File For Append Access Write As IsOpen If Err = 0 Then Exit Do DoEvents Loop While Unsign(GetTickCount) < W Or Unsign(GetTickCount) < Day49 Case "BINARY", "B" Do Err.Clear IsOpen = FreeFile Open File For Binary Access Read Write As IsOpen If Err = 0 Then Exit Do DoEvents Loop While Unsign(GetTickCount) < W Or Unsign(GetTickCount) < Day49 Case "READBINARY", "RB" If Not FileExists(File) Then Exit Function Do Err.Clear IsOpen = FreeFile Open File For Binary Access Read As IsOpen If Err = 0 Then Exit Do DoEvents Loop While Unsign(GetTickCount) < W Or Unsign(GetTickCount) < Day49 Case "WRITEBINARY", "WB" Do Err.Clear IsOpen = FreeFile Open File For Binary Access Write As IsOpen If Err = 0 Then Exit Do DoEvents Loop While Unsign(GetTickCount) < W Or Unsign(GetTickCount) < Day49 Case Else Mode = "Unknow mode" Error 55 End Select If Err Then ShowMsg "Can't open " & File & " for " & Mode, "IsOpen Error N°" & Str(Err) & _ " " & Err.Description IsOpen = 0 End If Err.Clear End Function Function Delete(File As String, Delai As Integer) As Boolean ' Détruit le fichier si possible sinon renvoie 'False' Dim W As Double Dim Day49 As Double Day49 = Unsign(GetTickCount) W = Day49 + Delai Delete = False On Error Resume Next Do Err.Clear Kill File If Err = 0 Or Err = 53 Then 'Accepter sans râler si fichier inexistant Delete = True Exit Function End If DoEvents Loop While Unsign(GetTickCount) < W Or Unsign(GetTickCount) < Day49 ShowMsg "Can't delete " & File, "Delete Error N°" & Str(Err) & _ " " & Err.Description End Function Function DelTree(Path As String) As Boolean 'Vide et détruit le répertoire spécifié. Dim RList As String Dim Flist As String Dim R As String Dim F As String Dim I As Integer If Not PathExists(Path) Then Exit Function Flist = GetFileListe(Path & "\*.*") 'Obtiend la liste des fichiers I = 1 F = Substring(Flist, I, ",") Do While Len(F) Delete Path & "\" & F, 1 'Efface tous les fichiers I = I + 1 F = Substring(Flist, I, ",") Loop RList = GetDirListe(Path & "\") 'Obtiend la liste des sous répertoires I = 1 R = Substring(RList, I, ",") Do While Len(R) 'pour chaque sous répertroire DelTree Path & "\" & R 'Récursif I = I + 1 R = Substring(RList, I, ",") Loop RmDir Path End Function Function ExecOnTree(Path As String, Action As Long) As Boolean End Function Function Rename(OldName As String, NewName As String, Delai As Integer, TouchDate As Boolean) As Boolean 'Renomme le fichier si possible 'Si 'TouchDate', met NewName à la date courante 'Remplace 'NewName' si existe déjà 'Si lecteurs différents, copie puis détruit ancien If Copy(OldName, NewName, Delai, TouchDate) Then Rename = Delete(OldName, 0) End If End Function Function CheckIfFiles(Liste As String, Path As String, Sep As String) As String 'Retourne 'Liste' sans les fichiers introuvables dans 'Path' Dim I As Integer Dim S As String Dim T As String If Len(Liste) Then I = 1 T = Substring(Liste, I, Sep) Do While Len(T) If FileExists(Path & "\" & T) Then S = S & T & Sep I = I + 1 T = Substring(Liste, I, Sep) Loop CheckIfFiles = S End If End Function Function FileExists(File As String) As Boolean ' Indique si le fichier existe If Len(File) = 0 Then Exit Function On Error Resume Next FileDateTime (File) If Err Then If GereManque Then Manque File Else FileExists = True End If End Function Sub Manque(S As String) If Len(Manquants) < 32000 Then If InStr(Manquants, S) = 0 Then Manquants = Manquants & S & "," 'Sans dupliquer ! End If End Sub Function Touch(File As String, Delai As Integer) As Boolean ' Change la date du fichier par la date courante Dim F As Integer Dim X As String * 1 Touch = False F = IsOpen(File, "Binary", Delai) If F Then If LOF(F) Then Get #F, 1, X Put #F, 1, X Touch = True Else ShowMsg "Can't change date if file is empty " & File, "Touch Error N°" & Str(Err) & _ " " & Err.Description End If Close F End If End Function Function XClose(FileNum As Integer, Delai As Integer) As Boolean Dim W As Double Dim Day49 As Double Day49 = Unsign(GetTickCount) W = Day49 + Delai XClose = False On Error Resume Next Do Err.Clear Close FileNum If Err = 0 Then XClose = True Exit Function End If DoEvents Loop While Unsign(GetTickCount) < W Or Unsign(GetTickCount) < Day49 ShowMsg "Can't close" & Str(FileNum), "Close Error N°" & Str(Err) & _ " " & Err.Description End Function Function CountFileLines(Fichier As String) As Integer 'Retourne le nombre de lignes non vides de 'Fichier' '0 si fichier inaccessible Dim L As String Dim F As Integer F = IsOpen(Fichier, "Input", 1000) If F Then While Not EOF(F) Line Input #F, L If Len(L) Then CountFileLines = CountFileLines + 1 Wend XClose F, 1000 End If End Function Function CountStringLines(S As String) As Integer 'Retourne le nombre de lignes non vides de S ' *** (Voir CountStrings dans ce même module) End Function Function TrieListeChaine(Liste As String, Mode As Integer, Sens As Integer) As String ' Retourne la liste triée dans le sens spécifié (1 = Croissant, 0 = Décroissant) ' selon Mode (1= Texte(Alphabétique), 0 = Binaire) Dim S As String Dim S1 As String Dim S2 As String Dim I As Integer Dim J As Integer Dim T() As String I = 1 S = Trim$(Substring(Liste, I, ",")) While Len(S) 'On rempli le tableau I = I + 1 ReDim Preserve T(I) T(I - 1) = S 'L'indice 0 n'est pas utilisé ! S = Substring(Liste, I, ",") Wend If I > 2 Then 'Il y a qqchose à trier I = I - 1 J = 1 While J < I If StrComp(T(J + 1), T(J), Mode) = -Sens Then 'Permuter S1 = T(J + 1) T(J + 1) = T(J) T(J) = S1 If J > 1 Then J = J - 1 'Retester le précédent Else J = J + 1 End If Wend For J = 1 To I 'Crée la chaine en sortie TrieListeChaine = TrieListeChaine & T(J) & "," Next J Else TrieListeChaine = Liste End If End Function Function TrieTableau(T(), Col As Integer, Mode As Integer) As Integer ' Ordonne les lignes d'un tableau à 2 dimension selon le contenu de la colonne spécifiée ' Mode = 0: Binaire, 1: Alphabétique, 2: Numérique ' Sens = Toujours croissant ' Retourne <> 0 si anomalie. Dim L As Integer Dim C As Integer Dim I As Integer Dim J As Integer Dim Swaped As Boolean L = UBound(T, 1) C = UBound(T, 2) ReDim TT(1, C) If L > 1 Then 'S'il y a au moins 2 lignes If C >= Col Then 'et si la colonne spécifiée existe I = 1 While I < UBound(T, 1) Swaped = False If Mode = 2 Then If T(I + 1, Col) < T(I, Col) Then Swaped = True For J = 0 To C TT(0, J) = T(I + 1, J) 'Permuter T(I + 1, J) = T(I, J) T(I, J) = TT(0, J) Next If I > 0 Then I = I - 1 'Retester le précédent End If Else If StrComp(T(I + 1, Col), T(I, Col), Mode) = -1 Then Swaped = True For J = 0 To C TT(0, J) = T(I + 1, J) 'Permuter T(I + 1, J) = T(I, J) T(I, J) = TT(0, J) Next If I > 0 Then I = I - 1 'Retester le précédent End If End If If Not Swaped Then I = I + 1 End If Wend Else TrieTableau = -1 End If Else TrieTableau = -2 End If End Function Sub StartChrono(Chrono As Integer) ' Lance un chrono On Error Resume Next Chronos(Chrono) = Unsign(GetTickCount) End Sub Sub ShowChrono(Chrono As Integer) 'Affiche un chrono Dim TT As Long On Error Resume Next TT = Unsign(GetTickCount) MsgBox Format$((TT - Chronos(Chrono)) / 1000, "0.000") & " secondes", 0, "Chrono" & Str$(Chrono) ' ShowMsg Str$(TT - Chronos(Chrono)) & " Millisecondes", "Chrono" & Str$(Chrono) End Sub Function UnsignedTovbInteger(ByVal Unsigned As Long) As Integer 'Convertit un long représentant entier non signé (retourné par un appel à un API par exemple) en 'entier non signé à passer à une fonction externe If (Unsigned And &H8000&) = 0 Then UnsignedTovbInteger = Unsigned And &HFFFF& Else UnsignedTovbInteger = &H8000 Or (Unsigned And &H7FFF&) End If End Function Function CountStrings(S As String, SubS As String) As Integer 'Retourne le nombre de 'SubS'contenues dans 'S'. Dim D As Long Dim F As Long D = 1 Do F = InStr(D + 1, S, SubS) If F Then CountStrings = CountStrings + 1 D = F Loop While D End Function Public Function GetFileSpecs(Objet, DefPath As String, DefFichier As String, Titre As String, Mode As String) As String ' Interface pour CommonDialog 'Ouvrir / Enregistrer sous' 'DefPath ne doit pas inclure le "\" terminal Dim S As String Dim E As String With Objet .CancelError = True .Filter = "Tous fichiers (*.*)|*.*" .FilterIndex = 1 E = GetExtension(DefFichier) If Len(E) Then .Filter = .Filter & "|Fichiers " & App.EXEName & " (*." & E & ")|*." & E .FilterIndex = 2 End If .Flags = &H804 .DialogTitle = Titre .InitDir = DefPath .FileName = DefFichier On Error Resume Next If Mode Like "Open" Then .ShowOpen If Mode Like "Save" Then .ShowSave S = .FileName If (Len(S) <> 0) And Err = 0 Then GetFileSpecs = S End If End With End Function Public Function GetFileDate(Fichier As String) As Date GetFileDate = "00:00" On Error Resume Next GetFileDate = FileDateTime(Fichier) End Function Public Function HexDump(S As String, Bloc As Long) As String ' Retourne un dump Hexadécimal de 256 octets de S. Dim Debut As Integer Dim Ligne As Integer Dim Colonne As Integer Dim C(1 To 16) As String Dim H As String For Ligne = 1 To 16 H = Hex((16 * (Ligne - 1)) + (256 * Bloc)) If Len(H) < 8 Then H = String(8 - Len(H), "0") & H HexDump = HexDump & H & ": " For Colonne = 1 To 16 ' les valeurs hexadéciamales C(Colonne) = Mid$(S, Debut + 1, 1) If Len(C(Colonne)) Then H = Hex(Asc(C(Colonne))) If Len(H) < 2 Then H = "0" & H Else H = ".." End If Debut = Debut + 1 HexDump = HexDump & H & " " Next Colonne HexDump = HexDump & " " For Colonne = 1 To 16 'les caractères ascii imprimables If C(Colonne) < " " Then C(Colonne) = " " HexDump = HexDump & C(Colonne) Next Colonne HexDump = HexDump & vbCrLf Next Ligne HexDump = HexDump & vbCrLf End Function ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 'Public Function Unsign(X As Long) As Double ' Retourne un single représentant un entier non signé. ' Utile pour traiter les valeurs retournées par des DLL qui renvoient un ULong 'Dim XX As Double ' XX = X ' If XX < 0 Then ' Unsign = 2147483647 + XX ' Unsign = Unsign + 2147483648# ' Else ' If XX = 0 Then ' Unsign = XX + 1 ' End If ' Unsign = XX ' End If 'End Function ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Function Unsign(X As Long) As Long 'Retourne X sans le signe Unsign = X And &H7FFFFFFF End Function Public Sub CenterForm(F As Form) F.Top = (Screen.Height - F.Height) / 2 F.Left = (Screen.Width - F.Width) / 2 End Sub Public Function Crc(S As String, Debut As Integer) As String 'Retourne le CRC (Xor) de S Dim I As Integer Dim X As Integer For I = Debut To Len(S) X = X Xor Asc(Mid$(S, I, 1)) Next I Crc = Chr$(X) End Function Public Function FormatTexte(S As String, C As Integer, Tableau() As String) As Integer ' Rempli le tableau avec des lignes de longueur 'C' extraites de S et centrées ' *** S ne doit pas contenir de caractères de contrôle *** ' Retourne le nombre de lignes (Taille du tableau) Dim Lignes As Integer Dim Debut As Integer Dim T As String Dim U As String Dim L As Integer Debut = 1 S = Trim$(S) T = Substring(S, Debut, " ") Do While Len(T) T = Trim$(T) Do While Len(T) < C 'Il reste de la place U = Trim$(Substring(S, Debut + 1, " ")) 'Essaie le suivant Debut = Debut + 1 If Len(U) + Len(T) < C Then 'C'est bon T = T & " " & U Else Exit Do End If Loop T = Trim$(T) L = Len(T) If L = C Then Debut = Debut + 1 L = C - L If L > 1 Then 'Centrer L = L \ 2 T = String(L, " ") & T & String(L, " ") End If Lignes = Lignes + 1 ReDim Preserve Tableau(Lignes) Tableau(Lignes - 1) = T T = Substring(S, Debut, " ") Loop FormatTexte = Lignes End Function Public Sub AdjustToken() Const TOKEN_ADJUST_PRIVILEGES = &H20 Const TOKEN_QUERY = &H8 Const SE_PRIVILEGE_ENABLED = &H2 Dim hdlProcessHandle As Long Dim hdlTokenHandle As Long Dim tmpLuid As LUID Dim tkp As TOKEN_PRIVILEGES Dim tkpNewButIgnored As TOKEN_PRIVILEGES Dim lBufferNeeded As Long hdlProcessHandle = GetCurrentProcess() OpenProcessToken hdlProcessHandle, (TOKEN_ADJUST_PRIVILEGES Or _ TOKEN_QUERY), hdlTokenHandle ' Get the LUID for shutdown privilege. LookupPrivilegeValue "", "SeShutdownPrivilege", tmpLuid tkp.PrivilegeCount = 1 ' One privilege to set tkp.TheLuid = tmpLuid tkp.Attributes = SE_PRIVILEGE_ENABLED ' Enable the shutdown privilege in the access token of this ' process. AdjustTokenPrivileges hdlTokenHandle, False, tkp, _ Len(tkpNewButIgnored), tkpNewButIgnored, lBufferNeeded End Sub Public Sub SystemRestart() #If NT Then AdjustToken #End If ExitWindowsEx (EWX_SHUTDOWN Or EWX_FORCE Or EWX_REBOOT), &HFFFF End Sub Public Sub ShowTrace(T As String, F As Form) 'Montre T dans l'objet texte 'Voir' de la feuille F si elle est visible If F.WindowState <> 1 Then If Len(F.Voir.Text) > 16000 Then 'Void overflow F.Voir.Text = "" End If F.Voir.SelText = T & vbCrLf End If Trace 1, T End Sub Public Sub ClearTrace(F As Form) F.Voir.Text = "" End Sub Public Sub PlaySound(Wavefile As String) If Len(Wavefile) > 0 And FileExists(Wavefile) Then sndPlaySound Wavefile, SND_ASYNC End If End Sub Public Function AdjustText(V As Variant, Lenght As Integer) 'Retourne une chaine de longueur 'Lenght' contenant V et paddée avec des espaces Dim S As String Dim L As Integer S = Format$(V) 'Regle le pb du NULL L = Len(S) If L < Lenght Then 'Trop court AdjustText = S & String$(Lenght - L, " ") Else AdjustText = Mid$(S, 1, Lenght) 'Trop long End If End Function Public Function ForceDp(V As String) As String 'Remplace la virgule par le point dans un variant représentant un nombre Dim VPos As Integer VPos = InStr(V, ",") If VPos Then 'Y'en a ForceDp = Substring(V, 1, ",") & "." & Substring(V, 2, ",") Else ForceDp = V End If End Function