'Download:http://www.codefans.net Option ExplicitPublic Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hdc As Long, graphics As Long) As GpStatus Public Declare Function GdipCreateFromHWND Lib "gdiplus" (ByVal hwnd As Long, graphics As Long) As GpStatus Public Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal graphics As Long) As GpStatus Public Declare Function GdipGetDC Lib "gdiplus" (ByVal graphics As Long, hdc As Long) As GpStatus Public Declare Function GdipReleaseDC Lib "gdiplus" (ByVal graphics As Long, ByVal hdc As Long) As GpStatus Public Declare Function GdipDrawImageRect Lib "gdiplus" (ByVal graphics As Long, ByVal image As Long, ByVal x As Single, ByVal y As Single, ByVal Width As Single, ByVal Height As Single) As GpStatus Public Declare Function GdipLoadImageFromFile Lib "gdiplus" (ByVal filename As String, image As Long) As GpStatus Public Declare Function GdipCloneImage Lib "gdiplus" (ByVal image As Long, cloneImage As Long) As GpStatus Public Declare Function GdipGetImageWidth Lib "gdiplus" (ByVal image As Long, Width As Long) As GpStatus Public Declare Function GdipGetImageHeight Lib "gdiplus" (ByVal image As Long, Height As Long) As GpStatus Public Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As Long, ByVal hpal As Long, bitmap As Long) As GpStatus Public Declare Function GdipBitmapGetPixel Lib "gdiplus" (ByVal bitmap As Long, ByVal x As Long, ByVal y As Long, color As Long) As GpStatus Public Declare Function GdipBitmapSetPixel Lib "gdiplus" (ByVal bitmap As Long, ByVal x As Long, ByVal y As Long, ByVal color As Long) As GpStatus Public Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As GpStatus Public Declare Function GdipCreateBitmapFromFile Lib "gdiplus" (ByVal filename As Long, bitmap As Long) As GpStatusPublic Declare Function ReleaseCapture Lib "user32" () As Long Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As LongPublic Const HTCAPTION = 2 Public Const WM_NCLBUTTONDOWN = &HA1 Public Const WM_SYSCOMMAND = &H112Public Type GdiplusStartupInput GdiplusVersion As Long DebugEventCallback As Long SuppressBackgroundThread As Long SuppressExternalCodecs As Long End TypePublic Declare Function GdiplusStartup Lib "gdiplus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As GpStatus Public Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal token As Long)Public Enum GpStatus Ok = 0 GenericError = 1 InvalidParameter = 2 OutOfMemory = 3 ObjectBusy = 4 InsufficientBuffer = 5 NotImplemented = 6 Win32Error = 7 WrongState = 8 Aborted = 9 FileNotFound = 10 ValueOverflow = 11 AccessDenied = 12 UnknownImageFormat = 13 FontFamilyNotFound = 14 FontStyleNotFound = 15 NotTrueTypeFont = 16 UnsupportedGdiplusVersion = 17 GdiplusNotInitialized = 18 PropertyNotFound = 19 PropertyNotSupported = 20 End Enum
类模块第一部分:Option Explicit'**************************************************************************** '人人为我,我为人人 '枕善居汉化收藏整理 '发布日期:05/04/18 '描 述:打开并显示PNG图片的源码 '网 站:http://www.mndsoft.com/blog/ 'e-mail:[email protected] 'OICQ : 88382850 '**************************************************************************** Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) Private Declare Function SetDIBitsToDevice Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As Any, ByVal wUsage As Long) As Long Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal XSrc As Long, ByVal YSrc As Long, ByVal dwRop As Long) As Long Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As Any, ByVal wUsage As Long) As Long Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Sub FillMemory Lib "kernel32.dll" Alias "RtlFillMemory" (Destination As Any, ByVal Length As Long, ByVal Fill As Byte) Private Type BITMAPINFOHEADER Size As Long Width As Long Height As Long Planes As Integer BitCount As Integer Compression As Long SizeImage As Long XPelsPerMeter As Long YPelsPerMeter As Long ClrUsed As Long ClrImportant As Long End Type Private RBD As Long Private IDATData() As Byte Dim IdataLen As Long Private Type IHDR Width As Long Height As Long BitDepth As Byte ColorType As Byte Compression As Byte Filter As Byte Interlacing As Byte End Type 'For Decompression: Private Type CodesType Lenght() As Long code() As Long End Type Private m_Backcolor As Long Private Palettenbyte() As Byte Private OutStream() As Byte Private OutPos As Long Private InStream() As Byte Private Inpos As Long Private ByteBuff As Long Private BitNum As Long Private BitMask(16) As Long Private Pow2(16) As Long Private LC As CodesType Private dc As CodesType Private LitLen As CodesType Private Dist As CodesType Private TempLit As CodesType Private TempDist As CodesType Private LenOrder(18) As Long Private MinLLenght As Long Private MaxLLenght As Long Private MinDLenght As Long Private MaxDLenght As Long Private IsStaticBuild As Boolean Private BPPprivat As Long Private m_width As Long Private m_height As Long Private m_bitdepht As Long Private m_colortype As Long Private m_compression As Long Private m_filter As Long Private m_interlacing As Long Private m_ErrorNumber As Long Private m_sAlpha As Boolean Private m_hAlpha As Boolean Private trns() As Byte Private m_hTrans As Boolean Private m_sTrans As Boolean Private Colorused As Long Private bkgd() As Byte Private m_hbkgd As Boolean Private m_bkgdColor As Long Private m_text As String Private m_Time As String Private m_ztext As String Private m_gama As Long Private m_Bgx As Long Private m_Bgy As Long Private m_BGPic As Object Private m_OwnBkgnd As Boolean Private m_OBCol As Long Private m_PicBox As Object Private m_settoBG As BooleanPublic Function OpenPNG(filename As String) As Long Dim Stand As Long Dim Ende As Boolean Dim Filenumber As Long Dim Signature(7) As Byte Dim Test As Long Dim Lge As Long Dim ChunkName As String * 4 Dim ChunkInhalt() As Byte Dim CRC32Inhalt As Long Dim Teststring As String 'Dim crc32test As New clsCRC Dim TestCRC32 As Long Dim Testint As Integer m_hbkgd = False m_hTrans = False BPPprivat = 0 ReDim IDATData(0) IdataLen = 0 Filenumber = FreeFile Open filename For Binary As Filenumber Get Filenumber, , Signature Test = IsValidSignature(Signature) If Test <> -1 Then m_ErrorNumber = 1 Exit Function End If Do While Ende = False Get Filenumber, , Lge SwapBytesLong Lge Get Filenumber, , ChunkName If Lge > 0 Then ReDim ChunkInhalt(Lge - 1) Stand = Seek(Filenumber) If Stand + Lge > LOF(Filenumber) Then m_ErrorNumber = 3 Exit Function End If Get Filenumber, , ChunkInhalt Get Filenumber, , CRC32Inhalt 'SwapBytesLong CRC32Inhalt 'teststring = ChunkName & StrConv(ChunkInhalt, vbUnicode) 'Testcrc32 = CRC32(teststring) 'reiner VB-Code 'crc32test.Algorithm = 1 'TestCRC32 = crc32test.CalculateString(teststring) 'VB und Assembler 'If CRC32Inhalt <> 0 Then 'If CRC32Inhalt <> TestCRC32 Then 'MsgBox "Bad crc32" 'm_ErrorNumber = 2 'Exit Function 'End If 'End If Select Case ChunkName Case "IHDR" ReadIHDR ChunkInhalt Case "PLTE" ReDim Palettenbyte(UBound(ChunkInhalt)) CopyMemory Palettenbyte(0), ChunkInhalt(0), UBound(ChunkInhalt) + 1 Case "IDAT" ReDim Preserve IDATData(IdataLen + UBound(ChunkInhalt)) CopyMemory IDATData(IdataLen), ChunkInhalt(0), UBound(ChunkInhalt) + 1 IdataLen = UBound(IDATData) + 1 Case "IEND" Ende = True Case "bKGD" bkgd = ChunkInhalt ReadBkgd m_hbkgd = True Case "cHRM" Case "oFFs" Case "pCaL" Case "sCAL" Case "gAMA" CopyMemory ByVal VarPtr(m_gama), ChunkInhalt(0), 4 SwapBytesLong m_gama Case "hIST" Case "pHYs" Case "sBIT" Case "tEXt" m_text = m_text & StrConv(ChunkInhalt, vbUnicode) & Chr(0) Case "zTXt" DecompressText ChunkInhalt Case "gIFg" Case "gIFx" Case "tIME" CopyMemory ByVal VarPtr(Testint), ChunkInhalt(0), 2 Swap Testint m_Time = Format(ChunkInhalt(3), "00") & "." & Format(ChunkInhalt(2), "00") & "." & Testint & " " & Format(ChunkInhalt(4), "00") & ":" & Format(ChunkInhalt(5), "00") & ":" & Format(ChunkInhalt(6), "00") Case "tRNS" m_hTrans = True trns = ChunkInhalt Case "cTXt" Case Else 'If Asc(Left(ChunkName, 1)) > 65 Then Exit Function 'kritischer Chunk End Select Loop If IdataLen = 0 Then m_ErrorNumber = 4 Exit Function End If Close Filenumber MakePicture End Function
类模块第二部分:Private Function IsValidSignature(Signature() As Byte) As Boolean If Signature(0) <> 137 Then Exit Function If Signature(1) <> 80 Then Exit Function If Signature(2) <> 78 Then Exit Function If Signature(3) <> 71 Then Exit Function If Signature(4) <> 13 Then Exit Function If Signature(5) <> 10 Then Exit Function If Signature(6) <> 26 Then Exit Function If Signature(7) <> 10 Then Exit Function IsValidSignature = True End Function Private Sub SwapBytesLong(ByteValue As Long) Dim ergabe As Long Dim i As Long For i = 0 To 3 CopyMemory ByVal VarPtr(ergabe) + i, ByVal VarPtr(ByteValue) + (3 - i), 1 Next i ByteValue = ergabe End Sub Private Sub ReadIHDR(Bytefeld() As Byte) Dim Header As IHDR CopyMemory ByVal VarPtr(Header), Bytefeld(0), 13 SwapBytesLong Header.Width SwapBytesLong Header.Height m_width = Header.Width m_height = Header.Height m_bitdepht = Header.BitDepth m_colortype = Header.ColorType m_compression = Header.Compression m_filter = Header.Filter m_interlacing = Header.Interlacing End Sub Public Property Get Width() As Long Width = m_width End Property Public Property Get Height() As Long Height = m_height End Property Public Property Get Bitdepht() As Long Bitdepht = m_bitdepht End Property Public Property Get ColorType() As Long ColorType = m_colortype End Property Public Property Get Compression() As Long Compression = m_compression End Property Public Property Get Filter() As Long Filter = m_filter End Property Public Property Get Interlacing() As Long Interlacing = m_interlacing End Property Private Sub MakePicture() Dim DataSize As Long Dim Buffer() As Byte Dim BitCount As Integer Dim Bitdepht As Long Dim Drehen As Integer m_hAlpha = False Drehen = 1 Select Case Me.Interlacing Case 0 DataSize = DataPerRow * Me.Height Case 1 DataSize = (DataPerRow * Me.Height) + Me.Height End Select ReDim Buffer(UBound(IDATData) - 2) CopyMemory Buffer(0), IDATData(2), UBound(IDATData) - 1 Select Case Me.Compression Case 0 Decompress Buffer, DataSize End Select Select Case Me.Interlacing Case 0 Buffer = DeFilter(Buffer) Drehen = 1 Case 1 Buffer = DeFilterInterlaced(Buffer) Drehen = 0 End Select BitCount = Me.Bitdepht Select Case Me.ColorType Case 0 'Grayscale Select Case Me.Bitdepht Case 16 Conv16To8 Buffer InitColorTable_Grey 8 BitCount = 8 BPPprivat = 8 Case 8, 4, 1 Select Case Interlacing Case 0 BitCount = Me.Bitdepht InitColorTable_Grey Me.Bitdepht, False Align32 BitCount, Buffer Case Else BitCount = 8 InitColorTable_Grey Me.Bitdepht, True End Select Case 2 InitColorTable_Grey 2 If Me.Interlacing = 0 Then Pal2To8 Me.Width, Me.Height, Buffer, DataPerRow End If BitCount = 8 BPPprivat = 8 End Select If m_hTrans And m_sTrans Then If Me.Bitdepht <> 2 Then Align32 BitCount, Buffer End If PalToRGBA Me.Width, Me.Height, BitCount, Buffer BitCount = 32 BPPprivat = 32 MakeAlpha m_BGPic, Buffer, m_Bgx, m_Bgy BitCount = 24 BPPprivat = 24 End If Case 2 'RGB If Me.Bitdepht = 16 Then Conv16To8 Buffer BitCount = 24 BPPprivat = 24 ReverseRGB Buffer Drehen = 1 BPPprivat = 8 Align32 BitCount, Buffer BPPprivat = 24 If m_hTrans And m_sTrans Then MakeRGBTransparent Buffer MirrorData Buffer, Me.Width * 4 Drehen = 0 BitCount = 32 BPPprivat = 32 MakeAlpha m_BGPic, Buffer, m_Bgx, m_Bgy BitCount = 24 BPPprivat = 24 End If Case 3 'Palette Select Case Me.Bitdepht Case 8, 4, 1 If Me.Interlacing = 1 Then BitCount = 8 BPPprivat = 8 Align32 BitCount, Buffer Else BitCount = Me.Bitdepht If BitCount >= 8 Then Align32 BitCount, Buffer End If End If Case 2 If Me.Interlacing = 0 Then Pal2To8 Me.Width, Me.Height, Buffer, DataPerRow BitCount = 8 BPPprivat = 8 Else BitCount = 8 BPPprivat = 8 Align32 BitCount, Buffer End If End Select If m_hTrans And m_sTrans Then If Me.Bitdepht <> 2 Then Align32 BitCount, Buffer End If PalToRGBA Me.Width, Me.Height, BitCount, Buffer BitCount = 32 BPPprivat = 32 MakeAlpha m_BGPic, Buffer, m_Bgx, m_Bgy BitCount = 24 BPPprivat = 24 End If Case 4 'Grayscale + Alpha m_hAlpha = True If Me.Bitdepht = 16 Then Conv16To8 Buffer GrayAToRGBA Buffer BPPprivat = 32 BitCount = 32 MirrorData Buffer, LineBytes(Me.Width, BitCount) Drehen = 0 If m_sAlpha = True Then MakeAlpha m_BGPic, Buffer, m_Bgx, m_Bgy BPPprivat = 24 BitCount = 24 End If Case 6 'RGB + Alpha m_hAlpha = True If Me.Bitdepht = 16 Then Conv16To8 Buffer BitCount = 32 BPPprivat = 32 ReverseRGBA Buffer MirrorData Buffer, LineBytes(Me.Width, BitCount) Drehen = 0 If m_sAlpha = True Then MakeAlpha m_BGPic, Buffer, m_Bgx, m_Bgy BPPprivat = 24 BitCount = 24 End If End Select If Not (((Me.ColorType = 3) And (BitCount = 32)) Or _ (Me.Bitdepht = 2)) Then Select Case Me.Bitdepht Case 16 Bitdepht = 8 Bitdepht = 16 End Select End If Select Case BitCount Case 1, 2, 4 Align32 BitCount, Buffer End Select Select Case BitCount Case 1 Select Case Me.ColorType Case 3 InitColorTable_1Palette Palettenbyte Case Else InitColorTable_1 End Select CreateBitmap_1 Buffer, Me.Width, Me.Height, True, Colorused DrawBitmap Me.Width, Me.Height, m_PicBox, True, m_Bgx, m_Bgy, m_settoBG Case 4 Select Case Me.ColorType Case 0 Case Else InitColorTable_4 Palettenbyte End Select CreateBitmap_4 Buffer, Me.Width, Me.Height, True, Colorused DrawBitmap Me.Width, Me.Height, m_PicBox, True, m_Bgx, m_Bgy, m_settoBG Case 8 Select Case Me.ColorType Case 0, 4 Case Else InitColorTable_8 Palettenbyte End Select Drehen = 1 CreateBitmap_8 Buffer, Me.Width, Me.Height, Drehen, Colorused DrawBitmap Me.Width, Me.Height, m_PicBox, True, m_Bgx, m_Bgy, m_settoBG Case 24 CreateBitmap_24 Buffer, Me.Width, Me.Height, Drehen, 1 DrawBitmap Me.Width, Me.Height, m_PicBox, True, m_Bgx, m_Bgy, m_settoBG Case 32 CreateBitmap_24 Buffer, Me.Width, Me.Height, Drehen DrawBitmap Me.Width, Me.Height, m_PicBox, True, m_Bgx, m_Bgy, m_settoBG End Select End Sub Private Function Decompress(ByteArray() As Byte, UncompressedSize As Long, Optional ZIP64 As Boolean = False) As Long Dim IsLastBlock As Boolean Dim CompType As Long Dim Char As Long Dim Nubits As Long Dim L1 As Long Dim L2 As Long Dim x As Long UncompressedSize = UncompressedSize + 100 InStream = ByteArray Call Init_Decompress(UncompressedSize) Do IsLastBlock = GetBits(1) CompType = GetBits(2) If CompType = 0 Then If Inpos + 4 > UBound(InStream) Then Decompress = -1 Exit Do End If Do While BitNum >= 8 Inpos = Inpos - 1 BitNum = BitNum - 8 Loop CopyMemory L1, InStream(Inpos), 2& CopyMemory L2, InStream(Inpos + 2), 2& Inpos = Inpos + 4 If L1 - (Not (L2) And &HFFFF&) Then Decompress = -2 If Inpos + L1 - 1 > UBound(InStream) Then Decompress = -1 Exit Do End If If OutPos + L1 - 1 > UBound(OutStream) Then Decompress = -1 Exit Do End If CopyMemory OutStream(OutPos), InStream(Inpos), L1 OutPos = OutPos + L1 Inpos = Inpos + L1 ByteBuff = 0 BitNum = 0 ElseIf CompType = 3 Then Decompress = -1 Exit Do Else If CompType = 1 Then If Create_Static_Tree <> 0 Then MsgBox "Error in tree creation (Static)" Exit Function End If Else If Create_Dynamic_Tree <> 0 Then MsgBox "Error in tree creation (Static)" Exit Function End If End If Do NeedBits MaxLLenght Nubits = MinLLenght Do While LitLen.Lenght(ByteBuff And BitMask(Nubits)) <> Nubits Nubits = Nubits + 1 Loop Char = LitLen.code(ByteBuff And BitMask(Nubits)) DropBits Nubits If Char < 256 Then OutStream(OutPos) = Char OutPos = OutPos + 1 ElseIf Char > 256 Then Char = Char - 257 L1 = LC.code(Char) + GetBits(LC.Lenght(Char)) If (L1 = 258) And ZIP64 Then L1 = GetBits(16) + 3 NeedBits MaxDLenght Nubits = MinDLenght Do While Dist.Lenght(ByteBuff And BitMask(Nubits)) <> Nubits Nubits = Nubits + 1 Loop Char = Dist.code(ByteBuff And BitMask(Nubits)) DropBits Nubits L2 = dc.code(Char) + GetBits(dc.Lenght(Char)) For x = 1 To L1 If OutPos > UncompressedSize Then OutPos = UncompressedSize GoTo Stop_Decompression End If OutStream(OutPos) = OutStream(OutPos - L2) OutPos = OutPos + 1 Next x End If Loop While Char <> 256 'EOB End If Loop While Not IsLastBlock Stop_Decompression: If OutPos > 0 Then ReDim Preserve OutStream(OutPos - 1) Else Erase OutStream End If Erase InStream Erase BitMask Erase Pow2 Erase LC.code Erase LC.Lenght Erase dc.code Erase dc.Lenght Erase LitLen.code Erase LitLen.Lenght Erase Dist.code Erase Dist.Lenght Erase LenOrder ByteArray = OutStream End Function
总算有人回帖了,我可以继续发,类第四部分:Private Function Create_Static_Tree() Dim x As Long Dim Lenght(287) As Long If IsStaticBuild = False Then For x = 0 To 143: Lenght(x) = 8: Next For x = 144 To 255: Lenght(x) = 9: Next For x = 256 To 279: Lenght(x) = 7: Next For x = 280 To 287: Lenght(x) = 8: Next If Create_Codes(TempLit, Lenght, 287, MaxLLenght, MinLLenght) <> 0 Then Create_Static_Tree = -1 Exit Function End If For x = 0 To 31: Lenght(x) = 5: Next Create_Static_Tree = Create_Codes(TempDist, Lenght, 31, MaxDLenght, MinDLenght) IsStaticBuild = True Else MinLLenght = 7 MaxLLenght = 9 MinDLenght = 5 MaxDLenght = 5 End If LitLen = TempLit Dist = TempDist End Function Private Function Create_Dynamic_Tree() As Long Dim Lenght() As Long Dim Bl_Tree As CodesType Dim MinBL As Long Dim MaxBL As Long Dim NumLen As Long Dim Numdis As Long Dim NumCod As Long Dim Char As Long Dim Nubits As Long Dim LN As Long Dim Pos As Long Dim x As Long NumLen = GetBits(5) + 257 Numdis = GetBits(5) + 1 NumCod = GetBits(4) + 4 ReDim Lenght(18) For x = 0 To NumCod - 1 Lenght(LenOrder(x)) = GetBits(3) Next For x = NumCod To 18 Lenght(LenOrder(x)) = 0 Next If Create_Codes(Bl_Tree, Lenght, 18, MaxBL, MinBL) <> 0 Then Create_Dynamic_Tree = -1 Exit Function End If ReDim Lenght(NumLen + Numdis) Pos = 0 Do While Pos < NumLen + Numdis NeedBits MaxBL Nubits = MinBL Do While Bl_Tree.Lenght(ByteBuff And BitMask(Nubits)) <> Nubits Nubits = Nubits + 1 Loop Char = Bl_Tree.code(ByteBuff And BitMask(Nubits)) DropBits Nubits If Char < 16 Then Lenght(Pos) = Char Pos = Pos + 1 Else If Char = 16 Then If Pos = 0 Then Create_Dynamic_Tree = -5 Exit Function End If LN = Lenght(Pos - 1) Char = 3 + GetBits(2) ElseIf Char = 17 Then Char = 3 + GetBits(3) LN = 0 Else Char = 11 + GetBits(7) LN = 0 End If If Pos + Char > NumLen + Numdis Then Create_Dynamic_Tree = -6 Exit Function End If Do While Char > 0 Char = Char - 1 Lenght(Pos) = LN Pos = Pos + 1 Loop End If Loop If Create_Codes(LitLen, Lenght, NumLen - 1, MaxLLenght, MinLLenght) <> 0 Then Create_Dynamic_Tree = -1 Exit Function End If For x = 0 To Numdis Lenght(x) = Lenght(x + NumLen) Next Create_Dynamic_Tree = Create_Codes(Dist, Lenght, Numdis - 1, MaxDLenght, MinDLenght) End Function Private Function Create_Codes(tree As CodesType, Lenghts() As Long, NumCodes As Long, MaxBits As Long, Minbits As Long) As Long Dim Bits(16) As Long Dim next_code(16) As Long Dim code As Long Dim LN As Long Dim x As Long Minbits = 16 For x = 0 To NumCodes Bits(Lenghts(x)) = Bits(Lenghts(x)) + 1 If Lenghts(x) > MaxBits Then MaxBits = Lenghts(x) If Lenghts(x) < Minbits And Lenghts(x) > 0 Then Minbits = Lenghts(x) Next LN = 1 For x = 1 To MaxBits LN = LN + LN LN = LN - Bits(x) If LN < 0 Then Create_Codes = LN: Exit Function Next Create_Codes = LN ReDim tree.code(2 ^ MaxBits - 1) ReDim tree.Lenght(2 ^ MaxBits - 1) code = 0 Bits(0) = 0 For x = 1 To MaxBits code = (code + Bits(x - 1)) * 2 next_code(x) = code Next For x = 0 To NumCodes LN = Lenghts(x) If LN <> 0 Then code = Bit_Reverse(next_code(LN), LN) tree.Lenght(code) = LN tree.code(code) = x next_code(LN) = next_code(LN) + 1 End If Next End Function Private Function Bit_Reverse(ByVal Value As Long, ByVal Numbits As Long) Do While Numbits > 0 Bit_Reverse = Bit_Reverse * 2 + (Value And 1) Numbits = Numbits - 1 Value = Value \ 2 Loop End Function Private Sub Init_Decompress(UncompressedSize As Long) Dim Temp() Dim x As Long ReDim OutStream(UncompressedSize) Erase LitLen.code Erase LitLen.Lenght Erase Dist.code Erase Dist.Lenght ReDim LC.code(31) ReDim LC.Lenght(31) ReDim dc.code(31) ReDim dc.Lenght(31) Temp() = Array(16, 17, 18, 0, 8, 7, 9, 6, 10, 5, 11, 4, 12, 3, 13, 2, 14, 1, 15) For x = 0 To UBound(Temp): LenOrder(x) = Temp(x): Next Temp() = Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 13, 15, 17, 19, 23, 27, 31, 35, 43, 51, 59, 67, 83, 99, 115, 131, 163, 195, 227, 258) For x = 0 To UBound(Temp): LC.code(x) = Temp(x): Next Temp() = Array(0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 2, 2, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 5, 5, 5, 5, 0) For x = 0 To UBound(Temp): LC.Lenght(x) = Temp(x): Next Temp() = Array(1, 2, 3, 4, 5, 7, 9, 13, 17, 25, 33, 49, 65, 97, 129, 193, 257, 385, 513, 769, 1025, 1537, 2049, 3073, 4097, 6145, 8193, 12289, 16385, 24577, 32769, 49153) For x = 0 To UBound(Temp): dc.code(x) = Temp(x): Next Temp() = Array(0, 0, 0, 0, 1, 1, 2, 2, 3, 3, 4, 4, 5, 5, 6, 6, 7, 7, 8, 8, 9, 9, 10, 10, 11, 11, 12, 12, 13, 13, 14, 14) For x = 0 To UBound(Temp): dc.Lenght(x) = Temp(x): Next For x = 0 To 16 BitMask(x) = 2 ^ x - 1 Pow2(x) = 2 ^ x Next OutPos = 0 Inpos = 0 ByteBuff = 0 BitNum = 0 End Sub Private Sub PutByte(Char As Byte) If OutPos > UBound(OutStream) Then ReDim Preserve OutStream(OutPos + 1000) OutStream(OutPos) = Char OutPos = OutPos + 1 End Sub Private Sub NeedBits(Numbits As Long) While BitNum < Numbits If Inpos > UBound(InStream) Then Exit Sub ByteBuff = ByteBuff + (InStream(Inpos) * Pow2(BitNum)) BitNum = BitNum + 8 Inpos = Inpos + 1 Wend End Sub Private Sub DropBits(Numbits As Long) ByteBuff = ByteBuff \ Pow2(Numbits) BitNum = BitNum - Numbits End Sub Private Function GetBits(Numbits As Long) As Long While BitNum < Numbits ByteBuff = ByteBuff + (InStream(Inpos) * Pow2(BitNum)) BitNum = BitNum + 8 Inpos = Inpos + 1 Wend GetBits = ByteBuff And BitMask(Numbits) ByteBuff = ByteBuff \ Pow2(Numbits) BitNum = BitNum - Numbits End Function Private Function DeFilter(Dat() As Byte) As Byte() Dim NewDat() As Byte, y As Long, iVal As Long Dim n As Long, StartByte As Long, DestByte As Long Dim BPRow As Long, x As Long, RowBytes() As Byte Dim PrevRowBytes() As Byte Dim i As Long iVal = Interval() BPRow = DataPerRow() ReDim NewDat(UBound(Dat) - Me.Height) ReDim PrevRowBytes(DataPerRow() - 2) ReDim RowBytes(DataPerRow() - 2) For y = 0 To Me.Height - 1 StartByte = BPRow * y DestByte = StartByte - y x = 0 CopyMemory RowBytes(0), Dat(StartByte + 1), BPRow - 1 Select Case Dat(StartByte) Case 0 'None Case 1 'Sub ReverseSub RowBytes, iVal Case 2 'Up ReverseUp RowBytes, PrevRowBytes Case 3 'Average ReverseAverage RowBytes, PrevRowBytes, iVal Case 4 'Paeth ReversePaeth RowBytes, PrevRowBytes, iVal End Select CopyMemory NewDat(DestByte), RowBytes(0), BPRow - 1 PrevRowBytes = RowBytes Next y DeFilter = NewDat End Function Private Function Interval() As Long Interval = BitsPerPixel() \ 8 If Interval = 0 Then Interval = 1 End Function Private Function BitsPerPixel() As Long Dim Bpp As Long If RBD = 0 Then Bpp = Me.Bitdepht Else Bpp = RBD End If If BPPprivat <> Bpp And BPPprivat <> 0 Then Bpp = BPPprivat Select Case Me.ColorType Case 0, 3: BitsPerPixel = Bpp Case 2: BitsPerPixel = 3 * Bpp Case 6: BitsPerPixel = 4 * Bpp Case 4: BitsPerPixel = 2 * Bpp End Select End Function Private Function DataPerRow() As Long DataPerRow = (Me.Width * BitsPerPixel() + 7) \ 8 + 1 End Function
类第五部分:Private Sub ReverseAverage(CurRow() As Byte, PrevRow() As Byte, Interval As Long) Dim PrevOff As Long, PrevVal As Byte, BPRow As Long Dim n As Long, x As Integer BPRow = UBound(CurRow) + 1 For n = 0 To BPRow - 1 PrevOff = n - Interval If PrevOff >= 0 Then PrevVal = CurRow(PrevOff) End If x = CurRow(n) + (CInt(PrevRow(n)) + CInt(PrevVal)) \ 2 CopyMemory CurRow(n), x, 1 Next n End Sub Private Sub ReversePaeth(CurRow() As Byte, PrevRow() As Byte, Interval As Long) Dim BPRow As Long, n As Long, x As Integer Dim LeftPixOff As Long, LeftPix As Byte Dim UpperLeftPix As Byte BPRow = UBound(CurRow) + 1 For n = 0 To BPRow - 1 LeftPixOff = n - Interval If LeftPixOff >= 0 Then LeftPix = CurRow(LeftPixOff) UpperLeftPix = PrevRow(LeftPixOff) End If x = CInt(CurRow(n)) + CInt(PaethPredictor(LeftPix, PrevRow(n), UpperLeftPix)) CopyMemory CurRow(n), x, 1 Next n End Sub Private Sub ReverseUp(CurRow() As Byte, PrevRow() As Byte) Dim PrevVal As Byte, BPRow As Long Dim n As Long, x As Integer BPRow = UBound(CurRow) + 1 For n = 0 To BPRow - 1 PrevVal = PrevRow(n) x = CInt(CurRow(n)) + CInt(PrevVal) CopyMemory CurRow(n), x, 1 Next n End Sub Private Sub ReverseSub(CurRow() As Byte, Interval As Long) Dim PrevOff As Long, PrevVal As Byte, BPRow As Long Dim n As Long, x As Integer BPRow = UBound(CurRow) + 1 For n = 0 To BPRow - 1 PrevOff = n - Interval If PrevOff >= 0 Then PrevVal = CurRow(PrevOff) End If x = CInt(CurRow(n)) + CInt(PrevVal) CopyMemory CurRow(n), x, 1 Next n End Sub Private Function PaethPredictor(Left As Byte, Above As Byte, UpperLeft As Byte) As Byte Dim pA As Integer, pB As Integer, pC As Integer, p As Integer p = CInt(Left) + CInt(Above) - CInt(UpperLeft) pA = Abs(p - Left) pB = Abs(p - Above) pC = Abs(p - UpperLeft) If (pA <= pB) And (pA <= pC) Then PaethPredictor = Left ElseIf pB <= pC Then PaethPredictor = Above Else PaethPredictor = UpperLeft End If End Function Private Sub ReverseRGB(Dat() As Byte) Dim n As Long, Tmp As Byte On Error Resume Next For n = 0 To UBound(Dat) Step 3 Tmp = Dat(n) Dat(n) = Dat(n + 2) Dat(n + 2) = Tmp Next n End Sub Private Sub Conv16To8(Dat() As Byte) Dim n As Long, DestDat() As Byte, DestOff As Long ReDim DestDat((UBound(Dat) + 1) \ 2 - 1) For n = 0 To UBound(Dat) Step 2 DestDat(DestOff) = Dat(n) DestOff = DestOff + 1 Next n Dat = DestDat End Sub Private Sub Align32(BitCount As Integer, Dat() As Byte) Dim RowBytes As Long, SrcRowBytes As Long Dim y As Long, Dest() As Byte Dim SrcOff As Long, DestOff As Long If BitCount = 32 Then Exit Sub RowBytes = LineBytes(Me.Width, BitCount) SrcRowBytes = DataPerRow() - 1 Select Case Me.ColorType Case 4 'Alpha SrcRowBytes = SrcRowBytes / 2 End Select If RowBytes = SrcRowBytes Then Exit Sub Else ReDim Dest(RowBytes * Me.Height - 1) For y = 0 To Me.Height - 1 SrcOff = y * SrcRowBytes DestOff = y * RowBytes CopyMemory Dest(DestOff), Dat(SrcOff), SrcRowBytes Next y Dat = Dest End If End Sub Private Function LineBytes(Width As Long, BitCount As Integer) As Long LineBytes = ((Width * BitCount + 31) \ 32) * 4 End Function Private Sub ReverseRGBA(Dat() As Byte) Dim n As Long, Tmp As Byte For n = 0 To UBound(Dat) Step 4 Tmp = Dat(n) If n + 2 > UBound(Dat) Then Exit For Dat(n) = Dat(n + 2) Dat(n + 2) = Tmp Next n End Sub Private Sub Pal2To8(Width As Long, Height As Long, Dat() As Byte, RowBytes As Long) Dim DestDat() As Byte, DestRowBytes As Long, n As Long Dim Px As Byte, DestOff As Long, x As Long, y As Long DestRowBytes = LineBytes(Width, 8) ReDim DestDat(DestRowBytes * Height - 1) For y = 0 To Height - 1 DestOff = y * DestRowBytes For x = 0 To Width - 1 n = y * (RowBytes - 1) + x \ 4 If (x Mod 4) <> 3 Then Px = (Dat(n) \ 4 ^ (3 - (x Mod 4))) And 3 Else Px = Dat(n) And 3 End If DestDat(DestOff) = Px DestOff = DestOff + 1 Next x Next y Dat = DestDat End Sub Private Sub GrayAToRGBA(Dat() As Byte) Dim n As Long, DestDat() As Byte, DestOff As Long ReDim DestDat((UBound(Dat) + 1) * 2 - 1) For n = 0 To UBound(Dat) Step 2 DestDat(DestOff) = Dat(n) DestDat(DestOff + 1) = Dat(n) DestDat(DestOff + 2) = Dat(n) DestDat(DestOff + 3) = Dat(n + 1) DestOff = DestOff + 4 Next n Dat = DestDat End Sub
'Download:http://www.codefans.net
Option ExplicitPublic Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hdc As Long, graphics As Long) As GpStatus
Public Declare Function GdipCreateFromHWND Lib "gdiplus" (ByVal hwnd As Long, graphics As Long) As GpStatus
Public Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal graphics As Long) As GpStatus
Public Declare Function GdipGetDC Lib "gdiplus" (ByVal graphics As Long, hdc As Long) As GpStatus
Public Declare Function GdipReleaseDC Lib "gdiplus" (ByVal graphics As Long, ByVal hdc As Long) As GpStatus
Public Declare Function GdipDrawImageRect Lib "gdiplus" (ByVal graphics As Long, ByVal image As Long, ByVal x As Single, ByVal y As Single, ByVal Width As Single, ByVal Height As Single) As GpStatus
Public Declare Function GdipLoadImageFromFile Lib "gdiplus" (ByVal filename As String, image As Long) As GpStatus
Public Declare Function GdipCloneImage Lib "gdiplus" (ByVal image As Long, cloneImage As Long) As GpStatus
Public Declare Function GdipGetImageWidth Lib "gdiplus" (ByVal image As Long, Width As Long) As GpStatus
Public Declare Function GdipGetImageHeight Lib "gdiplus" (ByVal image As Long, Height As Long) As GpStatus
Public Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As Long, ByVal hpal As Long, bitmap As Long) As GpStatus
Public Declare Function GdipBitmapGetPixel Lib "gdiplus" (ByVal bitmap As Long, ByVal x As Long, ByVal y As Long, color As Long) As GpStatus
Public Declare Function GdipBitmapSetPixel Lib "gdiplus" (ByVal bitmap As Long, ByVal x As Long, ByVal y As Long, ByVal color As Long) As GpStatus
Public Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As GpStatus
Public Declare Function GdipCreateBitmapFromFile Lib "gdiplus" (ByVal filename As Long, bitmap As Long) As GpStatusPublic Declare Function ReleaseCapture Lib "user32" () As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As LongPublic Const HTCAPTION = 2
Public Const WM_NCLBUTTONDOWN = &HA1
Public Const WM_SYSCOMMAND = &H112Public Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End TypePublic Declare Function GdiplusStartup Lib "gdiplus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As GpStatus
Public Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal token As Long)Public Enum GpStatus
Ok = 0
GenericError = 1
InvalidParameter = 2
OutOfMemory = 3
ObjectBusy = 4
InsufficientBuffer = 5
NotImplemented = 6
Win32Error = 7
WrongState = 8
Aborted = 9
FileNotFound = 10
ValueOverflow = 11
AccessDenied = 12
UnknownImageFormat = 13
FontFamilyNotFound = 14
FontStyleNotFound = 15
NotTrueTypeFont = 16
UnsupportedGdiplusVersion = 17
GdiplusNotInitialized = 18
PropertyNotFound = 19
PropertyNotSupported = 20
End Enum
以前在枕善居上看到一个据说是初中生写的代码,对GDI+很熟悉的样子。
'人人为我,我为人人
'枕善居汉化收藏整理
'发布日期:05/04/18
'描 述:打开并显示PNG图片的源码
'网 站:http://www.mndsoft.com/blog/
'e-mail:[email protected]
'OICQ : 88382850
'****************************************************************************
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function SetDIBitsToDevice Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As Any, ByVal wUsage As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal XSrc As Long, ByVal YSrc As Long, ByVal dwRop As Long) As Long
Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As Any, ByVal wUsage As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Sub FillMemory Lib "kernel32.dll" Alias "RtlFillMemory" (Destination As Any, ByVal Length As Long, ByVal Fill As Byte)
Private Type BITMAPINFOHEADER
Size As Long
Width As Long
Height As Long
Planes As Integer
BitCount As Integer
Compression As Long
SizeImage As Long
XPelsPerMeter As Long
YPelsPerMeter As Long
ClrUsed As Long
ClrImportant As Long
End Type
Private RBD As Long
Private IDATData() As Byte
Dim IdataLen As Long
Private Type IHDR
Width As Long
Height As Long
BitDepth As Byte
ColorType As Byte
Compression As Byte
Filter As Byte
Interlacing As Byte
End Type
'For Decompression:
Private Type CodesType
Lenght() As Long
code() As Long
End Type
Private m_Backcolor As Long
Private Palettenbyte() As Byte
Private OutStream() As Byte
Private OutPos As Long
Private InStream() As Byte
Private Inpos As Long
Private ByteBuff As Long
Private BitNum As Long
Private BitMask(16) As Long
Private Pow2(16) As Long
Private LC As CodesType
Private dc As CodesType
Private LitLen As CodesType
Private Dist As CodesType
Private TempLit As CodesType
Private TempDist As CodesType
Private LenOrder(18) As Long
Private MinLLenght As Long
Private MaxLLenght As Long
Private MinDLenght As Long
Private MaxDLenght As Long
Private IsStaticBuild As Boolean
Private BPPprivat As Long
Private m_width As Long
Private m_height As Long
Private m_bitdepht As Long
Private m_colortype As Long
Private m_compression As Long
Private m_filter As Long
Private m_interlacing As Long
Private m_ErrorNumber As Long
Private m_sAlpha As Boolean
Private m_hAlpha As Boolean
Private trns() As Byte
Private m_hTrans As Boolean
Private m_sTrans As Boolean
Private Colorused As Long
Private bkgd() As Byte
Private m_hbkgd As Boolean
Private m_bkgdColor As Long
Private m_text As String
Private m_Time As String
Private m_ztext As String
Private m_gama As Long
Private m_Bgx As Long
Private m_Bgy As Long
Private m_BGPic As Object
Private m_OwnBkgnd As Boolean
Private m_OBCol As Long
Private m_PicBox As Object
Private m_settoBG As BooleanPublic Function OpenPNG(filename As String) As Long
Dim Stand As Long
Dim Ende As Boolean
Dim Filenumber As Long
Dim Signature(7) As Byte
Dim Test As Long
Dim Lge As Long
Dim ChunkName As String * 4
Dim ChunkInhalt() As Byte
Dim CRC32Inhalt As Long
Dim Teststring As String
'Dim crc32test As New clsCRC
Dim TestCRC32 As Long
Dim Testint As Integer
m_hbkgd = False
m_hTrans = False
BPPprivat = 0
ReDim IDATData(0)
IdataLen = 0
Filenumber = FreeFile
Open filename For Binary As Filenumber
Get Filenumber, , Signature
Test = IsValidSignature(Signature)
If Test <> -1 Then
m_ErrorNumber = 1
Exit Function
End If
Do While Ende = False
Get Filenumber, , Lge
SwapBytesLong Lge
Get Filenumber, , ChunkName
If Lge > 0 Then ReDim ChunkInhalt(Lge - 1)
Stand = Seek(Filenumber)
If Stand + Lge > LOF(Filenumber) Then
m_ErrorNumber = 3
Exit Function
End If
Get Filenumber, , ChunkInhalt
Get Filenumber, , CRC32Inhalt
'SwapBytesLong CRC32Inhalt
'teststring = ChunkName & StrConv(ChunkInhalt, vbUnicode)
'Testcrc32 = CRC32(teststring) 'reiner VB-Code
'crc32test.Algorithm = 1
'TestCRC32 = crc32test.CalculateString(teststring) 'VB und Assembler
'If CRC32Inhalt <> 0 Then
'If CRC32Inhalt <> TestCRC32 Then
'MsgBox "Bad crc32"
'm_ErrorNumber = 2
'Exit Function
'End If
'End If
Select Case ChunkName
Case "IHDR"
ReadIHDR ChunkInhalt
Case "PLTE"
ReDim Palettenbyte(UBound(ChunkInhalt))
CopyMemory Palettenbyte(0), ChunkInhalt(0), UBound(ChunkInhalt) + 1
Case "IDAT"
ReDim Preserve IDATData(IdataLen + UBound(ChunkInhalt))
CopyMemory IDATData(IdataLen), ChunkInhalt(0), UBound(ChunkInhalt) + 1
IdataLen = UBound(IDATData) + 1
Case "IEND"
Ende = True
Case "bKGD"
bkgd = ChunkInhalt
ReadBkgd
m_hbkgd = True
Case "cHRM"
Case "oFFs"
Case "pCaL"
Case "sCAL"
Case "gAMA"
CopyMemory ByVal VarPtr(m_gama), ChunkInhalt(0), 4
SwapBytesLong m_gama
Case "hIST"
Case "pHYs"
Case "sBIT"
Case "tEXt"
m_text = m_text & StrConv(ChunkInhalt, vbUnicode) & Chr(0)
Case "zTXt"
DecompressText ChunkInhalt
Case "gIFg"
Case "gIFx"
Case "tIME"
CopyMemory ByVal VarPtr(Testint), ChunkInhalt(0), 2
Swap Testint
m_Time = Format(ChunkInhalt(3), "00") & "." & Format(ChunkInhalt(2), "00") & "." & Testint & " " & Format(ChunkInhalt(4), "00") & ":" & Format(ChunkInhalt(5), "00") & ":" & Format(ChunkInhalt(6), "00")
Case "tRNS"
m_hTrans = True
trns = ChunkInhalt
Case "cTXt"
Case Else
'If Asc(Left(ChunkName, 1)) > 65 Then Exit Function 'kritischer Chunk
End Select
Loop
If IdataLen = 0 Then
m_ErrorNumber = 4
Exit Function
End If
Close Filenumber
MakePicture
End Function
If Signature(0) <> 137 Then Exit Function
If Signature(1) <> 80 Then Exit Function
If Signature(2) <> 78 Then Exit Function
If Signature(3) <> 71 Then Exit Function
If Signature(4) <> 13 Then Exit Function
If Signature(5) <> 10 Then Exit Function
If Signature(6) <> 26 Then Exit Function
If Signature(7) <> 10 Then Exit Function
IsValidSignature = True
End Function
Private Sub SwapBytesLong(ByteValue As Long)
Dim ergabe As Long
Dim i As Long
For i = 0 To 3
CopyMemory ByVal VarPtr(ergabe) + i, ByVal VarPtr(ByteValue) + (3 - i), 1
Next i
ByteValue = ergabe
End Sub
Private Sub ReadIHDR(Bytefeld() As Byte)
Dim Header As IHDR
CopyMemory ByVal VarPtr(Header), Bytefeld(0), 13
SwapBytesLong Header.Width
SwapBytesLong Header.Height
m_width = Header.Width
m_height = Header.Height
m_bitdepht = Header.BitDepth
m_colortype = Header.ColorType
m_compression = Header.Compression
m_filter = Header.Filter
m_interlacing = Header.Interlacing
End Sub
Public Property Get Width() As Long
Width = m_width
End Property
Public Property Get Height() As Long
Height = m_height
End Property
Public Property Get Bitdepht() As Long
Bitdepht = m_bitdepht
End Property
Public Property Get ColorType() As Long
ColorType = m_colortype
End Property
Public Property Get Compression() As Long
Compression = m_compression
End Property
Public Property Get Filter() As Long
Filter = m_filter
End Property
Public Property Get Interlacing() As Long
Interlacing = m_interlacing
End Property
Private Sub MakePicture()
Dim DataSize As Long
Dim Buffer() As Byte
Dim BitCount As Integer
Dim Bitdepht As Long
Dim Drehen As Integer
m_hAlpha = False
Drehen = 1
Select Case Me.Interlacing
Case 0
DataSize = DataPerRow * Me.Height
Case 1
DataSize = (DataPerRow * Me.Height) + Me.Height
End Select
ReDim Buffer(UBound(IDATData) - 2)
CopyMemory Buffer(0), IDATData(2), UBound(IDATData) - 1
Select Case Me.Compression
Case 0
Decompress Buffer, DataSize
End Select
Select Case Me.Interlacing
Case 0
Buffer = DeFilter(Buffer)
Drehen = 1
Case 1
Buffer = DeFilterInterlaced(Buffer)
Drehen = 0
End Select
BitCount = Me.Bitdepht
Select Case Me.ColorType
Case 0 'Grayscale
Select Case Me.Bitdepht
Case 16
Conv16To8 Buffer
InitColorTable_Grey 8
BitCount = 8
BPPprivat = 8
Case 8, 4, 1
Select Case Interlacing
Case 0
BitCount = Me.Bitdepht
InitColorTable_Grey Me.Bitdepht, False
Align32 BitCount, Buffer
Case Else
BitCount = 8
InitColorTable_Grey Me.Bitdepht, True
End Select
Case 2
InitColorTable_Grey 2
If Me.Interlacing = 0 Then
Pal2To8 Me.Width, Me.Height, Buffer, DataPerRow
End If
BitCount = 8
BPPprivat = 8
End Select
If m_hTrans And m_sTrans Then
If Me.Bitdepht <> 2 Then
Align32 BitCount, Buffer
End If
PalToRGBA Me.Width, Me.Height, BitCount, Buffer
BitCount = 32
BPPprivat = 32
MakeAlpha m_BGPic, Buffer, m_Bgx, m_Bgy
BitCount = 24
BPPprivat = 24
End If
Case 2 'RGB
If Me.Bitdepht = 16 Then Conv16To8 Buffer
BitCount = 24
BPPprivat = 24
ReverseRGB Buffer
Drehen = 1
BPPprivat = 8
Align32 BitCount, Buffer
BPPprivat = 24
If m_hTrans And m_sTrans Then
MakeRGBTransparent Buffer
MirrorData Buffer, Me.Width * 4
Drehen = 0
BitCount = 32
BPPprivat = 32
MakeAlpha m_BGPic, Buffer, m_Bgx, m_Bgy
BitCount = 24
BPPprivat = 24
End If
Case 3 'Palette
Select Case Me.Bitdepht
Case 8, 4, 1
If Me.Interlacing = 1 Then
BitCount = 8
BPPprivat = 8
Align32 BitCount, Buffer
Else
BitCount = Me.Bitdepht
If BitCount >= 8 Then
Align32 BitCount, Buffer
End If
End If
Case 2
If Me.Interlacing = 0 Then
Pal2To8 Me.Width, Me.Height, Buffer, DataPerRow
BitCount = 8
BPPprivat = 8
Else
BitCount = 8
BPPprivat = 8
Align32 BitCount, Buffer
End If
End Select
If m_hTrans And m_sTrans Then
If Me.Bitdepht <> 2 Then
Align32 BitCount, Buffer
End If
PalToRGBA Me.Width, Me.Height, BitCount, Buffer
BitCount = 32
BPPprivat = 32
MakeAlpha m_BGPic, Buffer, m_Bgx, m_Bgy
BitCount = 24
BPPprivat = 24
End If
Case 4 'Grayscale + Alpha
m_hAlpha = True
If Me.Bitdepht = 16 Then Conv16To8 Buffer
GrayAToRGBA Buffer
BPPprivat = 32
BitCount = 32
MirrorData Buffer, LineBytes(Me.Width, BitCount)
Drehen = 0
If m_sAlpha = True Then
MakeAlpha m_BGPic, Buffer, m_Bgx, m_Bgy
BPPprivat = 24
BitCount = 24
End If
Case 6 'RGB + Alpha
m_hAlpha = True
If Me.Bitdepht = 16 Then Conv16To8 Buffer
BitCount = 32
BPPprivat = 32
ReverseRGBA Buffer
MirrorData Buffer, LineBytes(Me.Width, BitCount)
Drehen = 0
If m_sAlpha = True Then
MakeAlpha m_BGPic, Buffer, m_Bgx, m_Bgy
BPPprivat = 24
BitCount = 24
End If
End Select
If Not (((Me.ColorType = 3) And (BitCount = 32)) Or _
(Me.Bitdepht = 2)) Then
Select Case Me.Bitdepht
Case 16
Bitdepht = 8
Bitdepht = 16
End Select
End If
Select Case BitCount
Case 1, 2, 4
Align32 BitCount, Buffer
End Select
Select Case BitCount
Case 1
Select Case Me.ColorType
Case 3
InitColorTable_1Palette Palettenbyte
Case Else
InitColorTable_1
End Select
CreateBitmap_1 Buffer, Me.Width, Me.Height, True, Colorused
DrawBitmap Me.Width, Me.Height, m_PicBox, True, m_Bgx, m_Bgy, m_settoBG
Case 4
Select Case Me.ColorType
Case 0
Case Else
InitColorTable_4 Palettenbyte
End Select
CreateBitmap_4 Buffer, Me.Width, Me.Height, True, Colorused
DrawBitmap Me.Width, Me.Height, m_PicBox, True, m_Bgx, m_Bgy, m_settoBG
Case 8
Select Case Me.ColorType
Case 0, 4
Case Else
InitColorTable_8 Palettenbyte
End Select
Drehen = 1
CreateBitmap_8 Buffer, Me.Width, Me.Height, Drehen, Colorused
DrawBitmap Me.Width, Me.Height, m_PicBox, True, m_Bgx, m_Bgy, m_settoBG
Case 24
CreateBitmap_24 Buffer, Me.Width, Me.Height, Drehen, 1
DrawBitmap Me.Width, Me.Height, m_PicBox, True, m_Bgx, m_Bgy, m_settoBG
Case 32
CreateBitmap_24 Buffer, Me.Width, Me.Height, Drehen
DrawBitmap Me.Width, Me.Height, m_PicBox, True, m_Bgx, m_Bgy, m_settoBG
End Select
End Sub
Private Function Decompress(ByteArray() As Byte, UncompressedSize As Long, Optional ZIP64 As Boolean = False) As Long
Dim IsLastBlock As Boolean
Dim CompType As Long
Dim Char As Long
Dim Nubits As Long
Dim L1 As Long
Dim L2 As Long
Dim x As Long
UncompressedSize = UncompressedSize + 100
InStream = ByteArray
Call Init_Decompress(UncompressedSize)
Do
IsLastBlock = GetBits(1)
CompType = GetBits(2)
If CompType = 0 Then
If Inpos + 4 > UBound(InStream) Then
Decompress = -1
Exit Do
End If
Do While BitNum >= 8
Inpos = Inpos - 1
BitNum = BitNum - 8
Loop
CopyMemory L1, InStream(Inpos), 2&
CopyMemory L2, InStream(Inpos + 2), 2&
Inpos = Inpos + 4
If L1 - (Not (L2) And &HFFFF&) Then Decompress = -2
If Inpos + L1 - 1 > UBound(InStream) Then
Decompress = -1
Exit Do
End If
If OutPos + L1 - 1 > UBound(OutStream) Then
Decompress = -1
Exit Do
End If
CopyMemory OutStream(OutPos), InStream(Inpos), L1
OutPos = OutPos + L1
Inpos = Inpos + L1
ByteBuff = 0
BitNum = 0
ElseIf CompType = 3 Then
Decompress = -1
Exit Do
Else
If CompType = 1 Then
If Create_Static_Tree <> 0 Then
MsgBox "Error in tree creation (Static)"
Exit Function
End If
Else
If Create_Dynamic_Tree <> 0 Then
MsgBox "Error in tree creation (Static)"
Exit Function
End If
End If
Do
NeedBits MaxLLenght
Nubits = MinLLenght
Do While LitLen.Lenght(ByteBuff And BitMask(Nubits)) <> Nubits
Nubits = Nubits + 1
Loop
Char = LitLen.code(ByteBuff And BitMask(Nubits))
DropBits Nubits
If Char < 256 Then
OutStream(OutPos) = Char
OutPos = OutPos + 1
ElseIf Char > 256 Then
Char = Char - 257
L1 = LC.code(Char) + GetBits(LC.Lenght(Char))
If (L1 = 258) And ZIP64 Then L1 = GetBits(16) + 3
NeedBits MaxDLenght
Nubits = MinDLenght
Do While Dist.Lenght(ByteBuff And BitMask(Nubits)) <> Nubits
Nubits = Nubits + 1
Loop
Char = Dist.code(ByteBuff And BitMask(Nubits))
DropBits Nubits
L2 = dc.code(Char) + GetBits(dc.Lenght(Char))
For x = 1 To L1
If OutPos > UncompressedSize Then
OutPos = UncompressedSize
GoTo Stop_Decompression
End If
OutStream(OutPos) = OutStream(OutPos - L2)
OutPos = OutPos + 1
Next x
End If
Loop While Char <> 256 'EOB
End If
Loop While Not IsLastBlock
Stop_Decompression:
If OutPos > 0 Then
ReDim Preserve OutStream(OutPos - 1)
Else
Erase OutStream
End If
Erase InStream
Erase BitMask
Erase Pow2
Erase LC.code
Erase LC.Lenght
Erase dc.code
Erase dc.Lenght
Erase LitLen.code
Erase LitLen.Lenght
Erase Dist.code
Erase Dist.Lenght
Erase LenOrder
ByteArray = OutStream
End Function
Dim x As Long
Dim Lenght(287) As Long
If IsStaticBuild = False Then
For x = 0 To 143: Lenght(x) = 8: Next
For x = 144 To 255: Lenght(x) = 9: Next
For x = 256 To 279: Lenght(x) = 7: Next
For x = 280 To 287: Lenght(x) = 8: Next
If Create_Codes(TempLit, Lenght, 287, MaxLLenght, MinLLenght) <> 0 Then
Create_Static_Tree = -1
Exit Function
End If
For x = 0 To 31: Lenght(x) = 5: Next
Create_Static_Tree = Create_Codes(TempDist, Lenght, 31, MaxDLenght, MinDLenght)
IsStaticBuild = True
Else
MinLLenght = 7
MaxLLenght = 9
MinDLenght = 5
MaxDLenght = 5
End If
LitLen = TempLit
Dist = TempDist
End Function
Private Function Create_Dynamic_Tree() As Long
Dim Lenght() As Long
Dim Bl_Tree As CodesType
Dim MinBL As Long
Dim MaxBL As Long
Dim NumLen As Long
Dim Numdis As Long
Dim NumCod As Long
Dim Char As Long
Dim Nubits As Long
Dim LN As Long
Dim Pos As Long
Dim x As Long
NumLen = GetBits(5) + 257
Numdis = GetBits(5) + 1
NumCod = GetBits(4) + 4
ReDim Lenght(18)
For x = 0 To NumCod - 1
Lenght(LenOrder(x)) = GetBits(3)
Next
For x = NumCod To 18
Lenght(LenOrder(x)) = 0
Next
If Create_Codes(Bl_Tree, Lenght, 18, MaxBL, MinBL) <> 0 Then
Create_Dynamic_Tree = -1
Exit Function
End If
ReDim Lenght(NumLen + Numdis)
Pos = 0
Do While Pos < NumLen + Numdis
NeedBits MaxBL
Nubits = MinBL
Do While Bl_Tree.Lenght(ByteBuff And BitMask(Nubits)) <> Nubits
Nubits = Nubits + 1
Loop
Char = Bl_Tree.code(ByteBuff And BitMask(Nubits))
DropBits Nubits
If Char < 16 Then
Lenght(Pos) = Char
Pos = Pos + 1
Else
If Char = 16 Then
If Pos = 0 Then
Create_Dynamic_Tree = -5
Exit Function
End If
LN = Lenght(Pos - 1)
Char = 3 + GetBits(2)
ElseIf Char = 17 Then
Char = 3 + GetBits(3)
LN = 0
Else
Char = 11 + GetBits(7)
LN = 0
End If
If Pos + Char > NumLen + Numdis Then
Create_Dynamic_Tree = -6
Exit Function
End If
Do While Char > 0
Char = Char - 1
Lenght(Pos) = LN
Pos = Pos + 1
Loop
End If
Loop
If Create_Codes(LitLen, Lenght, NumLen - 1, MaxLLenght, MinLLenght) <> 0 Then
Create_Dynamic_Tree = -1
Exit Function
End If
For x = 0 To Numdis
Lenght(x) = Lenght(x + NumLen)
Next
Create_Dynamic_Tree = Create_Codes(Dist, Lenght, Numdis - 1, MaxDLenght, MinDLenght)
End Function
Private Function Create_Codes(tree As CodesType, Lenghts() As Long, NumCodes As Long, MaxBits As Long, Minbits As Long) As Long
Dim Bits(16) As Long
Dim next_code(16) As Long
Dim code As Long
Dim LN As Long
Dim x As Long
Minbits = 16
For x = 0 To NumCodes
Bits(Lenghts(x)) = Bits(Lenghts(x)) + 1
If Lenghts(x) > MaxBits Then MaxBits = Lenghts(x)
If Lenghts(x) < Minbits And Lenghts(x) > 0 Then Minbits = Lenghts(x)
Next
LN = 1
For x = 1 To MaxBits
LN = LN + LN
LN = LN - Bits(x)
If LN < 0 Then Create_Codes = LN: Exit Function
Next
Create_Codes = LN
ReDim tree.code(2 ^ MaxBits - 1)
ReDim tree.Lenght(2 ^ MaxBits - 1)
code = 0
Bits(0) = 0
For x = 1 To MaxBits
code = (code + Bits(x - 1)) * 2
next_code(x) = code
Next
For x = 0 To NumCodes
LN = Lenghts(x)
If LN <> 0 Then
code = Bit_Reverse(next_code(LN), LN)
tree.Lenght(code) = LN
tree.code(code) = x
next_code(LN) = next_code(LN) + 1
End If
Next
End Function
Private Function Bit_Reverse(ByVal Value As Long, ByVal Numbits As Long)
Do While Numbits > 0
Bit_Reverse = Bit_Reverse * 2 + (Value And 1)
Numbits = Numbits - 1
Value = Value \ 2
Loop
End Function
Private Sub Init_Decompress(UncompressedSize As Long)
Dim Temp()
Dim x As Long
ReDim OutStream(UncompressedSize)
Erase LitLen.code
Erase LitLen.Lenght
Erase Dist.code
Erase Dist.Lenght
ReDim LC.code(31)
ReDim LC.Lenght(31)
ReDim dc.code(31)
ReDim dc.Lenght(31)
Temp() = Array(16, 17, 18, 0, 8, 7, 9, 6, 10, 5, 11, 4, 12, 3, 13, 2, 14, 1, 15)
For x = 0 To UBound(Temp): LenOrder(x) = Temp(x): Next
Temp() = Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 13, 15, 17, 19, 23, 27, 31, 35, 43, 51, 59, 67, 83, 99, 115, 131, 163, 195, 227, 258)
For x = 0 To UBound(Temp): LC.code(x) = Temp(x): Next
Temp() = Array(0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 2, 2, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 5, 5, 5, 5, 0)
For x = 0 To UBound(Temp): LC.Lenght(x) = Temp(x): Next
Temp() = Array(1, 2, 3, 4, 5, 7, 9, 13, 17, 25, 33, 49, 65, 97, 129, 193, 257, 385, 513, 769, 1025, 1537, 2049, 3073, 4097, 6145, 8193, 12289, 16385, 24577, 32769, 49153)
For x = 0 To UBound(Temp): dc.code(x) = Temp(x): Next
Temp() = Array(0, 0, 0, 0, 1, 1, 2, 2, 3, 3, 4, 4, 5, 5, 6, 6, 7, 7, 8, 8, 9, 9, 10, 10, 11, 11, 12, 12, 13, 13, 14, 14)
For x = 0 To UBound(Temp): dc.Lenght(x) = Temp(x): Next
For x = 0 To 16
BitMask(x) = 2 ^ x - 1
Pow2(x) = 2 ^ x
Next
OutPos = 0
Inpos = 0
ByteBuff = 0
BitNum = 0
End Sub
Private Sub PutByte(Char As Byte)
If OutPos > UBound(OutStream) Then ReDim Preserve OutStream(OutPos + 1000)
OutStream(OutPos) = Char
OutPos = OutPos + 1
End Sub
Private Sub NeedBits(Numbits As Long)
While BitNum < Numbits
If Inpos > UBound(InStream) Then Exit Sub
ByteBuff = ByteBuff + (InStream(Inpos) * Pow2(BitNum))
BitNum = BitNum + 8
Inpos = Inpos + 1
Wend
End Sub
Private Sub DropBits(Numbits As Long)
ByteBuff = ByteBuff \ Pow2(Numbits)
BitNum = BitNum - Numbits
End Sub
Private Function GetBits(Numbits As Long) As Long
While BitNum < Numbits
ByteBuff = ByteBuff + (InStream(Inpos) * Pow2(BitNum))
BitNum = BitNum + 8
Inpos = Inpos + 1
Wend
GetBits = ByteBuff And BitMask(Numbits)
ByteBuff = ByteBuff \ Pow2(Numbits)
BitNum = BitNum - Numbits
End Function
Private Function DeFilter(Dat() As Byte) As Byte()
Dim NewDat() As Byte, y As Long, iVal As Long
Dim n As Long, StartByte As Long, DestByte As Long
Dim BPRow As Long, x As Long, RowBytes() As Byte
Dim PrevRowBytes() As Byte
Dim i As Long
iVal = Interval()
BPRow = DataPerRow()
ReDim NewDat(UBound(Dat) - Me.Height)
ReDim PrevRowBytes(DataPerRow() - 2)
ReDim RowBytes(DataPerRow() - 2)
For y = 0 To Me.Height - 1
StartByte = BPRow * y
DestByte = StartByte - y
x = 0
CopyMemory RowBytes(0), Dat(StartByte + 1), BPRow - 1
Select Case Dat(StartByte)
Case 0 'None
Case 1 'Sub
ReverseSub RowBytes, iVal
Case 2 'Up
ReverseUp RowBytes, PrevRowBytes
Case 3 'Average
ReverseAverage RowBytes, PrevRowBytes, iVal
Case 4 'Paeth
ReversePaeth RowBytes, PrevRowBytes, iVal
End Select
CopyMemory NewDat(DestByte), RowBytes(0), BPRow - 1
PrevRowBytes = RowBytes
Next y
DeFilter = NewDat
End Function
Private Function Interval() As Long
Interval = BitsPerPixel() \ 8
If Interval = 0 Then Interval = 1
End Function
Private Function BitsPerPixel() As Long
Dim Bpp As Long
If RBD = 0 Then
Bpp = Me.Bitdepht
Else
Bpp = RBD
End If
If BPPprivat <> Bpp And BPPprivat <> 0 Then Bpp = BPPprivat
Select Case Me.ColorType
Case 0, 3: BitsPerPixel = Bpp
Case 2: BitsPerPixel = 3 * Bpp
Case 6: BitsPerPixel = 4 * Bpp
Case 4: BitsPerPixel = 2 * Bpp
End Select
End Function
Private Function DataPerRow() As Long
DataPerRow = (Me.Width * BitsPerPixel() + 7) \ 8 + 1
End Function
Dim PrevOff As Long, PrevVal As Byte, BPRow As Long
Dim n As Long, x As Integer
BPRow = UBound(CurRow) + 1
For n = 0 To BPRow - 1
PrevOff = n - Interval
If PrevOff >= 0 Then
PrevVal = CurRow(PrevOff)
End If
x = CurRow(n) + (CInt(PrevRow(n)) + CInt(PrevVal)) \ 2
CopyMemory CurRow(n), x, 1
Next n
End Sub
Private Sub ReversePaeth(CurRow() As Byte, PrevRow() As Byte, Interval As Long)
Dim BPRow As Long, n As Long, x As Integer
Dim LeftPixOff As Long, LeftPix As Byte
Dim UpperLeftPix As Byte
BPRow = UBound(CurRow) + 1
For n = 0 To BPRow - 1
LeftPixOff = n - Interval
If LeftPixOff >= 0 Then
LeftPix = CurRow(LeftPixOff)
UpperLeftPix = PrevRow(LeftPixOff)
End If
x = CInt(CurRow(n)) + CInt(PaethPredictor(LeftPix, PrevRow(n), UpperLeftPix))
CopyMemory CurRow(n), x, 1
Next n
End Sub
Private Sub ReverseUp(CurRow() As Byte, PrevRow() As Byte)
Dim PrevVal As Byte, BPRow As Long
Dim n As Long, x As Integer
BPRow = UBound(CurRow) + 1
For n = 0 To BPRow - 1
PrevVal = PrevRow(n)
x = CInt(CurRow(n)) + CInt(PrevVal)
CopyMemory CurRow(n), x, 1
Next n
End Sub
Private Sub ReverseSub(CurRow() As Byte, Interval As Long)
Dim PrevOff As Long, PrevVal As Byte, BPRow As Long
Dim n As Long, x As Integer
BPRow = UBound(CurRow) + 1
For n = 0 To BPRow - 1
PrevOff = n - Interval
If PrevOff >= 0 Then
PrevVal = CurRow(PrevOff)
End If
x = CInt(CurRow(n)) + CInt(PrevVal)
CopyMemory CurRow(n), x, 1
Next n
End Sub
Private Function PaethPredictor(Left As Byte, Above As Byte, UpperLeft As Byte) As Byte
Dim pA As Integer, pB As Integer, pC As Integer, p As Integer
p = CInt(Left) + CInt(Above) - CInt(UpperLeft)
pA = Abs(p - Left)
pB = Abs(p - Above)
pC = Abs(p - UpperLeft)
If (pA <= pB) And (pA <= pC) Then
PaethPredictor = Left
ElseIf pB <= pC Then
PaethPredictor = Above
Else
PaethPredictor = UpperLeft
End If
End Function
Private Sub ReverseRGB(Dat() As Byte)
Dim n As Long, Tmp As Byte
On Error Resume Next
For n = 0 To UBound(Dat) Step 3
Tmp = Dat(n)
Dat(n) = Dat(n + 2)
Dat(n + 2) = Tmp
Next n
End Sub
Private Sub Conv16To8(Dat() As Byte)
Dim n As Long, DestDat() As Byte, DestOff As Long
ReDim DestDat((UBound(Dat) + 1) \ 2 - 1)
For n = 0 To UBound(Dat) Step 2
DestDat(DestOff) = Dat(n)
DestOff = DestOff + 1
Next n
Dat = DestDat
End Sub
Private Sub Align32(BitCount As Integer, Dat() As Byte)
Dim RowBytes As Long, SrcRowBytes As Long
Dim y As Long, Dest() As Byte
Dim SrcOff As Long, DestOff As Long
If BitCount = 32 Then Exit Sub
RowBytes = LineBytes(Me.Width, BitCount)
SrcRowBytes = DataPerRow() - 1
Select Case Me.ColorType
Case 4 'Alpha
SrcRowBytes = SrcRowBytes / 2
End Select
If RowBytes = SrcRowBytes Then
Exit Sub
Else
ReDim Dest(RowBytes * Me.Height - 1)
For y = 0 To Me.Height - 1
SrcOff = y * SrcRowBytes
DestOff = y * RowBytes
CopyMemory Dest(DestOff), Dat(SrcOff), SrcRowBytes
Next y
Dat = Dest
End If
End Sub
Private Function LineBytes(Width As Long, BitCount As Integer) As Long
LineBytes = ((Width * BitCount + 31) \ 32) * 4
End Function
Private Sub ReverseRGBA(Dat() As Byte)
Dim n As Long, Tmp As Byte
For n = 0 To UBound(Dat) Step 4
Tmp = Dat(n)
If n + 2 > UBound(Dat) Then Exit For
Dat(n) = Dat(n + 2)
Dat(n + 2) = Tmp
Next n
End Sub
Private Sub Pal2To8(Width As Long, Height As Long, Dat() As Byte, RowBytes As Long)
Dim DestDat() As Byte, DestRowBytes As Long, n As Long
Dim Px As Byte, DestOff As Long, x As Long, y As Long
DestRowBytes = LineBytes(Width, 8)
ReDim DestDat(DestRowBytes * Height - 1)
For y = 0 To Height - 1
DestOff = y * DestRowBytes
For x = 0 To Width - 1
n = y * (RowBytes - 1) + x \ 4
If (x Mod 4) <> 3 Then
Px = (Dat(n) \ 4 ^ (3 - (x Mod 4))) And 3
Else
Px = Dat(n) And 3
End If
DestDat(DestOff) = Px
DestOff = DestOff + 1
Next x
Next y
Dat = DestDat
End Sub
Private Sub GrayAToRGBA(Dat() As Byte)
Dim n As Long, DestDat() As Byte, DestOff As Long
ReDim DestDat((UBound(Dat) + 1) * 2 - 1)
For n = 0 To UBound(Dat) Step 2
DestDat(DestOff) = Dat(n)
DestDat(DestOff + 1) = Dat(n)
DestDat(DestOff + 2) = Dat(n)
DestDat(DestOff + 3) = Dat(n + 1)
DestOff = DestOff + 4
Next n
Dat = DestDat
End Sub
GDI+
jhone99