1 Attribute VB_Name = "mMisc" 2 Option Explicit 3 4 'These are old library functions 5 6 Private Type Bit64Currency 7 value As Currency 8 End Type 9 10 Private Type Bit64Integer 11 LowValue As Long 12 HighValue As Long 13 End Type 14 15 Global Const LANG_US = &H409 16 17 Public Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long 18 Public Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long 19 Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal length As Long) 20 Public Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long 21 Public Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long 22 Public Declare Function SetDllDirectory Lib "kernel32" Alias "SetDllDirectoryA" (ByVal lpPathName As String) As Long 23 24 Function makeCur(high As Long, low As Long) As Currency 25 Dim c As Bit64Currency 26 Dim dl As Bit64Integer 27 dl.LowValue = low 28 dl.HighValue = high 29 LSet c = dl 30 makeCur = c.value 31 End Function 32 33 Function lng2Cur(v As Long) As Currency 34 Dim c As Bit64Currency 35 Dim dl As Bit64Integer 36 dl.LowValue = v 37 dl.HighValue = 0 38 LSet c = dl 39 lng2Cur = c.value 40 End Function 41 42 Function cur2str(v As Currency) As String 43 Dim c As Bit64Currency 44 Dim dl As Bit64Integer 45 c.value = v 46 LSet dl = c 47 If dl.HighValue = 0 Then 48 cur2str = Right("00000000" & Hex(dl.LowValue), 8) 49 Else 50 cur2str = Right("00000000" & Hex(dl.HighValue), 8) & "`" & Right("00000000" & Hex(dl.LowValue), 8) 51 End If 52 End Function 53 54 Function x64StrToCur(ByVal str As String) As Currency 55 56 str = Replace(Trim(str), "0x", "") 57 str = Replace(str, " ", "") 58 str = Replace(str, "`", "") 59 60 Dim low As String, high As String 61 Dim c As Bit64Currency 62 Dim dl As Bit64Integer 63 64 low = VBA.Right(str, 8) 65 dl.LowValue = CLng("&h" & low) 66 67 If Len(str) > 8 Then 68 high = Mid(str, 1, Len(str) - 8) 69 dl.HighValue = CLng("&h" & high) 70 End If 71 72 LSet c = dl 73 x64StrToCur = c.value 74 75 End Function 76 77 Function cur2lng(v As Currency) As Long 78 Dim c As Bit64Currency 79 Dim dl As Bit64Integer 80 c.value = v 81 LSet dl = c 82 cur2lng = dl.LowValue 83 End Function 84 85 Function readLng(offset As Long) As Long 86 Dim tmp As Long 87 CopyMemory ByVal VarPtr(tmp), ByVal offset, 4 88 readLng = tmp 89 End Function 90 91 Function readByte(offset As Long) As Byte 92 Dim tmp As Byte 93 CopyMemory ByVal VarPtr(tmp), ByVal offset, 1 94 readByte = tmp 95 End Function 96 97 Function readCur(offset As Long) As Currency 98 Dim tmp As Currency 99 CopyMemory ByVal VarPtr(tmp), ByVal offset, 8 100 readCur = tmp 101 End Function 102 103 Function col2Str(c As Collection, Optional emptyVal = "") As String 104 Dim v, tmp As String 105 106 If c.count = 0 Then 107 col2Str = emptyVal 108 Else 109 For Each v In c 110 col2Str = col2Str & hhex(v) & ", " 111 Next 112 col2Str = Mid(col2Str, 1, Len(col2Str) - 2) 113 End If 114 115 End Function 116 117 Function regCol2Str(hEngine As Long, c As Collection) As String 118 Dim v, tmp As String 119 120 If c.count = 0 Then Exit Function 121 122 For Each v In c 123 regCol2Str = regCol2Str & regName(hEngine, CLng(v)) & ", " 124 Next 125 regCol2Str = Mid(regCol2Str, 1, Len(regCol2Str) - 2) 126 127 End Function 128 129 130 131 Function b2Str(b() As Byte) As String 132 Dim i As Long 133 134 If AryIsEmpty(b) Then 135 b2Str = "Empty" 136 Else 137 For i = 0 To UBound(b) 138 b2Str = b2Str & hhex(b(i)) & " " 139 Next 140 b2Str = Trim(b2Str) 141 End If 142 143 End Function 144 145 146 147 Function AryIsEmpty(ary) As Boolean 148 Dim i As Long 149 150 On Error GoTo oops 151 i = UBound(ary) '<- throws error if not initalized 152 AryIsEmpty = False 153 Exit Function 154 oops: AryIsEmpty = True 155 End Function 156 157 Public Function toBytes(ByVal hexstr, Optional strRet As Boolean = False) 158 159 'supports: 160 '11 22 33 44 spaced hex chars 161 '11223344 run together hex strings 162 '11,22,33,44 csv hex 163 '\x11,0x22 misc C source rips 164 ' 165 'ignores common C source prefixes, operators, delimiters, and whitespace 166 ' 167 'not supported 168 '1,2,3,4 all hex chars are must have two chars even if delimited 169 ' 170 'a version which supports more formats is here: 171 ' https://github.com/dzzie/libs/blob/master/dzrt/globals.cls 172 173 Dim ret As String, x As String, str As String 174 Dim r() As Byte, b As Byte, b1 As Byte 175 Dim foundDecimal As Boolean, tmp, i, a, a2 176 Dim pos As Long, marker As String 177 178 On Error GoTo nope 179 180 str = Replace(hexstr, vbCr, Empty) 181 str = Replace(str, vbLf, Empty) 182 str = Replace(str, vbTab, Empty) 183 str = Replace(str, Chr(0), Empty) 184 str = Replace(str, "{", Empty) 185 str = Replace(str, "}", Empty) 186 str = Replace(str, ";", Empty) 187 str = Replace(str, "+", Empty) 188 str = Replace(str, """""", Empty) 189 str = Replace(str, "'", Empty) 190 str = Replace(str, " ", Empty) 191 str = Replace(str, "0x", Empty) 192 str = Replace(str, "\x", Empty) 193 str = Replace(str, ",", Empty) 194 195 For i = 1 To Len(str) Step 2 196 x = Mid(str, i, 2) 197 If Not isHexChar(x, b) Then Exit Function 198 bpush r(), b 199 Next 200 201 If strRet Then 202 toBytes = StrConv(r, vbUnicode, LANG_US) 203 Else 204 toBytes = r 205 End If 206 207 nope: 208 End Function 209 210 Private Sub bpush(bAry() As Byte, b As Byte) 'this modifies parent ary object 211 On Error GoTo init 212 Dim x As Long 213 214 x = UBound(bAry) '<-throws Error If Not initalized 215 ReDim Preserve bAry(UBound(bAry) + 1) 216 bAry(UBound(bAry)) = b 217 218 Exit Sub 219 220 init: 221 ReDim bAry(0) 222 bAry(0) = b 223 224 End Sub 225 226 Sub push(ary, value) 'this modifies parent ary object 227 On Error GoTo init 228 Dim x 229 230 x = UBound(ary) 231 ReDim Preserve ary(x + 1) 232 233 If IsObject(value) Then 234 Set ary(x + 1) = value 235 Else 236 ary(x + 1) = value 237 End If 238 239 Exit Sub 240 init: 241 ReDim ary(0) 242 If IsObject(value) Then 243 Set ary(0) = value 244 Else 245 ary(0) = value 246 End If 247 End Sub 248 249 250 Public Function isHexChar(hexValue As String, Optional b As Byte) As Boolean 251 On Error Resume Next 252 Dim v As Long 253 254 If Len(hexValue) = 0 Then GoTo nope 255 If Len(hexValue) > 2 Then GoTo nope 'expecting hex char code like FF or 90 256 257 v = CLng("&h" & hexValue) 258 If Err.Number <> 0 Then GoTo nope 'invalid hex code 259 260 b = CByte(v) 261 If Err.Number <> 0 Then GoTo nope 'shouldnt happen.. > 255 cant be with len() <=2 ? 262 263 isHexChar = True 264 265 Exit Function 266 nope: 267 Err.Clear 268 isHexChar = False 269 End Function 270 271 Function hhex(b) As String 272 hhex = Right("00" & Hex(b), 2) 273 End Function 274 275 Function rpad(x, i, Optional c = " ") 276 rpad = Left(x & String(i, c), i) 277 End Function 278 279 Function HexDump(bAryOrStrData, Optional hexOnly = 0, Optional ByVal startAt As Long = 1, Optional ByVal length As Long = -1) As String 280 Dim s() As String, chars As String, tmp As String 281 On Error Resume Next 282 Dim ary() As Byte 283 Dim offset As Long 284 Const LANG_US = &H409 285 Dim i As Long, tt, h, x 286 287 offset = 0 288 289 If TypeName(bAryOrStrData) = "Byte()" Then 290 ary() = bAryOrStrData 291 Else 292 ary = StrConv(CStr(bAryOrStrData), vbFromUnicode, LANG_US) 293 End If 294 295 If startAt < 1 Then startAt = 1 296 If length < 1 Then length = -1 297 298 While startAt Mod 16 <> 0 299 startAt = startAt - 1 300 Wend 301 302 startAt = startAt + 1 303 304 chars = " " 305 For i = startAt To UBound(ary) + 1 306 tt = Hex(ary(i - 1)) 307 If Len(tt) = 1 Then tt = "0" & tt 308 tmp = tmp & tt & " " 309 x = ary(i - 1) 310 'chars = chars & IIf((x > 32 And x < 127) Or x > 191, Chr(x), ".") 'x > 191 causes \x0 problems on non us systems... asc(chr(x)) = 0 311 chars = chars & IIf((x > 32 And x < 127), Chr(x), ".") 312 If i > 1 And i Mod 16 = 0 Then 313 h = Hex(offset) 314 While Len(h) < 6: h = "0" & h: Wend 315 If hexOnly = 0 Then 316 push s, h & " " & tmp & chars 317 Else 318 push s, tmp 319 End If 320 offset = offset + 16 321 tmp = Empty 322 chars = " " 323 End If 324 If length <> -1 Then 325 length = length - 1 326 If length = 0 Then Exit For 327 End If 328 Next 329 330 'if read length was not mod 16=0 then 331 'we have part of line to account for 332 If tmp <> Empty Then 333 If hexOnly = 0 Then 334 h = Hex(offset) 335 While Len(h) < 6: h = "0" & h: Wend 336 h = h & " " & tmp 337 While Len(h) <= 56: h = h & " ": Wend 338 push s, h & chars 339 Else 340 push s, tmp 341 End If 342 End If 343 344 HexDump = Join(s, vbCrLf) 345 346 If hexOnly <> 0 Then 347 HexDump = Replace(HexDump, " ", "") 348 HexDump = Replace(HexDump, vbCrLf, "") 349 End If 350 351 End Function 352 353 354 355 Function FileExists(path As String) As Boolean 356 On Error GoTo hell 357 358 If Len(path) = 0 Then Exit Function 359 If Right(path, 1) = "\" Then Exit Function 360 If Dir(path, vbHidden Or vbNormal Or vbReadOnly Or vbSystem) <> "" Then FileExists = True 361 362 Exit Function 363 hell: FileExists = False 364 End Function 365 366 Sub WriteFile(path, it) 367 Dim f 368 f = FreeFile 369 Open path For Output As #f 370 Print #f, it 371 Close f 372 End Sub 373 374 Function GetParentFolder(path) As String 375 Dim tmp() As String, ub As Long 376 On Error Resume Next 377 tmp = Split(path, "\") 378 ub = tmp(UBound(tmp)) 379 If Err.Number = 0 Then 380 GetParentFolder = Replace(Join(tmp, "\"), "\" & ub, "") 381 Else 382 GetParentFolder = path 383 End If 384 End Function 385 386
