capstone/bindings/vb6/mMisc.bas

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