386 lines
9.8 KiB
QBasic
386 lines
9.8 KiB
QBasic
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
|
|
|