Toolbar Bitmap Creator

[Peter Lameijn]

Jan 4, 2002 : Added sourcecode.

I never could find an easy program to create toolbar bitmaps from icons,
so I decided to make one myself. It saves lots of time (It was always a crime
to put together a tb bitmap). It's a simple program. Any OS problem reports are
welcome...

rev 004, nov 2003 : Added background color change support
rev 005, nov 2003 : Bugfix in filesize calcs
------------------
Peter.
mailto[email protected][email protected]</A>



[This message has been edited by Peter Lameijn (edited November 23, 2003).]

[Peter Lameijn]

Added sourcecode to post. Also added possibility to create 16x16
and 32x32 bitmaps

'==================================================================================================
' TbbCreat.bas.     Toolbar bitmap creator.
'                   Creates 16,24, or 32 pixel high toolbar bitmaps from normal 16x16 or 32x32
'                   pixel sized icons.
'                   Default is 24 pixel high bitmap.
'                   For 16 pixel height, use commandline switch /16
'                   For 32 pixel height, use commandline switch /32
'                   Made by Peter Lameijn. (FreeWare)
'                   Version 1.00, rev 001 - Date: Jan, 03, 2002 - Initial version
'                                 rev 002 - Date: Jan, 04, 2002 - Bugfix:
'                                         - > 16 color icons would generate Access Error, now rejected
'                                         - Saving bitmap more then once would mess-up bitmap
'                                 rev 003 - Date: Jan. 05, 2002 - Bugfix:
'                                         - After Save As dialog window wasn't repainted
'                                 rev 004 - Date: Nov 11, 2003 - Added:
'                                         - Possibility to add different background color
'                                           Just change %BACKGROUNDCOLOR value to another (valid) value
'                                 rev 005 - Date: Nov 23, 2003 - BugFix:
'                                         - Size of bitmap internally wrong reported. Only problem
'                                           if bitmap used with LoadImage from a disk-file
'==================================================================================================
#Compile Exe
#Dim All
#Register None
'#Debug Error On
 
%NOANIMATE      = 1 : %NOBUTTON       = 1 : %NOCOMBO        = 1
%NODRAGLIST     = 1 : %NOHEADER       = 1 : %NOHOTKEY       = 1
%NOLIST         = 1 : %NONATIVEFONTCTL= 1 : %NOPAGESCROLLER = 1
%NOREBAR        = 1 : %NOIPADDRESS    = 1 : %NOMONTHCAL     = 1
%NOTREEVIEW     = 1 : %NOTABCONTROL   = 1 : %NOTOOLBAR      = 1
%NOTOOLTIPS     = 1 : %NODATETIMEPICK = 1 : %NOPROGRESS     = 1
%NOLISTVIEW     = 1 : %NOIMAGELIST    = 1 : %NOTRACKBAR     = 1
%NOUPDOWN       = 1
'%NOSTATUSBAR    = 1
 
#Include "win32api.inc"
#Include "Commctrl.inc"
#Include "ComDlg32.Inc"
'#Resource "testsub.pbr"
 
'%BACKGROUNDCOLOR = %COLOR_BTNFACE
'%BACKGROUNDCOLOR = %COLOR_3DDKSHADOW            'Dark shadow for three-dimensional display elements.
%BACKGROUNDCOLOR = %COLOR_3DFACE                '=COLOR_BTNFACE. Facecolor 3-dimens. display elements.
'%BACKGROUNDCOLOR = %COLOR_3DHILIGHT             '=COLOR_3DHIGHLIGHT, COLOR_BTNHILIGHT, COLOR_BTNHIGHLIGHT    Highlight color for three-dimensional display elements (for edges facing the light source.)
'%BACKGROUNDCOLOR = %COLOR_3DLIGHT               'Light color for three-dimensional display elements (for edges facing the light source.)
'%BACKGROUNDCOLOR = %COLOR_3DSHADOW              '=COLOR_BTNSHADOW     Shadow color for three-dimensional display elements (for edges facing away from the light source).
'%BACKGROUNDCOLOR = %COLOR_ACTIVEBORDER          'Active window border.
'%BACKGROUNDCOLOR = %COLOR_ACTIVECAPTION         'Active window caption.
'%BACKGROUNDCOLOR = %COLOR_APPWORKSPACE          'Background color of multiple document interface (MDI) applications.
'%BACKGROUNDCOLOR = %COLOR_BACKGROUND            '=COLOR_DESKTOP     Desktop.
'%BACKGROUNDCOLOR = %COLOR_BTNTEXT               'Text on push buttons.
'%BACKGROUNDCOLOR = %COLOR_CAPTIONTEXT           'Text in caption, size box, and scroll bar arrow box.
'%BACKGROUNDCOLOR = %COLOR_GRAYTEXT              'Grayed (disabled) text. This color is set to 0 if the current display driver does not support a solid gray color.
'%BACKGROUNDCOLOR = %COLOR_HIGHLIGHT             'Item(s) selected in a control.
'%BACKGROUNDCOLOR = %COLOR_HIGHLIGHTTEXT         'Text of item(s) selected in a control.
'%BACKGROUNDCOLOR = %COLOR_INACTIVEBORDER        'Inactive window border.
'%BACKGROUNDCOLOR = %COLOR_INACTIVECAPTION       'Inactive window caption.
'%BACKGROUNDCOLOR = %COLOR_INACTIVECAPTIONTEXT   'Color of text in an inactive caption.
'%BACKGROUNDCOLOR = %COLOR_INFOBK                'Background color for tooltip controls.
'%BACKGROUNDCOLOR = %COLOR_INFOTEXT              'Text color for tooltip controls.
'%BACKGROUNDCOLOR = %COLOR_MENU                  'Menu background.
'%BACKGROUNDCOLOR = %COLOR_MENUTEXT              'Text in menus.
'%BACKGROUNDCOLOR = %COLOR_SCROLLBAR             'Scroll bar gray area.
'%BACKGROUNDCOLOR = %COLOR_WINDOW                'Window background.
'%BACKGROUNDCOLOR = %COLOR_WINDOWFRAME           'Window frame.
'%BACKGROUNDCOLOR = %COLOR_WINDOWTEXT            'Text in windows.
 
%BUTTON         = %WM_USER + 1001
%MENU_SAVE      = %WM_USER + 1102
%MENU_EXIT      = %WM_USER + 1103
%MENU_ABOUT     = %WM_USER + 1104
%STATUSBAR      = %WM_USER + 1111
%LISTBOX        = %WM_USER + 1112
%UWM_STARTUP    = %WM_USER + 1113
%CMD_ABOUT_OK   = %WM_USER + 1114
 
%MAXBUTTONS     = 20
%MAXLISTEVENTS  = 500
 
Type ICONFILEHEADER
  Reserved1 As Word
  ResType   As Word
  IconCount As Word
End Type
 
Type ICONDIRENTRY
  bWidth        As Byte             'Width of icon in pixels
  bHeight       As Byte             'Height of icon in pixels
  bNumColors    As Byte             'Maximum number of colors
  bReserved     As Byte             'Obsolete (always zero)
  wNumPlanes    As Word             'Obsolete (always zero)
  wBitsPerPixel As Word             'Obsolete (always zero)
  dwDataSize    As Dword            'Length of icon bitmap in bytes
  dwDataOffset  As Dword            'Offset position of icon bitmap in file
End Type
 
Type ICONIMAGE16
  icHdr         As BITMAPINFOHEADER
  icCol(15)     As RGBQUAD
  icXOR(127)    As Byte
  icAND(63)     As Byte
End Type
 
Type ICONIMAGE32
  icHdr         As BITMAPINFOHEADER
  icCol(15)     As RGBQUAD
  icXOR(511)    As Byte
  icAND(127)    As Byte
End Type
 
Global hDlg         As Dword
Global hButton()    As Dword
Global hOldButton() As Dword
Global gBmpSize     As Long
Global RCol()       As Long
Global hMenu()      As Dword
Global hAbout       As Long
Global TBBName      As String
Global CTab()       As RGBQUAD
Global gBSize       As Long
Global hIconCnt     As Long
Global ActiveFiles  As Long
Global TBmpPels()   As Byte
Global TBmpName()   As Asciiz * %MAX_PATH
Global LoadedIcons  As Long
Global hLast        As Long
Global AppName      As String
Global AppVersion   As String
Global AppCopyRight As String
Global AppPath      As String
Global Bmp()        As Byte
Global Bm16()       As Byte
Global Bm32()       As Byte
Global TbBmpPix     As String
 
'==================================================================================================
' AddEvent - Adds event to list
'--------------------------------------------------------------------------------------------------
Sub AddEvent (pData As String)
  Local lRet As Long
  Control Send hDlg,%LISTBOX,%LB_GETCOUNT,0,0 To lRet
  If lRet > %MAXLISTEVENTS Then ListBox Delete hDlg, %LISTBOX, 1
  ListBox Add  hDlg, %LISTBOX, pData
  Control Send hDlg, %LISTBOX, %LB_GETCOUNT,0,0 To lRet
  Control Send hDlg, %LISTBOX, %LB_SETCURSEL, lRet -1, 0
End Sub
 
'==================================================================================================
' The About Box - This box is shown if user presses Menu - Help - About
'==================================================================================================
CallBack Function AboutCallBack ()
  Static Active As Long
  Select Case CbMsg
    Case %WM_INITDIALOG
      SETTIMER hAbout, ByVal &HFEED, 10, ByVal %NULL
    Case %WM_TIMER
      If Active = 0 Then
        Active = 1
        SetTimer hAbout, ByVal &HFEED, 30000, ByVal %NULL
        Beep
      Else
        Dialog End hAbout
      End If
    Case %WM_COMMAND
      If CbCtl = %CMD_ABOUT_OK Then Dialog End hAbout
    Case %WM_DESTROY
      Active = 0
      KillTimer hAbout, &HFEED
 End Select
End Function
 
'--------------------------------------------------------------------------------------------------
Function AboutDialog () As Long
  Dialog Disable hDlg
  Local lString As String, MStat As MEMORYSTATUS, lZStr As Asciiz * 64
  Dialog New hDlg ,"About Toolbitmap Creator" ,,, 200, 160, _
            %DS_MODALFRAME Or %WS_CAPTION Or %WS_POPUP, %WS_EX_TOPMOST, To hAbout
  MStat.dwLength = SizeOf (MStat)
  GlobalMemoryStatus MStat
  Control Add Frame,  hAbout, -1, "", 0, 0,  200,135
  Control Add Image,  hAbout, -1, "TOOLTOOL", 5,15,18,18
  Control Add Label,  hAbout, -1, AppName + " - " + AppVersion, 35, 10, 160, 10
  Control Add Label,  hAbout, -1, AppCopyright, 35, 20, 160, 10
  Control Add Label,  hAbout, -1, "Memory (Kb) :" + Str$(MStat.dwTotalPhys\1024), 35, 30,160, 10
  Control Add Label,  hAbout, -1, "", 35, 40,160, 10
  Control Add Label,  hAbout, -1, "", 35, 50,160, 10
  Control Add Label,  hAbout, -1, "", 35, 60, 150, 10
  Control Add Line,   hAbout, -1, "", 35, 75, 180, 1
  Control Add Label,  hAbout, -1, "This program creates toolbar bitmaps from "  , 35, 80,160, 10
  Control Add Label,  hAbout, -1, "from icons. Just drag an icon from Exlorer"  , 35, 90,160, 10
  Control Add Label,  hAbout, -1, "onto a button.(right mouse key = delete)  "  , 35,100,160, 10
  Control Add Label,  hAbout, -1, "Any existing Copyright on icon images you "  , 35,110,160, 10
  Control Add Label,  hAbout, -1, "are using needs to be respected."            , 35,120,160, 10
  Control Add Button, hAbout, %CMD_ABOUT_OK,"OK"                     ,75,140, 30, 15
  Dialog Show Modal   hAbout Call AboutCallBack
  Dialog Enable hDlg
End Function
 
'==================================================================================================
' GetBitmapsFromIcon (Iconpath As String,Bmppath As String)
'                       This function returns two bitmaps, extracted from an icon (if the icon
'                       icon holds both 16x16 and 32x32 pixel maps.
' Return values:        16 = Only 16x16 bitmap found
'                       32 = Only 32x32 bitmap found
'                        0 = OK, 2 bitmaps found
'                       -1 = File not found
'                       -2 = File is not an icon file or unsupported format
'                       -3 = Icon is RLE compressed
'==================================================================================================
Function GetBitmapsFromIcon (IconPath As String, BmpPath As String, IconNumber As Long) As Long
  Local lFile   As Long
  Local lString As String
  Local lCnt    As Long
  Local lRet    As Long
  Local uNibb   As Byte
  Local lNibb   As Byte
  Local Ifh     As ICONFILEHEADER
  Local Ide()   As ICONDIRENTRY
  Local Img16   As ICONIMAGE16
  Local Img32   As ICONIMAGE32
  Local Bih     As BITMAPINFOHEADER
  Local Bfh     As BITMAPFILEHEADER
 
'...................../ See if Icon file exists, open and read it (end if no bitmaps) /............
 
  If (Dir$(IconPath) = "") Then Function = -1 : Exit Function               'See if file exists
  lFile = FreeFile : Open IconPath For Binary As #lFile                     '
  Get$ #lFile, Lof(#lFile), lString                                         '
  Close #lFile                                                              '
  Poke$ VarPtr(Ifh), Left$(lString, 6)                                      '
  If (Ifh.IconCount < 1) Or (Ifh.ResType <> 1) Then                         '
    Function = -2                                                           '
    Exit Function                                                           'No bmp or wrong type
  End If
 
'...................../ Found icon(s), extract 16 and 32 pixel bitmaps if any /....................
 
  ReDim Ide(Ifh.IconCount -1)                                               'Resize DIRENTRY array
  Poke$ VarPtr(Ide(0)), Mid$(lString, 7, Ifh.IconCount * 16)                'Get ICONDIRENTRY's
  Bm16(IconNumber) = %FALSE : Bm32(IconNumber) = %FALSE                     '
  For lCnt = 0 To Ifh.IconCount -1                                          'Check all bitmaps
    If (Ide(lCnt).bNumColors > 0) And (Ide(lCnt).bNumColors <= 16) Then     'Rev 002: was ACCESSERR
      If (Ide(lCnt).bWidth = 16) And (Ide(lCnt).bHeight = 16) Then          'If it's 16 pixels,
        Poke$ VarPtr(Img16), Mid$(lString, Ide(lCnt).dwDataOffset +1, _     '
                                  Ide(lCnt).dwDataSize)                     'save it
        For lCnt = 2 To 31                                                  'Because the AND table
          lRet = lCnt * 2                                                   'with 16 pixel icons
          If lCnt Mod 2 Then Decr lRet                                      'is Dword aligned, we
          Img16.icAND(lCnt) = Img16.icAND(lRet)                             'need to remove byte
        Next                                                                '3 and 4 of entries.
        Bm16(IconNumber) = %TRUE                                            'Set flag
      ElseIf (Ide(lCnt).bWidth = 32) And (Ide(lCnt).bHeight = 32) Then      'If it's 32 pixels,
        Poke$ VarPtr(Img32), Mid$(lString, Ide(lCnt).dwDataOffset +1, _     '
                                  Ide(lCnt).dwDataSize)                     'save it
        Bm32(IconNumber) = %TRUE                                            'Set flag
      End If                                                                '
    End If                                                                  'Rev 002
  Next                                                                      '
 
'...................../ Processing 16 pixel bitmap /...............................................
 
  If Bm16(IconNumber) Then
    For lCnt = 0 To 15                                                      'Create cross reference
      Array Scan CTab(), = Img16.icCol(lCnt), To RCol(lCnt)                 'table for default and
      Decr RCol(lCnt)                                                       'icon bitmap colors
    Next                                                                    '
    ReDim Bmp(127)                                                          '
    For lCnt = 0 To 127                                                     'Save icon bitmap to
      lNibb = Img16.icXOR(lCnt) And &h0F                                    'bitmap-bitmap and
      uNibb = (Img16.icXOR(lCnt)\16)                                        '
      Bmp(lCnt) = RCol(uNibb) * 16 + RCol(lNibb)                            'adjust for AND bit-
      If (Bit(Img16.icAND(lCnt\4),7-((lCnt*2+1) Mod 8))) Then               'map transparent bits
        Bmp(lCnt) = (Bmp(lCnt) And &hF0) Or &h08                            '(because bitmaps don't
      End If                                                                'support transparency)
      If (Bit(Img16.icAND(lCnt\4),7-((lCnt*2) Mod 8))) Then                 'Just set it to the
        Bmp(lCnt) = (Bmp(lCnt) And &h0F) Or &h80                            'default windows grey
      End If                                                                '
    Next                                                                    '
 
'...................../ Write bitmap16 file to disk /..............................................
 
    lString = AppPath + Trim$(Str$(IconNumber)) + ".B16"                    'Output file name
    lFile = FreeFile
    Bfh.bfType       = Cvi ("BM")
    Bfh.bfSize       = 246
    Bfh.bfReserved1  = 0
    Bfh.bfReserved2  = 0
    Bfh.bfOffBits    = 118
 
    Bih.biSize       = SizeOf(Bih)
    Bih.biPlanes     = 1
    Bih.biBitCount   = 4
    Bih.biWidth      = 16
    Bih.biHeight     = 16
    Bih.biSizeImage  = 128
 
    Open lString For Binary As #lFile
    Put$ #lFile, Peek$(VarPtr(Bfh), SizeOf(Bfh))
    Put$ #lFile, Peek$(VarPtr(Bih), SizeOf(Bih))
    Put$ #lFile, Peek$(VarPtr(CTab(0)), 64)
    Put$ #lFile, Peek$(VarPtr(Bmp(0)), 16 * 16 \ 2)
    Close #lFile
  End If
 
'...................../ Processing 32 pixel bitmap /...............................................
 
  If Bm32(IconNumber) Then
    For lCnt = 0 To 15                                                      'Create cross reference
      Array Scan CTab(), = Img32.icCol(lCnt), To RCol(lCnt)                 'table for default and
      Decr RCol(lCnt)                                                       'icon bitmap colors
    Next                                                                    '
    ReDim Bmp(511)                                                          '
    For lCnt = 0 To 511                                                     'Save icon bitmap to
      lNibb = Img32.icXOR(lCnt) And &h0F                                    '
      uNibb = (Img32.icXOR(lCnt) \ 16) And &h0F                             'bitmap-bitmap and
      Bmp(lCnt) = RCol(uNibb) * 16 + RCol(lNibb)                            'adjust for AND bit-
      If (Bit(Img32.icAND(lCnt\4),7-((lCnt*2+1) Mod 8))) Then               'map transparent bits
        Bmp(lCnt) = (Bmp(lCnt) And &hF0) Or &h08                            '(because bitmaps don't
      End If                                                                'support transparency)
      If (Bit(Img32.icAND(lCnt\4),7-((lCnt*2) Mod 8))) Then                 'Just set it to the
        Bmp(lCnt) = (Bmp(lCnt) And &h0F) Or &h80                            'default windows grey
      End If                                                                '
    Next                                                                    '
 
'...................../ Write bitmap32 file to disk /..............................................
 
    lString = AppPath + Trim$(Str$(IconNumber)) + ".B32"                    'Output file name
    lFile = FreeFile                                                        '
    Bfh.bfType       = Cvi ("BM")
    Bfh.bfSize       = 630
    Bfh.bfReserved1  = 0
    Bfh.bfReserved2  = 0
    Bfh.bfOffBits    = 118
 
    Bih.biSize       = SizeOf(Bih)
    Bih.biPlanes     = 1
    Bih.biBitCount   = 4
    Bih.biWidth      = 32
    Bih.biHeight     = 32
    Bih.biSizeImage  = 512
 
    Open lString For Binary As #lFile                                       '
    Put$ #lFile, Peek$(VarPtr(Bfh), SizeOf(Bfh))
    Put$ #lFile, Peek$(VarPtr(Bih), SizeOf(Bih))
    Put$ #lFile, Peek$(VarPtr(CTab(0)), 64)
    Put$ #lFile, Peek$(VarPtr(Bmp(0)), 32 * 32 \ 2)
    Close #lFile
  End If
  If (Bm16(IconNumber)) And (Bm32(IconNumber)) Then
    Function = 0
  ElseIf (Bm16(IconNumber)) Then
    Function = 16
  ElseIf (Bm32(IconNumber)) Then
    Function = 32
  ElseIf (Bm16(IconNumber) =0) And (Bm32(IconNumber) =0) Then
    Function = -2
  End If
End Function                                                                                    '
 
'==================================================================================================
' CompressFile - Removes unused trailing icons from bitmap
'==================================================================================================
Function CompressFile() As Long
  Local lCnt    As Long
  Local lString As String
  For lCnt = %MAXBUTTONS To 1 Step -1                                       '
    If TBmpName(lCnt) <> "" Then Exit For                                   '
  Next                                                                      '
  hLast = lCnt                                                              '
  If hLast > 0 Then                                                         '
    For lCnt = 0 To gBmpSize-1                                              '
      lString = lString + Peek$(VarPtr(TBmpPels(0)) + (lCnt *(gBmpSize\2) _ '
                                * %MAXBUTTONS), hLast * (gBmpSize\2))       '
    Next                                                                    '
'    ReDim TBmpPels(hLast * gBmpSize * gBmpSize \ 2)                        'Rev 002 removed
     TbBmpPix = lString
'    Poke$ VarPtr(TBmpPels(0)), lString                                      '
    Function = Len(lString)                                                 '
  End If                                                                    '
End Function                                                                '
 
'==================================================================================================
' SaveTbBmp - Saves Toolbar bitmap to disk
'==================================================================================================
 Function SaveTbBmp(pString As String) As Long
  Local BIH     As BITMAPINFOHEADER
  Local BFH     As BITMAPFILEHEADER
  Local lString As String
  Local lFile   As Long
 
  BFH.bfType               =  Cvi ("BM")                                    'Start marker 'BM'
  BFH.bfSize               =  (hLast* gBmpSize *gBmpSize) \ 2 + 118         'Size of file
  BFH.bfReserved1          =  0                                             '
  BFH.bfReserved2          =  0                                             '
  BFH.bfOffBits            =  118                                           'Offset to bitmap
  BIH.biSize               =  SizeOf(BIH)                                   '
  BIH.biWidth              =  gBmpSize * hLast                              'Bitmap width and
  BIH.biHeight             =  gBmpSize                                      'height
  BIH.biPlanes             =  1                                             '
  BIH.biBitCount           =  4                                             'Bits per pixel
  BIH.biCompression        =  %BI_RGB                                       'No compression
  BIH.biXPelsPerMeter      =  0                                             '
  BIH.biYPelsPerMeter      =  0                                             '
  BIH.biClrUsed            =  0                                             '
  BIH.biClrImportant       =  0                                             '
  BIH.biSizeImage          =  (hLast * gBmpSize * gBmpSize) \ 2             'Bitmap data size
 
  lFile = FreeFile : Open pString For Binary As #lFile                      'Write to file
  Put$ #lFile, Peek$(VarPtr(BFH), SizeOf(BFH))                              '
  Put$ #lFile, Peek$(VarPtr(BIH), SizeOf(BIH))                              '
  Put$ #lFile, Peek$(VarPtr(CTab(0)), 64)                                   '
  Put$ #lFile, TbBmpPix 'Peek$(VarPtr(TBmpPels(0)), hLast * gBmpSize * gBmpSize\2)    '
  Close lFile                                                               '
 End Function
 
'==================================================================================================
' SubClassButton - The subclass callback for buttons
'==================================================================================================
 Function SubClassButton (ByVal hWnd As Dword, _
                          ByVal wMsg As Long, _
                          ByVal wParam As Long, _
                          ByVal lParam As Long) As Long
   Local lRet       As Long
   Local lSel       As Long
   Local lZStr      As Asciiz * %MAX_PATH
   Local lString    As String
   Local lp         As POINTAPI
   Local lPopUp     As Long
   Local lCnt       As Long
   Local hDc        As Long
   Local hDch       As Long
   Local lRow       As Long
   Local lCol       As Long
   Local PixPos     As Long
   Local Pix        As Long
   Local lRgbQ      As RGBQUAD
   Local hImg       As Dword
 
   Array Scan hButton(), = hWnd, To lSel : Decr lSel                        'See who's calling
 
   Select Case wMsg                                                         '
     Case %WM_DROPFILES                                                     '
       DragQueryFile wParam, 0, lzStr, SizeOf (lzStr)                       'Get dropped file
       lzStr = LCase$(lzStr)                                                '
       lString = lzStr                                                      '
       lRet = GetBitmapsFromIcon(lString,ByCopy AppPath,lSel)               'Extract bitmaps
       lString = ""                                                         '
       Select Case lRet                                                     '
         Case  0,16,32                                                      '
           TBmpName(lSel) = lzStr                                           'Save icon name
           If gBmpSize = 16 Then                                            '16x16?
             If Bm16(lSel) Then                                             '
               lzStr = AppPath + Trim$(Str$(lSel)) + ".B16"                 '
             ElseIf Bm32(lSel) Then                                         '
               AddEvent "Shrinking 32x32 bitmap in " + lzStr                '
               WinBeep 1600,100                                             '
               lzStr = AppPath + Trim$(Str$(lSel)) + ".B32"                 '
             End If                                                         '
           Else                                                             '
             If Bm32(lSel) Then                                             '24x24 or 32x32
               lzStr = AppPath + Trim$(Str$(lSel)) + ".B32"                 '
             ElseIf Bm16(lSel) Then                                         '
               AddEvent "Stretching 16x16 bitmap in " + lzStr               '
               WinBeep 1600,100                                             '
               lzStr = AppPath + Trim$(Str$(lSel)) + ".B16"                 '
             End If                                                         '
           End If                                                           '
           If lzStr <> "" Then                                              '
             hImg = LoadImage(ByVal 0, lzStr, %IMAGE_BITMAP, gBmpSize, _    '
                        gBmpSize, %LR_LOADFROMFILE Or %LR_CREATEDIBSECTION) '
             Incr LoadedIcons                                               '
             Control Send hDlg,%BUTTON +lSel,%BM_SETIMAGE,%IMAGE_BITMAP,hImg'
             AddEvent TBmpName(lSel) + " loaded at button" + Str$(lSel)     '
             hDc = GetDc (hWnd)                                             'Now we extract the
             hDch = CreateCompatibleDc(hDc)                                 'pixel data
             SelectObject hDch, hImg                                        '
             For lRow = 0 To gBmpSize-1                                     '
               For lCol = 0 To gBmpSize-1                                   '
                 PixPos = (%MAXBUTTONS * (gBmpSize\2) * lRow) + _           '
                           ((lSel-1) * gBmpSize\2) + lCol \ 2               '
                 lRet = GetPixel(hDch, lCol, gBmpSize -lRow -1)             '
                 lRgbQ.RgbRed     = LoByt(LoWrd(lRet))                      '
                 lRgbQ.RgbGreen   = HiByt(LoWrd(lRet))                      '
                 lRgbQ.RgbBlue    = LoByt(HiWrd(lRet))                      '
                 Array Scan CTab(), = lRgbQ, To Pix : Decr Pix              'Get color index
                 If (lCol+1) Mod 2 Then                                     '
                   TBmpPels(PixPos)=(TBmpPels(PixPos) And &h0F) Or (Pix *16)'
                 Else                                                       '
                   TBmpPels(PixPos)=(TBmpPels(PixPos) And &hF0) Or Pix      '
                 End If                                                     '
               Next                                                         '
             Next                                                           '
             ReleaseDc hWnd, hDc                                            '
             DeleteDc hDch                                                  '
           End If                                                           '
         Case -1                                                            '
           AddEvent lzStr + " doesn't exist"                                '
           WinBeep 1600,50                                                 '
         Case -2                                                            '
           AddEvent lzStr + " isn't icon file or wrong format"              '
           WinBeep 1600,50                                                 '
         Case -3                                                            '
           AddEvent lzStr + " RLE compressed; unsupported"                  '
           WinBeep 1600,50                                                 '
       End Select                                                           '
 
'---------------------/ Create popup menu /--------------------------------------------------------
 
     Case %WM_RBUTTONDOWN                                                   'Right mouse button
      GetCursorPos lp                                                       'popup menu
      Menu New PopUp To lPopup                                              '
      Control Send hDlg, %BUTTON +lSel,%BM_GETIMAGE,%IMAGE_BITMAP,0 To lRet '
      If lRet Then lRet = %MF_ENABLED Else lRet = %MF_GRAYED                '
      Menu Add String, lPopup, "Delete picture", 4001, lRet                 '
      TrackPopupMenu lPopup, %TPM_LEFTALIGN Or %TPM_RIGHTBUTTON, _          '
                     lp.x, lp.y, 0, hButton(lSel), ByVal 0                  '
      Function = 0                                                          '
      Exit Function                                                         '
     Case %WM_COMMAND                                                       '
        Select Case LoWrd (wParam)                                          '
          Case 4001                                                         '
            Control Send hDlg, %BUTTON +lSel,%BM_SETIMAGE,%IMAGE_BITMAP,0   '
             Exit Function                                                  '
            TBmpName(lSel) = ""                                             '
            Decr LoadedIcons                                                '
        End Select
   End Select                                                               '
   If (lSel < 0) Or IsFalse hOldButton(lSel) Then Exit Function             '
   Function = CallWindowProc(hOldButton(lSel), hWnd, wMsg, Wparam, Lparam)  '
 End Function                                                               '
 
'==================================================================================================
' Main callback
'==================================================================================================
  CallBack Function CbMain
    Local lCnt As Long, lRet As Long, lString As String
    Static TimerActive As Long, OldTabText As String
    Select Case CbMsg                                                       '
      Case %WM_INITDIALOG                                                   'Set subclass procs
        For lCnt = 1 To %MAXBUTTONS                                         '
          hOldButton(lCnt) = SetWindowLong (hButton (lCnt),%GWL_WNDPROC, _  '
                                            CodePtr(SubClassButton))        '
          Kill AppPath + Trim$(Str$(lCnt)) + ".B16"                         'If bmp's exist, kill
          Kill AppPath + Trim$(Str$(lCnt)) + ".B32"                         'them
        Next                                                                '
        PostMessage CbHndl, %WM_COMMAND, %MENU_ABOUT,0                      'Show about box
      Case %WM_SETFOCUS                                                     'Rev 003
        UpdateWindow hDlg                                                   'Rev 003
      Case %WM_COMMAND                                                      '
        Select Case CbCtl                                                   '
          Case %MENU_SAVE                                                   'Save toolbitmap
            lString = "Tbb" + Trim$(Str$(gBmpSize)) + ".bmp"                '
            If LoadedIcons Then                                             '
              If SaveFileDialog(hDlg, _                                     '
                        "Save as:", _                                       '
                        lString, _                                          '
                        AppPath, _                                          '
                        "*.bmp", _                                          '
                        ".bmp", _                                           '
                        %OFN_HIDEREADONLY Or %OFN_OVERWRITEPROMPT) Then     '
                If Dir$(lString) <> "" Then Kill lString                    'Kill toolbitmap
                CompressFile                                                'Compress bmp
                SaveTbBmp lString                                           'Save toolbitmap
                AddEvent "Toolbitmap saved as: "+ lString + _               '
                "("+ Trim$(Str$(hLast*gBmpSize*gBmpSize\2 +118))+" bytes)"  '
                LoadedIcons = 0                                             '
              End If                                                        '
            End If                                                          '
          Case %MENU_EXIT                                                   '
            Dialog Disable HDlg                                             '
            If LoadedIcons Then                                             '
              LRet = MsgBox ("Active files are not saved." + Chr$(13) + _   '
                     "Are you sure?",%MB_ICONQUESTION Or %MB_OKCANCEL Or _  '
                     %MB_DEFBUTTON2 Or %MB_TOPMOST, AppName + ", confirm:") '
              If (LRet <> 1) Then                                           '
                Dialog Enable hDlg                                          '
                Dialog Send hDlg, %WM_SETFOCUS,0,0                          '
                Exit Select                                                 '
              End If                                                        '
            End If                                                          '
            Dialog End HDlg                                                 '
          Case %MENU_ABOUT                                                  '
            AboutDialog                                                     '
          Case %WM_DESTROY                                                  '
            For lCnt = 1 To %MAXBUTTONS                                     'Restore procs
              SetWindowLong hButton (lCnt),%GWL_WNDPROC, hOldButton(lCnt)   '
              Kill AppPath + Trim$(Str$(lCnt)) + ".B16"                     '
              Kill AppPath + Trim$(Str$(lCnt)) + ".B32"                     '
            Next                                                            '
      End Select                                                            '
    End Select                                                              '
  End Function                                                              '
 
'=====================/ Main Program function /====================================================
 
Union CQ
  Rq  As RGBQUAD
  Dw  As Dword
End Union
 
Function WinMain (ByVal CurInst&, ByVal PrvInst&, CmdLine As Asciiz Ptr, _
                  ByVal CmdShow&) Export As Long
  Local lCnt    As Long
  Local lString As String
  Local lzStr   As Asciiz * %MAX_PATH
 
  Local BCol As CQ
  BCol.Dw = GetSysColor(%BACKGROUNDCOLOR)
 
  If InStr(Command$, "16") Then                                             '
    gBmpSize = 16 : gBSize = 14                                             '
  ElseIf InStr(Command$, "32") Then                                         '
    gBmpSize = 32 : gBSize = 25                                             '
  Else                                                                      '
    gBmpSize = 24 : gBSize = 20                                             '
  End If                                                                    '
                                                                             '
  AppName         = "ToolBar Bitmap Creator"                                '
  AppVersion      = "Version 1.00, rev 005"                                 '
  AppCopyRight    = "Copyright 2002, P.Lameijn (freeware)"                  '
  GetModuleFileName ByVal %NULL, lzStr, SizeOf (lzStr)                      '
  AppPath         = Left$(lzStr, InStr(-1, lzStr, "\"))                     '
 
'---------------------/ Set array sizes /----------------------------------------------------------
 
  ReDim hButton (%MAXBUTTONS), hOldButton (%MAXBUTTONS), hMenu(2), CTab(15) '
  ReDim TBmpPels((gBmpSize*gBmpSize*%MAXBUTTONS)\2), TBmpName(%MAXBUTTONS)  '
  ReDim Bm16(%MAXBUTTONS), Bm32(%MAXBUTTONS), RCol (15)                     '
  Reset CTab()
 
  For lCnt = 0 To UBound (TBmpPels)                                         '
    TBmpPels(lCnt) = &h88                                                   'Prefill array
  Next
 
'---------------------/ Fill default Color Table with it's values /--------------------------------
 
  CTab( 0).RgbBlue =  0: CTab( 0).RgbGreen =  0: CTab( 0).RgbRed =  0       '
  CTab( 1).RgbBlue =  0: CTab( 1).RgbGreen =  0: CTab( 1).RgbRed =128       '
  CTab( 2).RgbBlue =  0: CTab( 2).RgbGreen =128: CTab( 2).RgbRed =  0       '
  CTab( 3).RgbBlue =  0: CTab( 3).RgbGreen =128: CTab( 3).RgbRed =128       '
  CTab( 4).RgbBlue =128: CTab( 4).RgbGreen =  0: CTab( 4).RgbRed =  0       '
  CTab( 5).RgbBlue =128: CTab( 5).RgbGreen =  0: CTab( 5).RgbRed =128       '
  CTab( 6).RgbBlue =128: CTab( 6).RgbGreen =128: CTab( 6).RgbRed =  0       '
  CTab( 7).RgbBlue =128: CTab( 7).RgbGreen =128: CTab( 7).RgbRed =128       '
 
'---------------------/ Table entry for transparency replacement /---------------------------------
 
  CTab( 8).RgbBlue = BCol.Rq.RgbBlue: CTab( 8).RgbGreen = BCol.Rq.RgbGreen: CTab( 8).RgbRed =BCol.Rq.RgbRed
 
'--------------------------------------------------------------------------------------------------
  CTab( 9).RgbBlue =  0: CTab( 9).RgbGreen =  0: CTab( 9).RgbRed =255       '
  CTab(10).RgbBlue =  0: CTab(10).RgbGreen =255: CTab(10).RgbRed =  0       '
  CTab(11).RgbBlue =  0: CTab(11).RgbGreen =255: CTab(11).RgbRed =255       '
  CTab(12).RgbBlue =255: CTab(12).RgbGreen =  0: CTab(12).RgbRed =  0       '
  CTab(13).RgbBlue =255: CTab(13).RgbGreen =  0: CTab(13).RgbRed =255       '
  CTab(14).RgbBlue =255: CTab(14).RgbGreen =255: CTab(14).RgbRed =  0       '
  CTab(15).RgbBlue =255: CTab(15).RgbGreen =255: CTab(15).RgbRed =255       '
 
'---------------------/ Get/Set some general information /-----------------------------------------
 
  InitCommonControls                                                        'Initialize the common
  Local Icc As Init_Common_ControlsEx                                       'controls Dll and the
  Icc.dwSize = SizeOf(Icc)                                                  'extended classes
  Icc.dwIcc = %ICC_BAR_CLASSES                                              '
  InitCommonControlsEx Icc                                                  '
                                                                              '
'---------------------/ Create Main Dialog /-------------------------------------------------------
 
  Dialog New 0, AppName + " (" + Trim$(Str$(gBmpSize)) + "x" + _            '
                Trim$(Str$(gBmpSize)) + " pixelmode)",,,gBSize * 20 + 10, _ '
                           110, %WS_CAPTION To hDlg                         '
  For lCnt = 1 To %MAXBUTTONS                                               '
    Control Add Button, hDlg, %BUTTON + lCnt,"",lCnt*gBSize -(gBSize-5), _  '
                                            5,gBSize,gBSize, %BS_BITMAP     '
    Control Handle hDlg, %BUTTON + lCnt To hButton(lCnt)                    '
    Control Add Label , hDlg, -1, Trim$(Str$(lCnt)), lCnt * gBSize - _      '
                       (gBSize-5), gbSize+5,gBSize,gBSize, %SS_CENTER       '
    DragAcceptFiles hButton(lCnt), %TRUE                                    '
  Next                                                                      '
 
'----------------------/ Add Menubar to dialog /---------------------------------------------------
 
  Menu New Bar    To hMenu (0)                                              '
  Menu New PopUp  To hMenu (1)                                              '
  Menu Add PopUp,    hMenu (0), "&File"   , hMenu(1)      , %MF_ENABLED     '
  Menu Add String,   hMenu (1), "&Save"   , %MENU_SAVE    , %MF_ENABLED     '
  Menu Add String,   hMenu (1), "&Exit"   , %MENU_EXIT    , %MF_ENABLED     '
  Menu New PopUp  To hMenu (2)                                              '
  Menu Add PopUp ,   hMenu (0), "&Info"   , hMenu(2)      , %MF_ENABLED     '
  Menu Add String,   hMenu (2), "&About"  , %MENU_ABOUT   , %MF_ENABLED     '
  Menu Attach        hmenu (0), hdlg                                        '
 
'---------------------/ Add Statusbar and Listbox to dialog /--------------------------------------
 
Control Add "msctls_statusbar32", hDlg, %STATUSBAR, "", 0, 0, 0, 0, _       '
                                  %WS_CHILD Or %WS_VISIBLE                  '
Control Add ListBox, hDlg, %LISTBOX,, 5, 15 + gBSize, gBSize * 20, 70 - _   '
                          gBSize, %WS_VSCROLL Or %LBS_DISABLENOSCROLL Or _  '
                          %LBS_USETABSTOPS, %WS_EX_CLIENTEDGE               '
 
'---------------------/ Show dialog /--------------------------------------------------------------
                                                                               '
    Dialog Show Modal hDlg Call CbMain                                      '
  End Function                                                              '
'--------------------------------------------------------------------------------------------------

------------------
Peter.
mailto[email protected][email protected]</A>



[This message has been edited by Peter Lameijn (edited November 23, 2003).]

[Peter Simmonds]

Can't run program in PBWin 9

Hi

would like to use the program, but I get a "BYVAL required with pointers" error message on the FUNCTION WINMAIN...line when I try to compile it. Is there an easy way to convert the program to work with version 9 or am I doing something wrong?

Any help appreciated.

Peter

[José Roca]

Is there an easy way to convert the program to work with version 9...

Sure. Just add BYVAL before CmdLine.

Function WinMain (ByVal CurInst&, ByVal PrvInst&, [B][COLOR="Red"]BYVAL[/COLOR][/B] CmdLine As Asciiz Ptr, _
                  ByVal CmdShow&) Export As Long

[Peter Simmonds]

Thanks, works now, brilliant!