Attribute VB_Name = "mMisc" | |
Option Explicit | |
'These are old library functions | |
Private Type Bit64Currency | |
value As Currency | |
End Type | |
Private Type Bit64Integer | |
LowValue As Long | |
HighValue As Long | |
End Type | |
Global Const LANG_US = &H409 | |
Public Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long | |
Public Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long | |
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal length As Long) | |
Public Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long | |
Public Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long | |
Public Declare Function SetDllDirectory Lib "kernel32" Alias "SetDllDirectoryA" (ByVal lpPathName As String) As Long | |
Function makeCur(high As Long, low As Long) As Currency | |
Dim c As Bit64Currency | |
Dim dl As Bit64Integer | |
dl.LowValue = low | |
dl.HighValue = high | |
LSet c = dl | |
makeCur = c.value | |
End Function | |
Function lng2Cur(v As Long) As Currency | |
Dim c As Bit64Currency | |
Dim dl As Bit64Integer | |
dl.LowValue = v | |
dl.HighValue = 0 | |
LSet c = dl | |
lng2Cur = c.value | |
End Function | |
Function cur2str(v As Currency) As String | |
Dim c As Bit64Currency | |
Dim dl As Bit64Integer | |
c.value = v | |
LSet dl = c | |
If dl.HighValue = 0 Then | |
cur2str = Right("00000000" & Hex(dl.LowValue), 8) | |
Else | |
cur2str = Right("00000000" & Hex(dl.HighValue), 8) & "`" & Right("00000000" & Hex(dl.LowValue), 8) | |
End If | |
End Function | |
Function x64StrToCur(ByVal str As String) As Currency | |
str = Replace(Trim(str), "0x", "") | |
str = Replace(str, " ", "") | |
str = Replace(str, "`", "") | |
Dim low As String, high As String | |
Dim c As Bit64Currency | |
Dim dl As Bit64Integer | |
low = VBA.Right(str, 8) | |
dl.LowValue = CLng("&h" & low) | |
If Len(str) > 8 Then | |
high = Mid(str, 1, Len(str) - 8) | |
dl.HighValue = CLng("&h" & high) | |
End If | |
LSet c = dl | |
x64StrToCur = c.value | |
End Function | |
Function cur2lng(v As Currency) As Long | |
Dim c As Bit64Currency | |
Dim dl As Bit64Integer | |
c.value = v | |
LSet dl = c | |
cur2lng = dl.LowValue | |
End Function | |
Function readLng(offset As Long) As Long | |
Dim tmp As Long | |
CopyMemory ByVal VarPtr(tmp), ByVal offset, 4 | |
readLng = tmp | |
End Function | |
Function readByte(offset As Long) As Byte | |
Dim tmp As Byte | |
CopyMemory ByVal VarPtr(tmp), ByVal offset, 1 | |
readByte = tmp | |
End Function | |
Function readCur(offset As Long) As Currency | |
Dim tmp As Currency | |
CopyMemory ByVal VarPtr(tmp), ByVal offset, 8 | |
readCur = tmp | |
End Function | |
Function col2Str(c As Collection, Optional emptyVal = "") As String | |
Dim v, tmp As String | |
If c.count = 0 Then | |
col2Str = emptyVal | |
Else | |
For Each v In c | |
col2Str = col2Str & hhex(v) & ", " | |
Next | |
col2Str = Mid(col2Str, 1, Len(col2Str) - 2) | |
End If | |
End Function | |
Function regCol2Str(hEngine As Long, c As Collection) As String | |
Dim v, tmp As String | |
If c.count = 0 Then Exit Function | |
For Each v In c | |
regCol2Str = regCol2Str & regName(hEngine, CLng(v)) & ", " | |
Next | |
regCol2Str = Mid(regCol2Str, 1, Len(regCol2Str) - 2) | |
End Function | |
Function b2Str(b() As Byte) As String | |
Dim i As Long | |
If AryIsEmpty(b) Then | |
b2Str = "Empty" | |
Else | |
For i = 0 To UBound(b) | |
b2Str = b2Str & hhex(b(i)) & " " | |
Next | |
b2Str = Trim(b2Str) | |
End If | |
End Function | |
Function AryIsEmpty(ary) As Boolean | |
Dim i As Long | |
On Error GoTo oops | |
i = UBound(ary) '<- throws error if not initalized | |
AryIsEmpty = False | |
Exit Function | |
oops: AryIsEmpty = True | |
End Function | |
Public Function toBytes(ByVal hexstr, Optional strRet As Boolean = False) | |
'supports: | |
'11 22 33 44 spaced hex chars | |
'11223344 run together hex strings | |
'11,22,33,44 csv hex | |
'\x11,0x22 misc C source rips | |
' | |
'ignores common C source prefixes, operators, delimiters, and whitespace | |
' | |
'not supported | |
'1,2,3,4 all hex chars are must have two chars even if delimited | |
' | |
'a version which supports more formats is here: | |
' https://github.com/dzzie/libs/blob/master/dzrt/globals.cls | |
Dim ret As String, x As String, str As String | |
Dim r() As Byte, b As Byte, b1 As Byte | |
Dim foundDecimal As Boolean, tmp, i, a, a2 | |
Dim pos As Long, marker As String | |
On Error GoTo nope | |
str = Replace(hexstr, vbCr, Empty) | |
str = Replace(str, vbLf, Empty) | |
str = Replace(str, vbTab, Empty) | |
str = Replace(str, Chr(0), Empty) | |
str = Replace(str, "{", Empty) | |
str = Replace(str, "}", Empty) | |
str = Replace(str, ";", Empty) | |
str = Replace(str, "+", Empty) | |
str = Replace(str, """""", Empty) | |
str = Replace(str, "'", Empty) | |
str = Replace(str, " ", Empty) | |
str = Replace(str, "0x", Empty) | |
str = Replace(str, "\x", Empty) | |
str = Replace(str, ",", Empty) | |
For i = 1 To Len(str) Step 2 | |
x = Mid(str, i, 2) | |
If Not isHexChar(x, b) Then Exit Function | |
bpush r(), b | |
Next | |
If strRet Then | |
toBytes = StrConv(r, vbUnicode, LANG_US) | |
Else | |
toBytes = r | |
End If | |
nope: | |
End Function | |
Private Sub bpush(bAry() As Byte, b As Byte) 'this modifies parent ary object | |
On Error GoTo init | |
Dim x As Long | |
x = UBound(bAry) '<-throws Error If Not initalized | |
ReDim Preserve bAry(UBound(bAry) + 1) | |
bAry(UBound(bAry)) = b | |
Exit Sub | |
init: | |
ReDim bAry(0) | |
bAry(0) = b | |
End Sub | |
Sub push(ary, value) 'this modifies parent ary object | |
On Error GoTo init | |
Dim x | |
x = UBound(ary) | |
ReDim Preserve ary(x + 1) | |
If IsObject(value) Then | |
Set ary(x + 1) = value | |
Else | |
ary(x + 1) = value | |
End If | |
Exit Sub | |
init: | |
ReDim ary(0) | |
If IsObject(value) Then | |
Set ary(0) = value | |
Else | |
ary(0) = value | |
End If | |
End Sub | |
Public Function isHexChar(hexValue As String, Optional b As Byte) As Boolean | |
On Error Resume Next | |
Dim v As Long | |
If Len(hexValue) = 0 Then GoTo nope | |
If Len(hexValue) > 2 Then GoTo nope 'expecting hex char code like FF or 90 | |
v = CLng("&h" & hexValue) | |
If Err.Number <> 0 Then GoTo nope 'invalid hex code | |
b = CByte(v) | |
If Err.Number <> 0 Then GoTo nope 'shouldnt happen.. > 255 cant be with len() <=2 ? | |
isHexChar = True | |
Exit Function | |
nope: | |
Err.Clear | |
isHexChar = False | |
End Function | |
Function hhex(b) As String | |
hhex = Right("00" & Hex(b), 2) | |
End Function | |
Function rpad(x, i, Optional c = " ") | |
rpad = Left(x & String(i, c), i) | |
End Function | |
Function HexDump(bAryOrStrData, Optional hexOnly = 0, Optional ByVal startAt As Long = 1, Optional ByVal length As Long = -1) As String | |
Dim s() As String, chars As String, tmp As String | |
On Error Resume Next | |
Dim ary() As Byte | |
Dim offset As Long | |
Const LANG_US = &H409 | |
Dim i As Long, tt, h, x | |
offset = 0 | |
If TypeName(bAryOrStrData) = "Byte()" Then | |
ary() = bAryOrStrData | |
Else | |
ary = StrConv(CStr(bAryOrStrData), vbFromUnicode, LANG_US) | |
End If | |
If startAt < 1 Then startAt = 1 | |
If length < 1 Then length = -1 | |
While startAt Mod 16 <> 0 | |
startAt = startAt - 1 | |
Wend | |
startAt = startAt + 1 | |
chars = " " | |
For i = startAt To UBound(ary) + 1 | |
tt = Hex(ary(i - 1)) | |
If Len(tt) = 1 Then tt = "0" & tt | |
tmp = tmp & tt & " " | |
x = ary(i - 1) | |
'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 | |
chars = chars & IIf((x > 32 And x < 127), Chr(x), ".") | |
If i > 1 And i Mod 16 = 0 Then | |
h = Hex(offset) | |
While Len(h) < 6: h = "0" & h: Wend | |
If hexOnly = 0 Then | |
push s, h & " " & tmp & chars | |
Else | |
push s, tmp | |
End If | |
offset = offset + 16 | |
tmp = Empty | |
chars = " " | |
End If | |
If length <> -1 Then | |
length = length - 1 | |
If length = 0 Then Exit For | |
End If | |
Next | |
'if read length was not mod 16=0 then | |
'we have part of line to account for | |
If tmp <> Empty Then | |
If hexOnly = 0 Then | |
h = Hex(offset) | |
While Len(h) < 6: h = "0" & h: Wend | |
h = h & " " & tmp | |
While Len(h) <= 56: h = h & " ": Wend | |
push s, h & chars | |
Else | |
push s, tmp | |
End If | |
End If | |
HexDump = Join(s, vbCrLf) | |
If hexOnly <> 0 Then | |
HexDump = Replace(HexDump, " ", "") | |
HexDump = Replace(HexDump, vbCrLf, "") | |
End If | |
End Function | |
Function FileExists(path As String) As Boolean | |
On Error GoTo hell | |
If Len(path) = 0 Then Exit Function | |
If Right(path, 1) = "\" Then Exit Function | |
If Dir(path, vbHidden Or vbNormal Or vbReadOnly Or vbSystem) <> "" Then FileExists = True | |
Exit Function | |
hell: FileExists = False | |
End Function | |
Sub WriteFile(path, it) | |
Dim f | |
f = FreeFile | |
Open path For Output As #f | |
Print #f, it | |
Close f | |
End Sub | |
Function GetParentFolder(path) As String | |
Dim tmp() As String, ub As Long | |
On Error Resume Next | |
tmp = Split(path, "\") | |
ub = tmp(UBound(tmp)) | |
If Err.Number = 0 Then | |
GetParentFolder = Replace(Join(tmp, "\"), "\" & ub, "") | |
Else | |
GetParentFolder = path | |
End If | |
End Function | |