Attribute VB_Name = "klibr" Function klibr_version() As String klibr_version = "1.6.0" End Function Function array_shuffle(ByVal a As Variant) As Variant Dim t, c As Variant Dim n, i, r As Long t = a n = UBound(t) + 1 i = 0 Randomize Do While (i < n) r = CInt(Rnd() * (n - 1)) c = t(i) t(i) = t(r) t(r) = c i = i + 1 Loop array_shuffle = t End Function Function array_max_value(ByVal a As Variant) As Variant Dim m As Variant Dim n, i As Long m = a n = UBound(a) + 1 i = 0 Do While (i < n) m = IIf(i = 0, a(i), m) m = IIf(m > a(i), m, a(i)) i = i + 1 Loop array_max_value = m End Function Function array_min_value(ByVal a As Variant) As Variant Dim m As Variant Dim n, i As Long m = a n = UBound(a) + 1 i = 0 Do While (i < n) m = IIf(i = 0, a(i), m) m = IIf(m < a(i), m, a(i)) i = i + 1 Loop array_min_value = m End Function Function array_random(ByVal a As Variant, Optional ByVal l As Long) As Variant l = IIf(l = 0, 1, l) Dim t As Variant ReDim t(l - 1) Dim n, i, r As Long n = UBound(a) + 1 i = 0 Do While (i < l) r = CInt(Rnd() * (n - 1)) t(i) = a(r) i = i + 1 Loop array_random = t End Function Function array_reverse(ByVal a As Variant) As Variant Dim t As Variant Dim n, i As Long n = UBound(a) + 1 ReDim t(n - 1) i = 0 Do While (i < n) t(i) = a(n - i - 1) i = i + 1 Loop array_reverse = t End Function Function array_unique(ByVal a As Variant) As Variant '//!! besoin de : array_splice Dim t As Variant Dim n, i, j As Long t = a n = UBound(t) + 1 i = 0 Do While (i < n) j = i + 1 Do While (j < n) If t(i) = t(j) Then t = array_splice(t, j, 1) n = UBound(t) + 1 End If j = j + 1 Loop i = i + 1 Loop array_unique = t End Function Function array_splice(ByVal a As Variant, Optional ByVal p As Long, Optional ByVal l As Variant) As Variant Dim t As Variant Dim n, i, j As Long n = UBound(a) + 1 l = IIf(VarType(l) <> 2, n, l) If l >= n And p <= 0 Then '//!!! si l = ou > a la longeur du tableau et p = ou < a 0 on retourne un tableau vide array_splice = t Exit Function End If ReDim t(IIf(l = n, p - 1, n - l - 1)) i = 0 j = 0 Do While (i < n) If (i < p) Or (i > p + l - 1) Then t(j) = a(i) j = j + 1 End If i = i + 1 Loop array_splice = t End Function Function array_search(ByVal s As Variant, ByVal a As Variant) As Variant Dim i, n As Long n = UBound(a) + 1 i = 0 Do While (i < n) If a(i) = s Then array_search = i Exit Function End If i = i + 1 Loop array_search = Null End Function Function array_diff(ByVal a As Variant, ByVal b As Variant) As Variant Dim t As Variant Dim n, m, l, i, j, d As Long n = UBound(a) + 1 m = UBound(b) + 1 l = 0 i = 0 Do While (i < n) d = 0 j = 0 Do While (j < m) If a(i) = b(j) Then d = d + 1 End If j = j + 1 Loop If d = 0 Then If l = 0 Then ReDim t(l) Else ReDim Preserve t(l) End If t(l) = a(i) l = l + 1 End If i = i + 1 Loop array_diff = t End Function Function array_intersect(ByVal a As Variant, ByVal b As Variant) As Variant Dim t As Variant Dim n, m, l, i, j, d As Long n = UBound(a) + 1 m = UBound(b) + 1 l = 0 i = 0 Do While (i < n) d = 0 j = 0 Do While (j < m) If a(i) = b(j) Then d = d + 1 Exit Do End If j = j + 1 Loop If d > 0 Then If l = 0 Then ReDim t(l) Else ReDim Preserve t(l) End If t(l) = a(i) l = l + 1 End If i = i + 1 Loop array_intersect = t End Function Function array_sum(ByVal a As Variant) As Double Dim n, i As Long Dim r As Double n = UBound(a) + 1 r = 0 i = 0 Do While (i < n) r = r + CDbl(IIf(VarType(a(i)) > 1 And VarType(a(i)) < 6, a(i), Val(a(i)))) i = i + 1 Loop array_sum = r End Function Function array_count_values(ByVal a As Variant) As Object '//!! besoin de : array_splice Dim s As Object Dim t, k As Variant Dim n, c, i As Long t = a n = UBound(t) + 1 Set s = CreateObject("Scripting.Dictionary") Do While (n > 0) c = 0 i = 0 k = t(i) Do While (i < n) If k = t(i) Then c = c + 1 t = array_splice(t, i, 1) n = n - 1 Else i = i + 1 End If Loop s.Add k, c Loop Set array_count_values = s End Function Function array_key_exists(ByVal k As Variant, ByVal a As Variant) As Boolean Dim t As Variant Dim n, i As Long Dim r As Boolean r = False Select Case VarType(a) Case Is = vbObject t = a.keys n = UBound(t) + 1 i = 0 Do While (i < n) If t(i) = k Then r = True Exit Do End If i = i + 1 Loop Case Is >= vbArray If k >= LBound(a) And k <= UBound(a) Then r = True End If End Select array_key_exists = r End Function Function array_change_key_case(ByVal a As Variant, Optional ByVal c As String) As Variant Dim t, k As Variant Dim n, i As Long If VarType(a) >= vbArray Then array_change_key_case = a Exit Function End If c = IIf(c = vbNullString, "L", UCase(c)) c = IIf(c = "CASE_UPPER", "U", c) Set t = CreateObject("Scripting.Dictionary") k = a.keys n = a.Count i = 0 If c = "U" Then Do While (i < n) t.Add UCase(k(i)), a(k(i)) i = i + 1 Loop Else Do While (i < n) t.Add LCase(k(i)), a(k(i)) i = i + 1 Loop End If Set array_change_key_case = t End Function Function array_merge(ByVal a As Variant, ByVal b As Variant) As Variant Dim t, x, k, v, c As Variant Dim n, m, i, j As Long x = 0 x = IIf(VarType(a) = vbEmpty, x + 1, x) x = IIf(VarType(a) >= vbArray, x + 1, x) x = IIf(VarType(a) = vbObject, x + 2, x) x = IIf(VarType(b) = vbEmpty, x + 3, x) x = IIf(VarType(b) >= vbArray, x + 3, x) x = IIf(VarType(b) = vbObject, x + 6, x) x = Choose(x, 3, 5, 4, 1, 2, 6, 2, 2) '1 array mode / 2 object mode / 3 is array a / 4 is array b / 5 is object a / 6 is object b x = IIf(x = Null, 0, x) Select Case x Case 1 'ARRAY MODE n = 0 m = 0 If Not IsEmpty(a) Then n = UBound(a) + 1 'If (Not x()) <> -1 Then If Not IsEmpty(b) Then m = UBound(b) + 1 If n + m > 0 Then ReDim t(n + m - 1) i = 0 Do While (i < n) t(i) = a(i) i = i + 1 Loop i = 0 Do While (i < m) t(i + n) = b(i) i = i + 1 Loop Case 2 'OBJECT MODE Set t = CreateObject("Scripting.Dictionary") m = 0 j = 0 Do While (j < 2) If j = 0 Then If VarType(a) = vbObject Then Set c = a Else c = a End If Else If VarType(b) = vbObject Then Set c = b Else c = b End If End If If VarType(c) = vbObject Then k = c.keys v = c.Items n = c.Count i = 0 Do While (i < n) t(k(i)) = v(i) If IsNumeric(k(i)) Then m = Val(k(i)) + 1 i = i + 1 Loop Else n = 0 If Not IsEmpty(c) Then n = UBound(c) + 1 i = 0 Do While (i < n) t(m) = c(i) m = m + 1 i = i + 1 Loop End If j = j + 1 Loop Case 3 'IS ARRAY A t = a Case 4 'IS ARRAY B t = b Case 5 'IS OBJECT A Set t = a Case 6 'IS OBJECT B Set t = b End Select If VarType(t) = vbObject Then Set array_merge = t Else array_merge = t End If End Function Function array_keys(ByVal a As Variant) As Variant Dim t As Variant Dim n, m, i As Long If VarType(a) = vbObject Then t = a.keys ElseIf VarType(a) >= vbArray Then If Not IsEmpty(a) Then n = UBound(a) + 1 If n > 0 Then i = LBound(a) ReDim t(n - i - 1) m = 0 Do While (i < n) t(m) = i m = m + 1 i = i + 1 Loop End If End If End If array_keys = t End Function Function array_join(ByVal a As Variant, Optional ByVal s As Variant) As Variant If var_is_array(a) Then array_join = Join(a, var_string(s)) Else array_join = "" End If End Function Function fso_drives(Optional ByVal s As Variant) As Variant '//s = search type de lecteur ("UNKNOWN" ; "REMOVABLE" ; "FIXED" ; "NETWORK" ; "CDROM" ; "RAMDISK") Dim t, r As Variant Dim n As Long Dim f, d, e As Object s = IIf(VarType(s) = 10, vbNullString, s) s = IIf(VarType(s) = vbInteger, CStr(s), s) s = IIf(VarType(s) <> vbString, vbNullString, s) s = Trim(s) s = IIf(s = vbNullString, "012345", s) s = UCase(s) s = Replace(s, " ", vbNullString) s = Replace(s, "-", vbNullString) r = Split("UNKNOWN,REMOVABLE,FIXED,NETWORK,CDROM,RAMDISK", ",") l = UBound(r) i = 0 Do While (i < l) s = Replace(s, r(i), CStr(i)) i = i + 1 Loop Set f = CreateObject("Scripting.FileSystemObject") Set d = f.Drives n = 0 For Each e In d If InStr(1, s, CStr(e.DriveType)) > 0 Then If n = 0 Then ReDim t(n) Else ReDim Preserve t(n) End If t(n) = e.DriveLetter n = n + 1 End If Next fso_drives = t End Function Function fso_drive_name(ByVal p As String) As String Dim s As String Dim f, d As Object p = Left(p, 1) & ":" Set f = CreateObject("Scripting.FileSystemObject") s = "" If f.DriveExists(p) Then Set d = f.GetDrive(p) If d.DriveType = 3 Then s = d.ShareName Else If d.IsReady Then s = d.VolumeName Else s = "[Drive not ready]" End If End If End If fso_drive_name = s End Function Function fso_drive_exists(ByVal p As String) As Boolean Dim s As Boolean Dim f As Object p = Left(p, 1) & ":" Set f = CreateObject("Scripting.FileSystemObject") s = False If f.DriveExists(p) Then s = True End If fso_drive_exists = s End Function Function fso_folders(ByVal p As String, Optional ByVal r As Boolean) As Variant '//!! besoin de : array_merge Dim t As Variant Dim n As Long Dim f, d, e As Object Set f = CreateObject("Scripting.FileSystemObject") If f.FolderExists(p) Then Set d = f.GetFolder(p) Set d = d.SubFolders n = 0 For Each e In d If n = 0 Then ReDim t(n) Else ReDim Preserve t(n) End If t(n) = e.Path If r Then t = array_merge(t, fso_folders(t(n), r)) n = UBound(t) End If n = n + 1 Next End If fso_folders = t End Function Function fso_folder_exists(ByVal p As String) As Boolean Dim s As Boolean Dim f As Object Set f = CreateObject("Scripting.FileSystemObject") s = False If f.FolderExists(p) Then s = True End If fso_folder_exists = s End Function Function fso_files(ByVal p As String, Optional ByVal r As Boolean) As Variant '//!! besoin de : array_merge Dim t As Variant Dim n As Long Dim f, d, e As Object Set f = CreateObject("Scripting.FileSystemObject") If f.FolderExists(p) Then Set d = f.GetFolder(p) Set d = d.Files n = 0 For Each e In d If n = 0 Then ReDim t(n) Else ReDim Preserve t(n) End If t(n) = e.Path n = n + 1 Next If r Then Set d = f.GetFolder(p) Set d = d.SubFolders For Each e In d t = array_merge(t, fso_files(e.Path, r)) Next End If fso_files = t End If End Function Function fso_file_exists(ByVal p As String) As Boolean Dim s As Boolean Dim f As Object Set f = CreateObject("Scripting.FileSystemObject") s = False If f.FileExists(p) Then s = True End If fso_file_exists = s End Function Function math_random(Optional ByVal a As Variant, Optional ByVal b As Variant) As Variant a = var_number(a) b = var_number(b, 1) Randomize math_random = Format((Rnd() * (b - a)) + a, "0") End Function Function math_pi() As Double math_pi = 3.14159265358979 End Function Function math_round(ByVal v As Variant, Optional ByVal d As Variant) As Variant v = var_number(v) d = var_number(d) math_round = Int((v * (10 ^ d)) + 0.5) / (10 ^ d) End Function Function math_abs(ByVal v As Variant) As Variant v = var_number(v) math_abs = IIf(v < 0, v * -1, v) End Function Function math_to_bytes(ByVal v As Variant, Optional ByVal l As Variant) As Variant Dim k, i As Long Dim b() As Byte ReDim b(0) v = math_round(v) l = math_round(l) k = 1 i = 0 Do While k <= v ReDim Preserve b(i) b(i) = ((255 * k) And v) \ k i = i + 1 k = IIf(l < 1, 256 ^ i, IIf(l <= i, v + 1, 256 ^ i)) Loop If i < l Then ReDim Preserve b(l - 1) math_to_bytes = b End Function Function math_to_str(ByVal v As Variant, Optional ByVal l As Variant) As String Dim k, i As Long Dim s() As String ReDim s(0) s(0) = Chr(0) v = math_round(v) l = math_round(l) k = 1 i = 0 Do While k <= v ReDim Preserve s(i) s(i) = Chr(((255 * k) And v) \ k) i = i + 1 k = IIf(l < 1, 256 ^ i, IIf(l <= i, v + 1, 256 ^ i)) Loop Do While i < l ReDim Preserve s(i) s(i) = Chr(0) i = i + 1 Loop math_to_str = Join(s, "") End Function Function var_numeric(ByVal v As Variant, Optional ByVal d As Variant) As Variant Select Case VarType(d) Case vbDouble, vbSingle, vbInteger, vbLong '-- Case Else d = 0 End Select Select Case VarType(v) Case vbDouble, vbSingle, vbInteger, vbLong var_numeric = v Case Else var_numeric = d End Select End Function Function var_number(ByVal v As Variant, Optional ByVal d As Variant, Optional ByVal e As Boolean) As Variant Dim t As Variant t = VarType(d) Select Case t Case vbDouble, vbSingle, vbInteger, vbLong '-- Case Else d = 0 End Select t = VarType(v) If (t = vbString And e <> True) Then var_number = IIf(Trim(v) = vbNullString, d, IIf(IsNumeric(v), Val(v), d)) Exit Function End If Select Case t Case vbString var_number = IIf(Trim(v) = vbNullString, 0, IIf(IsNumeric(v), Val(v), d)) Case vbDouble, vbSingle, vbInteger, vbLong var_number = v Case Else var_number = d End Select End Function Function var_string(ByVal v As Variant, Optional ByVal d As Variant) As String d = IIf(VarType(d) = vbString, d, "") v = IIf(VarType(v) = vbString, v, d) var_string = v End Function Function var_is_numeric(ByVal v As Variant) As Boolean Select Case VarType(v) Case vbDouble, vbSingle, vbInteger, vbLong var_is_numeric = True Case Else var_is_numeric = False End Select End Function Function var_is_number(ByVal v As Variant, Optional ByVal e As Boolean) As Boolean Dim t As Variant t = VarType(v) If (t = vbString And e <> True) Then var_is_number = IIf(Trim(v) = vbNullString, False, IIf(IsNumeric(v), True, False)) Exit Function End If Select Case t Case vbString var_is_number = IIf(Trim(v) = vbNullString, True, IIf(IsNumeric(v), True, False)) Case vbDouble, vbSingle, vbInteger, vbLong var_is_number = True Case Else var_is_number = False End Select End Function Function var_is_string(ByVal v As Variant) As Boolean var_is_string = IIf(VarType(v) = vbString, True, False) End Function Function var_is_array(ByVal a As Variant) As Boolean Dim r As Boolean r = False If VarType(a) >= vbArray Then r = True End If var_is_array = r End Function Function var_is_object(ByVal o As Variant) As Boolean Dim r As Boolean r = False If VarType(o) = vbObject Then r = True End If var_is_object = r End Function Function str_len(ByVal v As Variant) As Long str_len = Len(var_string(v)) End Function Function str_pos(ByVal v As Variant, Optional ByVal s As Variant, Optional ByVal p As Variant) As Long Dim r, l As Long p = math_round(p) v = var_string(v) l = Len(v) v = str_sub_str(v, p) s = var_string(s) 'modif special VB6 r = IIf(s = vbNullString, l + 1, InStr(1, v, var_string(s))) 'modif special VB6 pour si s = vide retourne str_pos = IIf(r = l + 1, -1, IIf(r < 1, r - 1, IIf(p < 0, IIf(l + p < 0, r - 1, l + p + r - 1), r + p - 1))) End Function Function str_reverse(ByVal v As Variant) As String str_reverse = StrReverse(var_string(v)) End Function Function str_split(ByVal v As Variant, Optional ByVal s As Variant) As Variant Dim t As Variant Dim n, i As Long v = var_string(v) s = var_string(s) If v = vbNullString Then str_split = Array() Exit Function End If If s = vbNullString Then n = Len(v) i = 0 ReDim t(i) Do While (i < n) ReDim Preserve t(i) t(i) = Mid(v, i + 1, 1) i = i + 1 Loop str_split = t Exit Function End If str_split = Split(v, s) End Function Function str_sub_str(ByVal v As Variant, Optional ByVal s As Variant, Optional ByVal l As Variant) As String v = var_string(v) s = math_round(s) l = IIf(var_is_number(l), math_round(l), Len(v)) s = IIf(s < 0, Len(v) + s, s) l = IIf(l < 0, Len(v) + l - s, l) s = IIf(s < 0, 0, s) l = IIf(l < 0, 0, l) str_sub_str = Mid(v, s + 1, l) End Function Function str_last_pos(ByVal v As Variant, Optional ByVal s As Variant, Optional ByVal p As Variant) As Long Dim r, l As Long p = math_round(p) v = var_string(v) l = Len(v) v = IIf(p < 0, str_sub_str(v, 0, p), str_sub_str(v, p)) s = var_string(s) 'modif special VB6 r = IIf(s = vbNullString, l + 1, InStrRev(v, s)) 'modif special VB6 pour si s = vide retourne str_last_pos = IIf(r = l + 1, -1, IIf(r < 1, r - 1, IIf(p < 0, r - 1, r + p - 1))) End Function Function str_repeat(ByVal v As Variant, Optional ByVal n As Variant) As String Dim i As Long Dim t As Variant v = var_string(v) n = math_round(n) n = IIf(n < 0, 0, n) i = 0 Do While (i < n) If i = 0 Then ReDim t(i) Else ReDim Preserve t(i) End If t(i) = v i = i + 1 Loop str_repeat = array_join(t) End Function Function str_to_bytes(ByVal v As Variant) As Variant Dim t() As Byte t = StrConv(var_string(v), vbFromUnicode) str_to_bytes = t End Function Function str_to_crc32(ByVal v As Variant) As String Dim t() As Byte t = str_to_bytes(v) str_to_crc32 = hash_crc32(t) End Function Function hash_crc32_table() As Variant Dim t(255) As Long Dim p, x, i, j As Long p = &HEDB88320 i = 0 Do While i < 256 x = i j = 8 Do While j > 0 If (x And 1) Then x = ((x And &HFFFFFFFE) \ 2&) And &H7FFFFFFF x = x Xor p Else x = ((x And &HFFFFFFFE) \ 2&) And &H7FFFFFFF End If j = j - 1 Loop t(i) = x i = i + 1 Loop hash_crc32_table = t End Function Function hash_crc32(ByRef b() As Byte) As String Dim t() As Long Dim r, i, j, u As Long 'result r = &HFFFFFFFF t = hash_crc32_table() i = LBound(b) u = UBound(b) + 1 Do While i < u j = (r And &HFF) Xor b(i) r = ((r And &HFFFFFF00) \ &H100) And 16777215 ' nasty shr 8 with vb :/ r = r Xor t(j) i = i + 1 Loop r = Not (r) hash_crc32 = Hex(r) End Function Function hash_crc16_table() As Variant Dim t(255) As Long Dim x, i, j, k As Long i = 0 Do While i < 256 k = i * 256 x = 0 j = 8 Do While j > 0 If (((x Xor k) And 32768) = 32768) Then x = (x * 2) Xor &H1021 Else x = x * 2 End If k = k * 2 j = j - 1 Loop t(i) = x i = i + 1 Loop hash_crc16_table = t End Function