?? modparsers.bas
字號:
Public Function iparseIsArrayEmpty(ByVal lArrayPointer As Long) As Boolean
' test to see if an array has been initialized
iparseIsArrayEmpty = (lArrayPointer = -1&)
End Function
Public Function iparseByteAlignOnWord(ByVal bitDepth As Byte, ByVal Width As Long) As Long
' function to align any bit depth on dWord boundaries
iparseByteAlignOnWord = (((Width * bitDepth) + &H1F&) And Not &H1F&) \ &H8&
End Function
Public Function iparseArrayToPicture(inArray() As Byte, Offset As Long, Size As Long) As IPicture
' function creates a stdPicture from the passed array
' Note: The array was already validated as not empty when calling class' LoadStream was called
Dim o_hMem As Long
Dim o_lpMem As Long
Dim aGUID(0 To 3) As Long
Dim IIStream As IUnknown
aGUID(0) = &H7BF80980 ' GUID for stdPicture
aGUID(1) = &H101ABF32
aGUID(2) = &HAA00BB8B
aGUID(3) = &HAB0C3000
o_hMem = GlobalAlloc(&H2&, Size)
If Not o_hMem = 0& Then
o_lpMem = GlobalLock(o_hMem)
If Not o_lpMem = 0& Then
CopyMemory ByVal o_lpMem, inArray(Offset), Size
Call GlobalUnlock(o_hMem)
If CreateStreamOnHGlobal(o_hMem, 1&, IIStream) = 0& Then
Call OleLoadPicture(ByVal ObjPtr(IIStream), 0&, 0&, aGUID(0), iparseArrayToPicture)
End If
End If
End If
End Function
Public Function iparseHandleToStdPicture(ByVal hImage As Long, ByVal imgType As Long) As IPicture
' function creates a stdPicture object from a image handle (bitmap or icon)
Dim lpPictDesc As PictDesc, aGUID(0 To 3) As Long
With lpPictDesc
.Size = Len(lpPictDesc)
.Type = imgType
.hHandle = hImage
.hPal = 0
End With
' IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
aGUID(0) = &H7BF80980
aGUID(1) = &H101ABF32
aGUID(2) = &HAA00BB8B
aGUID(3) = &HAB0C3000
' create stdPicture
Call OleCreatePictureIndirect(lpPictDesc, aGUID(0), True, iparseHandleToStdPicture)
End Function
Public Function iparseReverseLong(ByVal inLong As Long) As Long
' fast function to reverse a long value from big endian to little endian
' PNG files contain reversed longs
Dim b1 As Long
Dim b2 As Long
Dim b3 As Long
Dim b4 As Long
Dim lHighBit As Long
lHighBit = inLong And &H80000000
If lHighBit Then
inLong = inLong And Not &H80000000
End If
b1 = inLong And &HFF
b2 = (inLong And &HFF00&) \ &H100&
b3 = (inLong And &HFF0000) \ &H10000
If lHighBit Then
b4 = inLong \ &H1000000 Or &H80&
Else
b4 = inLong \ &H1000000
End If
If b1 And &H80& Then
iparseReverseLong = ((b1 And &H7F&) * &H1000000 Or &H80000000) Or _
b2 * &H10000 Or b3 * &H100& Or b4
Else
iparseReverseLong = b1 * &H1000000 Or _
b2 * &H10000 Or b3 * &H100& Or b4
End If
End Function
Public Function iparseFileExists(FileName As String) As Boolean
' test to see if a file exists
iparseFileExists = (Len(Dir$(FileName, vbArchive Or vbHidden Or vbReadOnly Or vbSystem)) > 0)
End Function
Public Function iparseValidateDLL(ByVal DllName As String, ByVal dllProc As String) As Boolean
' PURPOSE: Test a DLL for a specific function.
Dim LB As Long, pa As Long
'attempt to open the DLL to be checked
LB = LoadLibrary(DllName)
If LB Then
'if so, retrieve the address of one of the function calls
pa = GetProcAddress(LB, dllProc)
' free references
FreeLibrary LB
End If
iparseValidateDLL = (Not (LB = 0 Or pa = 0))
End Function
Public Function iparseValidateZLIB(ByRef DllName As String, ByRef Version As Long, _
ByRef isCDECL As Boolean, ByRef hasCompression2 As Boolean, _
Optional ByVal bTestOnly As Boolean) As Boolean
' PURPOSE: Test ZLib availability and calling convention.
' About zLIB. There are several versions ranging from v1.2.3 (latest) to v1.0.? (earliest).
' Zlib is used to compress/decompress PNG files, among other things.
' However, zLIB is written with C calling convention (cdecl) which is unusable with VB. There
' are other modified versions out there that were converted to stdcall calling convention which
' is what VB expects. But, we don't know the calling convention of the zLIB in advance, do we?
' Allowing VB to call cdecl directly results in crashes or invalid function returns. The class
' cCDECL is one created by Paul Caton that uses assembly to "wrap" the cdecl call into a stdcall.
' But we still need to know the calling convention so we know to use cCDECL or simple API calls.
Dim LB As Long, pa As Long
Dim asmVal As Integer
DllName = "zlib1.dll" ' test for newer version first
For Version = 2& To 1& Step -1&
LB = LoadLibrary(DllName) 'attempt to open the DLL to be checked
If LB Then
hasCompression2 = Not (GetProcAddress(LB, "compress2") = 0)
pa = GetProcAddress(LB, "crc32") ' retrieve the address of the "crc32" exported function
If Not pa = 0& Then
If bTestOnly Then Exit For
Do
' Note: this method will not work for every DLL, nor every function within a DLL.
' I have analyzed 5 versions of zlib (some cdecl, some stdcall) using disassemblers
' and am confident this will work for the crc32 function in all versions.
' Looking for an exit code:
CopyMemory asmVal, ByVal pa, 1&
Select Case asmVal
Case &HC3 ' exit code, no stack clean up
isCDECL = True ' DLL uses cdecl calling convention, we use cCDECL
Exit For
Case &HC2
CopyMemory asmVal, ByVal pa + 1&, 2&
If asmVal = &HC Then ' exit code with clean up of 12 bytes (the 3 crc32 parameters)
isCDECL = False ' DLL uses stdcall calling convention, we use APIs
Exit For
End If
End Select
pa = pa + 1&
Loop
End If
' unmap library
FreeLibrary LB
LB = 0&
hasCompression2 = False
End If
DllName = "zlib.dll" ' test for older version next, if necessary
Next Version
If Not LB = 0& Then FreeLibrary LB
iparseValidateZLIB = (Not (Version = 0&))
End Function
Public Sub iparseValidateAlphaChannel(inStream() As Byte, bPreMultiply As Boolean, bIsAlpha As Boolean, imgType As Long)
' Purpose: Modify 32bpp DIB's alpha bytes depending on whether or not they are used
' Parameters
' inStream(). 2D array overlaying the DIB to be checked
' bPreMultiply. If true, image will be premultiplied if not already
' bIsAlpha. Returns whether or not the image contains transparency
' imgType. If passed as -1 then image is known to be not alpha, but will have its alpha values set to 255
' When routine returns, imgType is either imgBmpARGB, imgBmpPARGB or imgBitmap
Dim X As Long, Y As Long
Dim lPARGB As Long, zeroCount As Long
Dim bPARGB As Boolean, bAlpha As Boolean
' see if the 32bpp is premultiplied or not and if it is alpha or not
If Not imgType = -1 Then
For Y = 0 To UBound(inStream, 2)
For X = 3 To UBound(inStream, 1) Step 4
Select Case inStream(X, Y)
Case 0
If lPARGB = 0 Then
' zero alpha, if any of the RGB bytes are non-zero, then this is not pre-multiplied
If Not inStream(X - 1, Y) = 0 Then
lPARGB = 1 ' not premultiplied
ElseIf Not inStream(X - 2, Y) = 0 Then
lPARGB = 1
ElseIf Not inStream(X - 3, Y) = 0 Then
lPARGB = 1
End If
' but don't exit loop until we know if any alphas are non-zero
End If
zeroCount = zeroCount + 1 ' helps in decision factor at end of loop
Case 255
' no way to indicate if premultiplied or not, unless...
If lPARGB = 1 Then
lPARGB = 2 ' not pre-multiplied because of the zero check above
Exit For
End If
Case Else
' if any Exit For's below get triggered, not pre-multiplied
If lPARGB = 1 Then
lPARGB = 2: Exit For
ElseIf inStream(X - 3, Y) > inStream(X, Y) Then
lPARGB = 2: Exit For
ElseIf inStream(X - 2, Y) > inStream(X, Y) Then
lPARGB = 2: Exit For
ElseIf inStream(X - 1, Y) > inStream(X, Y) Then
lPARGB = 2: Exit For
End If
End Select
Next
If lPARGB = 2 Then Exit For
Next
' if we got all the way thru the image without hitting Exit:For then
' the image is not alpha unless the bAlpha flag was set in the loop
If zeroCount = (UBound(inStream, 1) + 1) * (UBound(inStream, 2) + 1) Then ' every alpha value was zero
bPARGB = False: bAlpha = False ' assume RGB, else 100% transparent ARGB
' also if lPARGB=0, then image is completely black
imgType = vbPicTypeBitmap
Else
Select Case lPARGB
Case 2: bPARGB = False: bAlpha = True ' 100% positive ARGB
Case 1: bPARGB = False: bAlpha = True ' now 100% positive ARGB
Case 0: bPARGB = True: bAlpha = True
End Select
End If
End If
' see if caller wants the non-premultiplied alpha channel premultiplied
If bAlpha = True Then
If bPARGB Then ' else force premultiplied
imgType = imgBmpPARGB
Else
imgType = imgBmpARGB
If bPreMultiply = True Then
For Y = 0 To UBound(inStream, 2)
For X = 3 To UBound(inStream, 1) Step 4
If inStream(X, Y) = 0 Then
CopyMemory inStream(X - 3, Y), 0&, &H4
ElseIf Not inStream(X, Y) = 255 Then
For lPARGB = X - 3 To X - 1
inStream(lPARGB, Y) = ((0& + inStream(lPARGB, Y)) * inStream(X, Y)) \ &HFF
Next
End If
Next
Next
bAlpha = True
End If
End If
Else
If bPreMultiply = True Then
For Y = 0 To UBound(inStream, 2)
For X = 3 To UBound(inStream, 1) Step 4
inStream(X, Y) = 255
Next
Next
End If
End If
bIsAlpha = bAlpha
End Sub
?? 快捷鍵說明
復制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號
Ctrl + =
減小字號
Ctrl + -