Using CryptHashData On Very Large Input - winapi

I am trying to MD5 hash user-supplied data (a file) using The Crypto functions in AdvApi32. All is well and good unless the file is very large (hundreds of MB. or larger) in which case I eventually get an OutOfMemory exception.
I figured that the solution would be to make repeated calls to CryptHashData using the same HashObject and processing only (for example) 4096 bytes at a time.
This appears to work, but the returned hash is incorrect.
Function HashFile(File As FolderItem) As String
Declare Function CryptAcquireContextW Lib "AdvApi32" (ByRef provider as Integer, container as Integer, providerName as WString, _
providerType as Integer, flags as Integer) as Boolean
Declare Sub CryptDestroyHash Lib "AdvApi32" (hashHandle as Integer )
Declare Function CryptCreateHash Lib "AdvApi32" (provider as Integer, algorithm as Integer, key as Integer, flags as Integer, _
ByRef hashHandle as Integer) as Boolean
Declare Function CryptHashData Lib "AdvApi32" (hashHandle as Integer, data as Ptr, length as Integer, flags as Integer) as Boolean
Declare Function CryptGetHashParam Lib "AdvApi32" (hashHandle as Integer, type as Integer, value as Ptr, ByRef length as Integer, _
flags as Integer) as Boolean
Const HP_HASHVAL = &h0002
Const HP_HASHSIZE = &h0004
Const MS_DEF_PROV = "Microsoft Base Cryptographic Provider v1.0"
Const PROV_RSA_FULL = 1
Const CRYPT_NEWKEYSET = &h00000008
Const CALG_MD5 = &h00008003
Dim provider As Integer
Dim hashHandle As Integer
If Not CryptAcquireContextW(provider, 0, MS_DEF_PROV, PROV_RSA_FULL, 0) Then
If Not CryptAcquireContextW(provider, 0, MS_DEF_PROV, PROV_RSA_FULL, CRYPT_NEWKEYSET) Then
Raise New RuntimeException
End If
End If
If Not CryptCreateHash(provider, CALG_MD5, 0, 0, hashHandle) Then
Raise New RuntimeException
End If
Dim dataPtr As New MemoryBlock(4096)
Dim bs As BinaryStream
bs = bs.Open(File)
dataPtr.StringValue(0, 4096) = bs.Read(4096)
Do
If CryptHashData(hashHandle, dataPtr, dataPtr.Size, 0) Then
dataPtr = New MemoryBlock(4096)
dataPtr.StringValue(0, 4095) = bs.Read(4096)
End If
Loop Until bs.EOF
Dim size as Integer = 4
Dim toss As New MemoryBlock(4)
If Not CryptGetHashParam(hashHandle, HP_HASHSIZE, toss, size, 0) Then
Raise New RuntimeException
End If
size = toss.UInt32Value(0)
Dim hashValue As New MemoryBlock(size)
If Not CryptGetHashParam(hashHandle, HP_HASHVAL, hashValue, size, 0) Then
Raise New RuntimeException
End If
CryptDestroyHash(hashHandle)
//Convert binary to hex
Dim hexvalue As Integer
Dim hexedInt As String
Dim src As String = hashValue.StringValue(0, hashValue.Size)
For i As Integer = 1 To LenB(src)
hexvalue = AscB(MidB(src, i, 1))
hexedInt = hexedInt + RightB("00" + Hex(hexvalue), 2)
next
Return LeftB(hexedInt, LenB(hexedInt))
End Function
What am I doing wrong here? The output I get is consistent, but wrong.

Did you check that msdn example on C++ ?
Very similar answer to your question.

I think the problem is that since you read the data in blocks of 4096 bytes - when the data is not a multiple of 4096 you endup including unwanted trailing 0's or possibly garbage values. Try bs.Read(1) instead of bs.Read(4096) in the loop: Loop Until bs.EOF in-order to test if correct hash is being calculated now. If successful adjust your loop to tackle the remainder (%4096) bytes separately.

Related

How to get the Browser UserAgent String in Visual Basic 6?

I am trying to get the UserAgent of the default browser using the ObtainUserAgentString API in Visual Basic 6. I found the documentation on the MSDN and tried to convert it to Visual Basic 6 but it did not work.
C++ (MSDN)
HRESULT ObtainUserAgentString(
_In_ DWORD dwOption = 0,
_Out_ LPCSTR *pcszUAOut,
_Out_ DWORD *cbSize
);
Visual Basic 6 API
Private Declare Function ObtainUserAgentString Lib "Urlmon.dll" (ByVal dwOption As Long, ByRef pcszUAOut As String, ByRef cbSize As Long) As Long
Private Function BrowserUserAgent() As String
Dim httpUseragent As String
Dim szhttpUserAgent As Long
httpUseragent = Space(512)
szhttpUserAgent = Len(httpUseragent)
Call ObtainUserAgentString(0, httpUseragent, szhttpUserAgent)
BrowserUserAgent = httpUseragent
End Function
Private Sub Command1_Click()
MsgBox BrowserUserAgent
End Sub
Aside from the fact this is a cruddy old ANSI entrypoint, everything you need appears to be documented.
Option Explicit
Private Const NOERROR As Long = 0
Private Const E_OUTOFMEMORY As Long = &H8007000E
Private Enum UAS_OPTIONSENUM
[_UAS_EXACTLEGACY] = &H1000&
UAS_DEFAULT = 0
UAS_7 = 7 'Compatible mode.
UAS_7_LEGACY = 7 Or [_UAS_EXACTLEGACY]
UAS_8 = 8
UAS_9 = 9
UAS_10 = 10
UAS_11 = 11
End Enum
Private Declare Function ObtainUserAgentString Lib "urlmon" ( _
ByVal dwOption As Long, _
ByVal pcszUAOut As Long, _
ByRef cbSize As Long) As Long
Private Function BrowserUserAgent( _
Optional ByVal Options As UAS_OPTIONSENUM = UAS_DEFAULT) As String
Const MAX_BUFFER As Long = 2048
Dim Size As Long
Dim Buffer() As Byte
Dim HRESULT As Long
Do
Size = Size + 128
ReDim Buffer(Size - 1)
HRESULT = ObtainUserAgentString(Options, VarPtr(Buffer(0)), Size)
Loop While HRESULT = E_OUTOFMEMORY And Size < MAX_BUFFER
If HRESULT = NOERROR Then
BrowserUserAgent = StrConv(LeftB$(Buffer, Size - 1), vbUnicode)
Else
Err.Raise &H8004D000, _
, _
"ObtainUserAgentString error &H" & Hex$(HRESULT)
End If
End Function
Private Sub Form_Load()
AutoRedraw = True
Print BrowserUserAgent()
Print BrowserUserAgent(UAS_7)
Print BrowserUserAgent(UAS_7_LEGACY)
Print BrowserUserAgent(UAS_8)
Print BrowserUserAgent(UAS_11)
End Sub
HRESULT ObtainUserAgentString(
_In_ DWORD dwOption = 0,
_Out_ LPCSTR *pcszUAOut,
_Out_ DWORD *cbSize
);
Param 2 is LongPointerCString. You always pass C strings ByVal which in reality passes the C string part of the B String ByRef. If it was a IN param you would have to end the string with a Chr(0) which is what real C strings have.
String arguments are a special case. Passing a string by value means you are passing the address of the first data byte in the string; passing a string by reference means you are passing the memory address where another address is stored; the second address actually refers to the first data byte of the string. How you determine which approach to use is explained in the topic "Passing Strings to a DLL Procedure" later in this chapter.
From Visual Basic Concepts in Help.

How to represent 64-bit integer in VB6?

I am having to augment a legacy app to handle 64-bit integers. However, VB6 doesn't have a data type for that. The recommendation online that I've found has been to use the Currency data type.
However, I've found that I am running into some overflow issues.
Example - Results in Overflow during CCur call:
dim c as currency
' set maximum value of int64
c = CCur("9223372036854775807")
However, if I apply a smaller number (but still much larger than int32), it does work:
dim c as currency
' Remove the last 4 digits
c = CCur("922337203685477")
So what am I missing here? How can I handle a 64-bit value?
The only thing that I need to do with the 64-bit values is to read them from a SQL Server stored procedure (it comes as sql type bigint) and then display it to the form.
ADO Field.Value is type Variant. When you retrieve an adBigInt in VB6 the Variant will be of subtype Decimal.
You can use Variant datatype with CDec() conversion.
dim c as variant
' set maximum value of int64
c = CDec("9223372036854775807")
Now you can even use standard vb6 math operations, or string conversion functions on c.
Dim c As Variant, d As Variant
c = CDec("9223372036854775807")
Dim i As Integer
i = 1000
d = 10
Debug.Print c + i
Debug.Print c / d
Debug.Print CStr(c)
Results
9223372036854776807
922337203685477580,7
9223372036854775807
Just be aware that Decimal type Variant is wider than 64 bits, so you don't get the 'Overflow' on the server side :)
The answer is, it depends on what you're going to do with the 64 bit value. If you simply want to hold a value without doing any arithmetic on it, then it may be better to create a byte array or long array. For example:
Dim SixtFourBit(7) As Byte
or
Dim SixtyFourBit(1) As Long
Using the currency type is a simpler solution since you can apply arithmetic to it. But the Currency type is a fixed format representation, always having four decimal places. That means the lower bytes of the 64 bit representation go to make up the fractional part of the Currency value (sort of).
To coerce between Currency and arrays use the devilish CopyMemory windows API function:
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Integer)
Sub SomeFunction()
Dim AnArray(7) As Byte
Dim ACurrency as Currency
ACurrency = 123.4567
CopyMemory AnArray(0), VarPtr(ACurrency), 8&
' Inspecting AnArray in the watch window will show you the byte representation of ACurrency
End Sub
With the caveat, that this sort of trickery is to be generally avoided. Incorrect use of CopyMemory can kill your program.
VB6 can be used with variant type of I8 to provide a 64-bit signed integer. (UI8 does not work with VB6). There are some limitations, for example TypeName does not work, whilst VarType does.
Example of function cInt64 to create a 64-bit integer variant which first creates a decimal variant then converts this to an I8 variant:
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Enum VARENUM
VT_I8 = &H14
End Enum ' } VARENUM;
Private Type Dec_Hdr
DecType As Integer
DecScale As Byte
DecSign As Byte
End Type
Function cInt64(v As Variant) As Variant
Dim DecHdr As Dec_Hdr
cInt64 = CDec(v) ' first create a Decimal Variant
CopyMemory DecHdr, ByVal VarPtr(cInt64), Len(DecHdr)
'Correct possible CDec conversion errors with Hex strings
If VarType(v) = vbString Then
If InStr(1, v, "&h", vbTextCompare) = 1 Then DecHdr.DecSign = 0
End If
'Remove any decimal places
If DecHdr.DecScale Then cInt64 = Fix(cInt64)
'Convert Decimal to Int64, setting sign and scale to zero
CopyMemory ByVal VarPtr(cInt64), CLng(VT_I8), 4
'Adjust for Decimal Sign
If (DecHdr.DecSign <> 0) And (cInt64 > 0) Then cInt64 = -cInt64
'Finally check variant is of type I8
If (VarType(cInt64) <> VT_I8) Then Err.Raise 6
End Function

Change datatype from char to int in VBSCRIPT

Hi I need your help guys!
I am new to the system I am using and I am working on customizing a report that uses crystal report,
I need to get the value of the last page and compare this to the current page
(CurrentPage <> LastPage) , yet the data type of the Last Page is set to string/char..
I guess this is the reason why I can't get the result on the condition above. is there any way to change
its data type to Integer? or is there other way to get the LastPage integer value from a crystal reports without using the set variables for last page?
Thank You.
Remember that ALL textbox values is always a string value no matter of the content.
'Private Sub TextBox1_Change()
Dim IntValue As Integer
If TextBox1.TextLength > 0 Then
IntValue = TextBox1 * 1 ' method 1
'IntValue = TextBox1 + 1 - 1 ' method 2
'IntValue = TextBox1 + 0 ' method 3
MsgBox "IntValue = " & IntValue
End If
End Sub'
CInt specifies the integer datatype. VBScript normally autoconverts.
I have a different user id so ihave to reply here. This is a variant,
struct tagVARIANT {
VARTYPE vt;
WORD wReserved1;
WORD wReserved2;
WORD wReserved3;
union {
// C++ Type Union Name Type Tag Basic Type
// -------- ---------- -------- ----------
long lVal; // VT_I4 ByVal Long
unsigned char bVal; // VT_UI1 ByVal Byte
short iVal; // VT_I2 ByVal Integer
float fltVal; // VT_R4 ByVal Single
double dblVal; // VT_R8 ByVal Double
VARIANT_BOOL boolVal; // VT_BOOL ByVal Boolean
SCODE scode; // VT_ERROR
CY cyVal; // VT_CY ByVal Currency
DATE date; // VT_DATE ByVal Date
BSTR bstrVal; // VT_BSTR ByVal String
IUnknown *punkVal; // VT_UNKNOWN
IDispatch *pdispVal; // VT_DISPATCH ByVal Object
SAFEARRAY *parray; // VT_ARRAY|* ByVal array
// A bunch of other types that don't matter here...
VARIANT *pvarVal; // VT_BYREF|VT_VARIANT ByRef Variant
void * byref; // Generic ByRef
};
};
Variants normally autoconvert, need a string it changes to a string.
This is one OLE function (and probably what VB uses)
HRESULT VariantChangeType(VARIANT * pvDst, VARIANT * pvSrc, WORD wFlags, VARTYPE vt);
This function changes the type of a VARIANT without changing its value (if possible). To change a variable in place, make the destination the same as the source.
CInt forces it to be an integer, even if vbscript think it should be something else.
So a string containing 52 will be an integer if you try and add another number to it.
Also in basic a int is 16 bit and a long is 32 bit for compatability with 16 bit VB.

Check if picturebox contains an image

Is there any built-in method of PictureBox compontent to check if a certain portion of its content matches another PictureBox's content? e.g:
I know I can do it by comparing each individual pixel's color with PictureBox's Point(X,Y) Method, but that seems a bit overkill to me. Not to mention it would probably be way too slow.
You can compare each pixel faster by accessing the picture's memory.
It's very easy and fast, I wrote a 2D game engine using this way when I was a new VB6 programmer. My 2D Game Engine (yLib)
All the things you got to do is that get the first pixel's address.
The below function do the job for you:
module1:
Public Declare Function VarPtrArray Lib "msvbvm60" Alias "VarPtr" (Ptr() As Any) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
Public Declare Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" (destination As Any, ByVal Length As Long)
Public Type SAFEARRAYBOUND
cElements As Long
lLbound As Long
End Type
Public Type SAFEARRAY2D
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As Long
Bounds(0 To 1) As SAFEARRAYBOUND
End Type
Public Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
Public Type Picture
pic As STDPicture
c() As Byte
bmp As BITMAP
SA As SAFEARRAY2D
End Type
Public Type lyPicture
pic As STDPicture
c() As Byte
bmp As BITMAP
SA As SAFEARRAY2D
End Type
main form or module:
Private Sub LoadPicArray2D(val As lyPicture)
' get bitmap info from image box
Call GetObjectAPI(val.pic, Len(val.bmp), val.bmp) 'dest
' exit if not 24-bit bitmap
' make the local matrix point to bitmap pixels
If val.bmp.bmPlanes 1 Or val.bmp.bmBitsPixel 24 Or val.bmp.bmWidthBytes / val.bmp.bmWidth 3 Then
Call Err.Raise(500, "Only 24-bit bitmaps.", "Only 24-bit bitmaps.")
End If
With val.SA
.cbElements = 1
.cDims = 2
.Bounds(0).lLbound = 0
.Bounds(0).cElements = val.bmp.bmHeight
.Bounds(1).lLbound = 0
.Bounds(1).cElements = val.bmp.bmWidthBytes
.pvData = val.bmp.bmBits
End With
Call CopyMemory(ByVal VarPtrArray(val.c()), VarPtr(val.SA), 4)
End Sub
Public Sub Main()
Dim pic As lyPicture
Set pic.pic = Form1.TargetPictureBox.Picture
Call LoadPicArray2D(pic)
'Just remember that the picture's memory stored top-down this mean the
' upper pixel lays in lower array bound.
' but the array is correct in horizontal arrangement.
' And the array is formated BGR pic.c(0,0) = B , pic.c(1,0) = G, pic.c(2,0) = R
pic.c(0,0) = 0 ' the pixel at the left bottom (0, MAX_PICTURE_HEIGHT-1) of the picture.
pic.c(0,MAX_PICTURE_HEIGHT-1) = 0 ' the pixel at (0, 0)
' This is very IMPORTANT to release the array at the end of the code.
Call ZeroMemory(ByVal VarPtrArray(val.c()), 4)
' I dont tested this code just copied from my game engine. :D
End Sub

VB6: Slow Binary Write?

Wondering why a particular binary write operation in VB is so slow. The function reads a Byte array from memory and dumps it into a file like this:
Open Destination For Binary Access Write As #1
Dim startP, endP As Long
startP = BinaryStart
endP = UBound(ReadBuf) - 1
Dim i as Integer
For i = startP To endP
DoEvents
Put #1, (i - BinaryStart) + 1, ReadBuf(i)
Next
Close #1
For two megabytes on a slower system, this can take up to a minute. Can anyone tell me why this is so slow?
Edit: The reason for choosing VB6 is that it runs on 100% of our target platforms as a single EXE, without any separate dependencies (except VBRUN, which is on pretty much everything).
Well, are you reading and writing each byte 1 by one? In that case you are iterating through 2 million elements instead of just taking a chunk of data at a time and write it to the stream.
Take out the DoEvents call. If you're writing two megabytes of data one byte at a time, that loop has 2097152 DoEvents calls. That will really really slow down the process.
Dim startP, endP As Long -- here you declare startP as Variant and endP as Long.
DoEvents -- yields control to the OS, calling on each iteration makes virtually any loop endless.
And then, if you want to save a piece of an array to a file, that should be...
Hmm... What should it be then?
Option 1.
Declare another array to hold the piece, CopyMemory the data into it and put it into a file using a single Put:
Put #1, , arrName
That, however, may be not wise memory-wise.
Hence, Option 2.
Create an array that refers to the data in the big array. This way nothing will be allocated twice:
Dim bigArray(1 To 1000) As Byte
Dim chunk() As Byte
Dim i As Long
'Filling the array for test purposes
For i = LBound(bigArray) To UBound(bigArray)
bigArray(i) = Rnd * 254
Next
'Create an array that refers to 100 bytes from bigArray, starting from 500th
CreateSAFEARRAY ArrPtr(chunk), 1, VarPtr(bigArray(500)), 1, 100
Open "c:\1.txt" For Binary Access Write As #1
Put #1, , chunk
Close #1
'Always destroy it manually!
DestroySAFEARRAY ArrPtr(chunk)
This code requires the following helper functions (put in a separate module):
Option Explicit
Private Declare Function SafeArrayAllocDescriptor Lib "oleaut32" (ByVal cDims As Long, ppsaOut As Any) As Long
Private Declare Function SafeArrayDestroyDescriptor Lib "oleaut32" (psa As Any) As Long
Public Declare Function GetMem4 Lib "msvbvm60" (ByVal pSrc As Long, ByVal pDst As Long) As Long
Public Declare Function PutMem4 Lib "msvbvm60" (ByVal pDst As Long, ByVal NewValue As Long) As Long
Public Declare Function PutMem8 Lib "msvbvm60" (ByVal pDst As Long, ByVal NewValueLow As Long, ByVal NewValueHigh As Long) As Long
Private Const S_OK As Long = 0
Public Declare Function ArrPtr Lib "msvbvm60" Alias "VarPtr" (arr() As Any) As Long
Public Function CreateSAFEARRAY(ByVal ppBlankArr As Long, ByVal ElemSize As Long, ByVal pData As Long, ParamArray Bounds()) As Long
Dim i As Long
If (UBound(Bounds) - LBound(Bounds) + 1) Mod 2 Then Err.Raise 5, "SafeArray", "Bounds must contain even number of entries."
If SafeArrayAllocDescriptor((UBound(Bounds) - LBound(Bounds) + 1) / 2, ByVal ppBlankArr) <> S_OK Then Err.Raise 5
GetMem4 ppBlankArr, VarPtr(CreateSAFEARRAY)
PutMem4 CreateSAFEARRAY + 4, ElemSize
PutMem4 CreateSAFEARRAY + 12, pData
For i = LBound(Bounds) To UBound(Bounds) - 1 Step 2
If Bounds(i + 1) - Bounds(i) + 1 > 0 Then
PutMem8 CreateSAFEARRAY + 16 + (UBound(Bounds) - i - 1) * 4, Bounds(i + 1) - Bounds(i) + 1, Bounds(i)
Else
SafeArrayDestroyDescriptor ByVal CreateSAFEARRAY
CreateSAFEARRAY = 0
PutMem4 ppBlankArr, 0
Err.Raise 5, , "Each dimension must contain at least 1 element"
End If
Next
End Function
Public Function DestroySAFEARRAY(ByVal ppArray As Long) As Long
GetMem4 ppArray, VarPtr(DestroySAFEARRAY)
If SafeArrayDestroyDescriptor(ByVal DestroySAFEARRAY) <> S_OK Then Err.Raise 5
PutMem4 ppArray, 0
DestroySAFEARRAY = 0
End Function

Resources