home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 3_2004-2005.ISO / Data / Zips / iICO_1_2_(18090510222004.psc / cIcon.cls < prev   
Text File  |  2004-10-23  |  9KB  |  301 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "cIcon"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. '================================================
  15. ' Class:         cIcon.cls
  16. ' Author:        Carles P.V.
  17. ' Dependencies:  cDIB.cls, cPalette.cls
  18. ' Last revision: 2004.06.14
  19. '================================================
  20.  
  21. Option Explicit
  22.  
  23. '-- API:
  24.  
  25. Private Type ICONDIR
  26.     idReserved    As Integer  ' Reserved
  27.     idType        As Integer  ' Resource type
  28.     idCount       As Integer  ' Image Count
  29. End Type '6 bytes
  30.  
  31. Private Type ICONDIRENTRY
  32.     bWidth        As Byte     ' Width of the image
  33.     bHeight       As Byte     ' Height of the image (2 * Height)
  34.     bColorCount   As Byte     ' Number of colors in image (0 when >= 8 bpp)
  35.     bReserved     As Byte     ' Reserved
  36.     wPlanes       As Integer  ' Color Planes   (-> xHotspot [Cursor])
  37.     wBitCount     As Integer  ' Bits per pixel (-> yHotspot [Cursor])
  38.     dwBytesInRes  As Long     ' How many bytes in this resource?
  39.     dwImageOffset As Long     ' Where in the file is this image?
  40. End Type '16 bytes
  41.  
  42. Private Type BITMAPINFOHEADER
  43.     biSize          As Long
  44.     biWidth         As Long
  45.     biHeight        As Long
  46.     biPlanes        As Integer
  47.     biBitCount      As Integer
  48.     biCompression   As Long
  49.     biSizeImage     As Long
  50.     biXPelsPerMeter As Long
  51.     biYPelsPerMeter As Long
  52.     biClrUsed       As Long
  53.     biClrImportant  As Long
  54. End Type '40 bytes
  55.  
  56. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDst As Any, lpSrc As Any, ByVal Length As Long)
  57. Private Declare Sub FillMemory Lib "kernel32" Alias "RtlFillMemory" (lpDst As Any, ByVal Length As Long, ByVal Fill As Byte)
  58. Private Declare Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" (lpDst As Any, ByVal Length As Long)
  59.  
  60. '//
  61.  
  62. '-- Public Enums.:
  63.  
  64. Public Enum ResourceTypeCts
  65.     [rtIcon] = 1
  66.     [rtCursor] = 2
  67. End Enum
  68.  
  69. Public Enum icoBPPCts
  70.     [002_Colors] = 1
  71.     [016_Colors] = 4
  72.     [256_Colors] = 8
  73.     [True_Color] = 24
  74.     [ARGB_Color] = 32
  75. End Enum
  76.  
  77. '-- Private Types:
  78. Private Type DIBDATA
  79.     XORDIB As cDIB                   ' XOR DIB section
  80.     ANDDIB As cDIB                   ' AND DIB section
  81. End Type
  82.  
  83. '-- Private Variables:
  84. Private m_Loaded      As Boolean      ' Icon <loaded> flag
  85. Private m_OrderKey()  As String * 8   ' Image format key
  86. Private m_uDir        As ICONDIR      ' Icon file header
  87. Private m_uDirEntry() As ICONDIRENTRY ' Icon image headers
  88. Private m_uDIBData()  As DIBDATA      ' Icon data (DIBs)
  89.  
  90.  
  91.  
  92. '========================================================================================
  93. ' Class
  94. '========================================================================================
  95.  
  96. Private Sub Class_Initialize()
  97.     m_uDir.idType = [rtIcon]
  98. End Sub
  99.  
  100. Private Sub Class_Terminate()
  101.     Call pvClear
  102. End Sub
  103.  
  104. '========================================================================================
  105. ' Methods
  106. '========================================================================================
  107.  
  108. Public Sub Destroy()
  109.     Call pvClear
  110. End Sub
  111.  
  112. Public Function LoadFromFile(ByVal Filename As String, Optional ByVal SortByFormat As Boolean = True) As Boolean
  113.     
  114.   Dim currRes    As ResourceTypeCts
  115.   Dim uBIH       As BITMAPINFOHEADER
  116.   Dim aXORBits() As Byte
  117.   Dim aANDBits() As Byte
  118.   Dim aPalXOR()  As Byte
  119.   Dim aPalAND(7) As Byte
  120.  
  121.   Dim hFile As Integer
  122.   Dim nImg  As Integer
  123.     
  124.     '-- Store temp. resource type (->Err)
  125.     currRes = m_uDir.idType
  126.     
  127.     '-- Clear / Activate error handling
  128.     Call pvClear
  129.     On Error GoTo ErrLoad
  130.     
  131.     '-- Open file
  132.     hFile = FreeFile()
  133.     Open Filename For Binary Access Read As hFile
  134.       
  135.         '-- Get icon header
  136.         Get #hFile, , m_uDir
  137.         '-- Get icon entries
  138.         ReDim m_uDirEntry(m_uDir.idCount - 1)
  139.         Get #hFile, , m_uDirEntry()
  140.         
  141.         '-- Initialize arrays and monochrome palette
  142.         ReDim m_OrderKey(m_uDir.idCount - 1)
  143.         ReDim m_uDIBData(m_uDir.idCount - 1)
  144.         ReDim m_DIBData(m_uDir.idCount - 1)
  145.         Call FillMemory(aPalAND(4), 3, &HFF)
  146.         
  147.         '-- Get images
  148.         For nImg = 0 To m_uDir.idCount - 1
  149.             
  150.             '-- Move to begin of image data
  151.             Seek #hFile, m_uDirEntry(nImg).dwImageOffset + 1
  152.             
  153.             '-- Load BITMAPINFOHEADER
  154.             Get #hFile, , uBIH
  155.             
  156.             '-- Load XOR palette [?] (<= 8 bpp)
  157.             If (uBIH.biBitCount <= 8) Then
  158.                 ReDim aPalXOR(4 * 2 ^ uBIH.biBitCount - 1)
  159.                 Get #hFile, , aPalXOR()
  160.             End If
  161.             
  162.             With m_uDIBData(nImg)
  163.                 
  164.                 '-- Inititalize XOR DIB
  165.                 Set .XORDIB = New cDIB
  166.                 Call .XORDIB.Create(uBIH.biWidth, uBIH.biHeight \ 2, uBIH.biBitCount)
  167.                 If (uBIH.biBitCount <= 8) Then
  168.                     Call .XORDIB.SetPalette(aPalXOR())
  169.                 End If
  170.                 
  171.                 '-- Inititalize AND DIB
  172.                 Set .ANDDIB = New cDIB
  173.                 Call .ANDDIB.Create(uBIH.biWidth, uBIH.biHeight \ 2, [01_bpp])
  174.                 Call .ANDDIB.SetPalette(aPalAND())
  175.                 
  176.                 '-- Read DIB bits
  177.                 ReDim aXORBits(.XORDIB.Size - 1): Get #hFile, , aXORBits()
  178.                 ReDim aANDBits(.ANDDIB.Size - 1): Get #hFile, , aANDBits()
  179.                 
  180.                 '-- Assign DIB bits
  181.                 Call CopyMemory(ByVal .XORDIB.lpBits, aXORBits(0), .XORDIB.Size)
  182.                 Call CopyMemory(ByVal .ANDDIB.lpBits, aANDBits(0), .ANDDIB.Size)
  183.                 
  184.                 '-- Build image format key (sort entries)
  185.                 m_OrderKey(nImg) = Format$(uBIH.biWidth, "000") & Format$(uBIH.biHeight \ 2, "000") & Format$(uBIH.biBitCount, "00")
  186.             End With
  187.         Next nImg
  188.  
  189.     Close #hFile
  190.     If (SortByFormat) Then
  191.         Call pvSortEntries
  192.     End If
  193.     
  194. '-- Success
  195.     m_Loaded = True
  196.     LoadFromFile = True
  197.     Exit Function
  198.     
  199. '-- Err.
  200. ErrLoad:
  201.     Close #hFile
  202.     Call pvClear
  203.     m_uDir.idType = currRes
  204. End Function
  205.  
  206. Public Function SaveToFile(ByVal Filename As String) As Boolean
  207.  
  208.   Dim uBIH       As BITMAPINFOHEADER
  209.   Dim aPalXOR()  As Byte
  210.   Dim aXORBits() As Byte
  211.   Dim aANDBits() As Byte
  212.  
  213.   Dim hFile As Integer
  214.   Dim nImg  As Integer
  215.  
  216.     If (m_Loaded) Then
  217.         
  218.         On Error Resume Next
  219.         Call Kill(Filename)
  220.         On Error GoTo 0
  221.  
  222.         On Error GoTo ErrSave
  223.         
  224.         hFile = FreeFile()
  225.         Open Filename For Binary Access Write As hFile
  226.  
  227.         '-- Write icon header
  228.         Put #hFile, , m_uDir
  229.         '-- Write icon entries
  230.         Put #hFile, , m_uDirEntry()
  231.  
  232.         '-- Write icon data
  233.         For nImg = 0 To m_uDir.idCount - 1
  234.  
  235.             With m_uDIBData(nImg)
  236.             
  237.                 '-- Build BITMAPINFOHEADER / Get palette [?]
  238.                 With .XORDIB
  239.                     uBIH.biSize = Len(uBIH)
  240.                     uBIH.biPlanes = 1
  241.                     uBIH.biBitCount = .BPP
  242.                     uBIH.biWidth = .Width
  243.                     uBIH.biHeight = 2 * .Height
  244.                     If (.BPP <= 8) Then
  245.                         ReDim aPalXOR(4 * 2 ^ .BPP - 1): Call .GetPalette(aPalXOR())
  246.                     End If
  247.                 End With
  248.  
  249.                 '-- Get DIB bits
  250.                 ReDim aXORBits(.XORDIB.Size - 1)
  251.                 ReDim aANDBits(.ANDDIB.Size - 1)
  252.                 Call CopyMemory(aXORBits(0), ByVal .XORDIB.lpBits, .XORDIB.Size)
  253.                 Call CopyMemory(aANDBits(0), ByVal .ANDDIB.lpBits, .ANDDIB.Size)
  254.     
  255.                 '-- Move to entry start
  256.                 Seek #hFile, m_uDirEntry(nImg).dwImageOffset + 1
  257.                 
  258.                 '-- Write data
  259.                 Put #hFile, , uBIH
  260.                 If (.XORDIB.BPP <= 8) Then
  261.                     Put #hFile, , aPalXOR()
  262.                 End If
  263.                 Put #hFile, , aXORBits()
  264.                 Put #hFile, , aANDBits()
  265.             End With
  266.         Next nImg
  267.  
  268.         Close #hFile
  269.         SaveToFile = True
  270.     End If
  271.     Exit Function
  272.  
  273. ErrSave:
  274.     Close #hFile
  275. End Function
  276.  
  277. '//
  278.  
  279. Public Function AddFormat(ByVal NewWidth As Integer, ByVal NewHeight As Integer, ByVal NewBPP As icoBPPCts, Optional ByVal SortByFormat As Boolean = True) As Integer
  280.  
  281.   Dim nCount As Integer
  282.   Dim oPal   As New cPalette
  283.   Dim aPal() As Byte
  284.  
  285.     '-- Check format
  286.     If (Not pvFormatExists(Format$(NewWidth, "000") & Format$(NewHeight, "000") & Format$(NewBPP, "00"))) Then
  287.  
  288.         '-- Increase image Count
  289.         nCount = m_uDir.idCount
  290.         nt
  291.         nte   Nuntt
  292.   )s(.XiBitCountlm_uDirormat$(NewWidth, "
  293.         (m_Lo
  294.  
  295.   Dim nCount As Integ0a==============
  296.                 
  297.                 '===========
  298.    t==========o begin of image data
  299.  en(uBIH)
  300. d 
  301.