Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

Toolbar Bitmap Creator

Collapse
X
 
  • Filter
  • Time
  • Show
Clear All
new posts

  • Toolbar Bitmap Creator

    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).]
    Regards,
    Peter

  • #2
    Added sourcecode to post. Also added possibility to create 16x16
    and 32x32 bitmaps
    Code:
    '==================================================================================================
    ' 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).]
    Regards,
    Peter

    Comment


    • #3
      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

      Comment


      • #4
        Is there an easy way to convert the program to work with version 9...
        Sure. Just add BYVAL before CmdLine.

        Code:
        Function WinMain (ByVal CurInst&, ByVal PrvInst&, [B][COLOR="Red"]BYVAL[/COLOR][/B] CmdLine As Asciiz Ptr, _
                          ByVal CmdShow&) Export As Long
        Forum: http://www.jose.it-berater.org/smfforum/index.php

        Comment


        • #5
          Thanks, works now, brilliant!

          Comment

          Working...
          X