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

BMP to ICO sample

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

  • BMP to ICO sample

    The code is an altered version of the PowerBasic PWRPaint utility with added code to save images in ico files.

    'pbIconMaker.bas - used only for demonstration, but pretty usable
    'ToDo - add text capability (I already added and updated the post)
    ' - add grid
    ' - make background transparent (alphablending ?)
    Code:
    '====================================================================
    '  This is an altered version of
    '  PWRPAINT.BAS for PowerBASIC Compiler for Windows
    '  Copyright (c) 2005 - 2008 PowerBASIC, Inc.
    '  All Rights Reserved.
    '
    '  Besides saving the images in BMP files it also allows now ICO files.
    '  It supports 1, 4, 8 and 24 bit ico files. The default that is used is 24 bit.
    '
    '  The win32api.inc needs a little change:
    '  DECLARE FUNCTION GetDIBits LIB "GDI32.DLL" ALIAS "GetDIBits" (BYVAL hdc AS DWORD, BYVAL hBitmap AS DWORD, BYVAL nStartScan AS DWORD, BYVAL nNumScans AS DWORD, lpBits AS ANY, lpBI AS ANY, BYVAL wUsage AS DWORD) AS LONG
    '====================================================================
    
    #COMPILER PBWIN 9
    #COMPILE EXE
    #DIM ALL
    
    '#RESOURCE "PBICONMAKER.PBR"  'resource file
    
    #INCLUDE "C:\PBWin90\Projects\pbIconMaker\win32api.inc"     '<---   Change it as needed (see header info for GetDIBits)
    #INCLUDE "bmp2icon.bas"
    #INCLUDE "textentry.bas"
    
    %IDC_GRAPHIC1    = 101
    
    %IDC_LABELCOL1   = 111
    %IDC_LABELCOL2   = 112
    %IDC_LABELCOL3   = 113
    %IDC_LABELCOL4   = 114
    %IDC_LABELCOL5   = 115
    %IDC_LABELCOL6   = 116
    %IDC_LABELCOL7   = 117
    %IDC_LABELCOL8   = 118
    %IDC_LABELCOL9   = 119
    %IDC_LABELCOL10  = 120
    %IDC_LABELCOL11  = 121
    %IDC_LABELCOL12  = 122
    %IDC_LABELCOL13  = 123
    %IDC_LABELCOL14  = 124
    %IDC_LABELCOL15  = 125
    %IDC_LABELCOL16  = 126
    %IDC_LABELCOL17  = 127
    %IDC_LABELCOL18  = 128
    %IDC_LABELCOL19  = 129
    %IDC_LABELCOL20  = 130
    %IDC_LABELCOL21  = 131
    %IDC_LABELCOL22  = 132
    %IDC_LABELCOL23  = 133
    %IDC_LABELCOL24  = 134
    %IDC_LABELCOL25  = 135
    %IDC_LABELCOL26  = 136
    %IDC_LABELCOL27  = 137
    %IDC_LABELCOL28  = 138
    %IDC_LABELCOL29  = 139
    %IDC_LABELCOL30  = 140
    %IDC_LABELCOL31  = 141
    %IDC_LABELCOL32  = 142
    %IDC_LABELCOL33  = 143
    %IDC_LABELCOL34  = 144
    %IDC_LABELPOS    = 145
    %IDC_LABELINFO   = 146
    
    %IDC_BTNOPEN     = 150
    %IDC_BTNSAVE     = 151
    %IDC_BTNCLS      = 152
    %IDC_COMBOBOX1   = 161
    %IDC_COMBOBOX2   = 162
    %IDC_COMBOBOX3   = 163
    %IDC_FRAME1      = 171
    %IDC_FRAME2      = 172
    %IDC_OPTLINE     = 181
    %IDC_OPTFREE     = 182
    %IDC_OPTBEAM     = 183
    %IDC_OPTRBOX     = 184
    %IDC_OPTRECT     = 185
    %IDC_OPTCIRC     = 186
    %IDC_OPTOVAL     = 187
    %IDC_OPTFILL     = 188
    %IDC_OPTTEXTN    = 189
    %IDC_OPTTEXTS    = 190
    %IDC_OPTTEXTR    = 191
    %IDC_TEXT        = 192
    
    
    GLOBAL x, y, x2, y2 AS LONG
    GLOBAL OldX, OldY, OldX2, OldY2 AS LONG
    GLOBAL OldGraphicProc AS DWORD
    GLOBAL g_DrawOp       AS LONG
    GLOBAL g_Color        AS LONG
    GLOBAL g_FillColor    AS LONG
    GLOBAL g_FillStyle    AS LONG
    GLOBAL g_PenWidth     AS LONG
    GLOBAL g_CanDraw      AS LONG
    GLOBAL g_Radius       AS SINGLE
    
    GLOBAL tx, ty         AS LONG
    GLOBAL maindlg        AS DWORD
    GLOBAL g_textstyle    AS LONG           '0 - normal, 1 - sunken, 2 - raised
    
    DECLARE FUNCTION GetQBColor (BYVAL c AS LONG) AS LONG
    
    
    '====================================================================
    FUNCTION PBMAIN () AS LONG
    '--------------------------------------------------------------------
      ' PROGRAM ENTRANCE
      '------------------------------------------------------------------
      LOCAL c, h, w AS LONG, hDlg AS DWORD
    
      DIALOG NEW 0, "PowerPaint v 1.0", , , 301, 224, _
                    %WS_CAPTION OR %WS_SYSMENU, 0 TO hDlg
    
      '------------------------------------------------------------------
      CONTROL ADD GRAPHIC, hDlg, %IDC_GRAPHIC1,"", _
                           4, 4, 196, 181, %SS_NOTIFY, %WS_EX_CLIENTEDGE
    
      g_DrawOp    = %IDC_OPTLINE
      g_Color     = GetQBColor(0)
      g_FillColor = GetQBColor(7)
      g_FillStyle = 0
    
      GRAPHIC ATTACH hDlg, %IDC_GRAPHIC1
      GRAPHIC COLOR RGB(0,0,0), RGB(255,255,255)
      GRAPHIC CLEAR
      GRAPHIC WIDTH 1
    
      '------------------------------------------------------------------
      ' Setup pixel based coordinate system in the Graphic control
      '------------------------------------------------------------------
      CONTROL GET CLIENT hDlg, %IDC_GRAPHIC1 TO w, h    'get client size
      DIALOG UNITS hDlg, w, h TO PIXELS w, h            'convert to pixels
      GRAPHIC SCALE (0, 0) - (w, h)                     'scale to pixel coordinate system
    
      '------------------------------------------------------------------
      CONTROL ADD FRAME,  hDlg, %IDC_FRAME1,   "&Draw",  211,   1, 86, 170
        CONTROL ADD OPTION, hDlg, %IDC_OPTLINE,  "Line ",          216, 11, 75,  10
        CONTROL ADD OPTION, hDlg, %IDC_OPTFREE,  "Freehand ",      216, 21, 75,  10
        CONTROL ADD OPTION, hDlg, %IDC_OPTBEAM,  "Beams ",         216, 31, 75,  10
        CONTROL ADD OPTION, hDlg, %IDC_OPTRBOX,  "Rounded Box ",   216, 41, 75,  10
        CONTROL ADD OPTION, hDlg, %IDC_OPTRECT,  "Square Box ",    216, 51, 75,  10
        CONTROL ADD OPTION, hDlg, %IDC_OPTCIRC,  "Circle ",        216, 61, 75,  10
        CONTROL ADD OPTION, hDlg, %IDC_OPTOVAL,  "Oval ",          216, 71, 75,  10
        CONTROL ADD OPTION, hDlg, %IDC_OPTFILL,  "Fill area ",     216, 81, 75,  10
        CONTROL ADD OPTION, hDlg, %IDC_OPTTEXTN,  "Text normal ",     216, 91, 75,  10
        CONTROL ADD OPTION, hDlg, %IDC_OPTTEXTS,  "Text sunken ",     216, 101, 75,  10
        CONTROL ADD OPTION, hDlg, %IDC_OPTTEXTR,  "Text raised ",     216, 111, 75,  10
        CONTROL SET OPTION  hDlg, %IDC_OPTLINE, %IDC_OPTLINE, %IDC_OPTFILL
    
        CONTROL ADD COMBOBOX, hDlg, %IDC_COMBOBOX1,, _
                              216, 120, 76, 125, %CBS_DROPDOWNLIST OR %WS_TABSTOP
        COMBOBOX ADD hDlg, %IDC_COMBOBOX1, "Hollow"
        COMBOBOX ADD hDlg, %IDC_COMBOBOX1, "Solid"
        COMBOBOX ADD hDlg, %IDC_COMBOBOX1, "Horizontal lines"
        COMBOBOX ADD hDlg, %IDC_COMBOBOX1, "Vertical lines"
        COMBOBOX ADD hDlg, %IDC_COMBOBOX1, "Upward diagonal"
        COMBOBOX ADD hDlg, %IDC_COMBOBOX1, "Downward diagonal"
        COMBOBOX ADD hDlg, %IDC_COMBOBOX1, "Crossed lines"
        COMBOBOX ADD hDlg, %IDC_COMBOBOX1, "Diagonal crossed"
        COMBOBOX SELECT hDlg, %IDC_COMBOBOX1, 2
    
        CONTROL ADD COMBOBOX, hDlg, %IDC_COMBOBOX2,, _
                              216, 137, 76, 125, %CBS_DROPDOWNLIST OR %WS_TABSTOP
        COMBOBOX ADD hDlg, %IDC_COMBOBOX2, "Pen width =   1"
        COMBOBOX ADD hDlg, %IDC_COMBOBOX2, "Pen width =   2"
        COMBOBOX ADD hDlg, %IDC_COMBOBOX2, "Pen width =   3"
        COMBOBOX ADD hDlg, %IDC_COMBOBOX2, "Pen width =   4"
        COMBOBOX ADD hDlg, %IDC_COMBOBOX2, "Pen width =   5"
        COMBOBOX ADD hDlg, %IDC_COMBOBOX2, "Pen width =   6"
        COMBOBOX ADD hDlg, %IDC_COMBOBOX2, "Pen width =   7"
        COMBOBOX ADD hDlg, %IDC_COMBOBOX2, "Pen width =   8"
        COMBOBOX ADD hDlg, %IDC_COMBOBOX2, "Pen width =   9"
        COMBOBOX ADD hDlg, %IDC_COMBOBOX2, "Pen width = 10"
        COMBOBOX SELECT hDlg, %IDC_COMBOBOX2, 1
        g_PenWidth = 1
    
        CONTROL ADD COMBOBOX, hDlg, %IDC_COMBOBOX3,, _
                              216, 154, 76, 125, %CBS_DROPDOWNLIST OR %WS_TABSTOP
        COMBOBOX ADD hDlg, %IDC_COMBOBOX3, "Pen type = Solid"
        COMBOBOX ADD hDlg, %IDC_COMBOBOX3, "Pen type = Dash"
        COMBOBOX ADD hDlg, %IDC_COMBOBOX3, "Pen type = Dot"
        COMBOBOX ADD hDlg, %IDC_COMBOBOX3, "Pen type = DashDot"
        COMBOBOX ADD hDlg, %IDC_COMBOBOX3, "Pen type = DashDotDot"
        COMBOBOX SELECT hDlg, %IDC_COMBOBOX3, 1
    
      '------------------------------------------------------------------
        FOR c = 0 TO 15
            CONTROL ADD LABEL, hDlg, %IDC_LABELCOL1 + c, "", _
                               5 + c * 11, 190, 11, 10, %SS_NOTIFY OR %SS_SUNKEN
            CONTROL SET COLOR hDlg, %IDC_LABELCOL1 + c,  -1, GetQBColor(c)
            CONTROL ADD LABEL, hDlg, %IDC_LABELCOL17 + c, "", _
                               5 + c * 11, 200, 11, 10, %SS_NOTIFY OR %SS_SUNKEN
            CONTROL SET COLOR hDlg, %IDC_LABELCOL17 + c,  -1, GetQBColor(16 + c)
        NEXT
        CONTROL ADD LABEL, hDlg, %IDC_LABELCOL33,"", 185, 190, 21, 20, %SS_SUNKEN
        CONTROL SET COLOR hDlg, %IDC_LABELCOL33, -1, g_Color
        CONTROL ADD LABEL, hDlg, %IDC_LABELCOL34,"", 188, 193, 15, 14
        CONTROL SET COLOR hDlg, %IDC_LABELCOL34, -1, g_FillColor
    
      CONTROL ADD LABEL, hDlg, %IDC_LABELINFO, "", 5, 213, 210, 10
      CONTROL SET TEXT hDlg, %IDC_LABELINFO, _
                       "Color fields:  Left-click to set pen color.  " + _
                       "Right-click to set fill color."
    
      '------------------------------------------------------------------
      CONTROL ADD LABEL, hDlg, %IDC_LABELPOS, "Pos:",   214, 172, 80, 20
    
      CONTROL ADD BUTTON, hDlg, %IDC_TEXT,    "Text",  255, 206, 42, 14
      CONTROL ADD BUTTON, hDlg, %IDC_BTNOPEN, "&Open",  211, 189, 42, 14
      CONTROL ADD BUTTON, hDlg, %IDC_BTNSAVE, "Save",   255, 189, 42, 14
      CONTROL ADD BUTTON, hDlg, %IDC_BTNCLS,  "&Clear", 211, 206, 42, 14
      CONTROL ADD BUTTON, hDlg, %IDCANCEL,    "&Quit",  255, 206, 42, 14
    
      '------------------------------------------------------------------
      DIALOG SHOW MODAL hDlg CALL DlgProc
    
    END FUNCTION
    
    
    '====================================================================
    CALLBACK FUNCTION DlgProc() AS LONG
    '--------------------------------------------------------------------
      ' MAIN DIALOG'S CALLBACK PROCEDURE
      '------------------------------------------------------------------
    
      LOCAL lRes, x2, y2 AS LONG, dwStyle AS DWORD, f, sPath AS STRING, rc AS RECT
      STATIC oldFillColor AS LONG
    
       SELECT CASE AS LONG CB.MSG
          CASE %WM_INITDIALOG  ' <- Sent right before the dialog is shown
              STATIC hGraphic AS DWORD
              CONTROL HANDLE CB.HNDL, %IDC_GRAPHIC1 TO hGraphic
              OldGraphicProc = SetWindowLong(hGraphic, %GWL_WNDPROC, CODEPTR(GraphicProc))
              oldFillColor = g_FillColor
              DIALOG SET ICON CB.HNDL, "PROGRAM"
              CONTROL SHOW STATE CB.HNDL, %IDC_TEXT, %SW_HIDE
              maindlg = CB.HNDL
          CASE %WM_DESTROY     ' <- Sent when the dialog is about to be destroyed
              IF OldGraphicProc THEN
                  SetWindowLong hGraphic, %GWL_WNDPROC, OldGraphicProc
              END IF
    
          CASE %WM_PARENTNOTIFY   ' Detect left/right click in color labels
              LOCAL hCtrl AS DWORD, pt AS POINTAPI
    
              pt.x = LO(WORD, CB.LPARAM)
              pt.y = HI(WORD, CB.LPARAM)
              MapWindowPoints CB.HNDL, 0, pt, 1
              hCtrl = WindowFromPoint(pt.x, pt.y)
              lRes = GetDlgCtrlId(hCtrl)
    
              IF LO(WORD, CB.WPARAM) = %WM_LBUTTONDOWN THEN
                  SELECT CASE AS LONG lRes
                  CASE %IDC_LABELCOL1 TO %IDC_LABELCOL32
                      lRes = MAX&(0, lRes - %IDC_LABELCOL1)
                      g_Color = GetQBColor(lRes)
                      GRAPHIC ATTACH CB.HNDL, %IDC_GRAPHIC1
                      CONTROL SET COLOR CB.HNDL, %IDC_LABELCOL33, -1, g_Color
                      CONTROL REDRAW CB.HNDL, %IDC_LABELCOL33
                      CONTROL REDRAW CB.HNDL, %IDC_LABELCOL34
                  END SELECT
    
              ELSEIF LO(WORD, CB.WPARAM) = %WM_RBUTTONDOWN THEN
                  SELECT CASE AS LONG lRes
                  CASE %IDC_LABELCOL1 TO %IDC_LABELCOL32
                      lRes = MAX&(0, lRes - %IDC_LABELCOL1)
                      g_FillColor  = GetQBColor(lRes)
                      oldFillColor = g_FillColor
                      GRAPHIC ATTACH CB.HNDL, %IDC_GRAPHIC1
                      CONTROL SET COLOR CB.HNDL, %IDC_LABELCOL34, -1, g_FillColor
                      CONTROL REDRAW CB.HNDL, %IDC_LABELCOL34
                  END SELECT
              END IF
    
          CASE %WM_SETCURSOR   ' <- Sent on mouse move, etc
            IF CB.WPARAM <> hGraphic THEN
                CONTROL SET TEXT CB.HNDL, %IDC_LABELPOS, "Pos:"
            END IF
    
          CASE %WM_COMMAND     ' <- Sent from child controls
              '----------------------------------------------------------
              SELECT CASE AS LONG CB.CTL  ' ComboBox selections
              CASE %IDC_COMBOBOX1  ' fill style
                  IF CB.CTLMSG = %CBN_SELENDOK THEN
                      COMBOBOX GET SELECT CB.HNDL, %IDC_COMBOBOX1 TO g_FillStyle
                      DECR g_FillStyle
    
                      IF g_FillStyle = 0 THEN
                          oldFillColor = g_FillColor
                          g_FillColor = -2
                      ELSE
                          g_FillColor = oldFillColor
                      END IF
                      DECR g_FillStyle
                  END IF
                  EXIT FUNCTION
    
              CASE %IDC_COMBOBOX2  ' pen width
                  IF CB.CTLMSG = %CBN_SELENDOK THEN
                      COMBOBOX GET SELECT CB.HNDL, %IDC_COMBOBOX2 TO g_PenWidth
                      DECR g_PenWidth
                      GRAPHIC ATTACH CB.HNDL, %IDC_GRAPHIC1
                      g_PenWidth = MAX&(1, g_PenWidth + 1)
                      GRAPHIC WIDTH g_PenWidth
                      IF g_PenWidth = 1 THEN
                          CONTROL ENABLE CB.HNDL, %IDC_COMBOBOX3
                      ELSE
                          CONTROL DISABLE CB.HNDL, %IDC_COMBOBOX3
                      END IF
                  END IF
                  EXIT FUNCTION
    
              CASE %IDC_COMBOBOX3  ' pen type
                  IF CB.CTLMSG = %CBN_SELENDOK THEN
                      COMBOBOX GET SELECT CB.HNDL, %IDC_COMBOBOX3 TO lRes
                      DECR lRes
                      GRAPHIC ATTACH CB.HNDL, %IDC_GRAPHIC1
                      GRAPHIC STYLE lRes
                  END IF
                  EXIT FUNCTION
              END SELECT
    
              '----------------------------------------------------------
              IF CB.CTLMSG = %BN_CLICKED _           ' Button click
              OR CB.CTLMSG = 1 THEN
                  SELECT CASE AS LONG CB.CTL         ' Look at control's id
                  CASE %IDC_OPTLINE TO %IDC_OPTFILL
                      g_DrawOp = CB.CTL
                  CASE %IDC_OPTTEXTN, %IDC_OPTTEXTS, %IDC_OPTTEXTR
                      g_DrawOp = CB.CTL
                  CASE %IDC_BTNOPEN
                      sPath = CURDIR$
                      f     = "*.bmp"
                      dwStyle = %OFN_EXPLORER OR %OFN_FILEMUSTEXIST OR %OFN_HIDEREADONLY
    
                      DISPLAY OPENFILE CB.HNDL, , , "", sPath, _
                          CHR$("Bitmap Files", 0, "*.bmp", 0, "All Files", 0, "*.*", 0), _
                          "", "bmp", dwStyle TO f
                      IF LEN(f) THEN
                          ' Stretch the image to the Graphic control
                          CONTROL GET CLIENT CB.HNDL, %IDC_GRAPHIC1 TO x2, y2   'client size in Dlg Units
                          DIALOG UNITS CB.HNDL, x2, y2 TO PIXELS x2, y2         'convert to pixels
                          DECR x2 : DECR y2                                     'decr by one to match zero based area
                          GRAPHIC ATTACH CB.HNDL, %IDC_GRAPHIC1
                          GRAPHIC RENDER f, (0,0)-(x2,y2)                       'Render the image to the control
                          GRAPHIC REDRAW                                        'and redraw
                      END IF
    
                  CASE %IDC_BTNSAVE
                      sPath = CURDIR$
                      f     = "*.bmp"
                      dwStyle = %OFN_EXPLORER OR %OFN_PATHMUSTEXIST OR %OFN_HIDEREADONLY
                      DISPLAY SAVEFILE CB.HNDL, , , "", sPath, _
                          CHR$("Icon Files", 0, "*.ico", 0,"Bitmap Files", 0, "*.bmp", 0, "All Files", 0, "*.*", 0), _
                          "", "bmp", dwStyle TO f
    
                      IF LEN(f) THEN
                          LOCAL fl AS STRING
                          IF LCASE$(RIGHT$(f, 3)) = "ico" THEN
                              fl = LEFT$(f, LEN(f) - 3) & "bmp"
                          ELSE
                              fl = f
                          END IF
                          GRAPHIC ATTACH CB.HNDL, %IDC_GRAPHIC1
                          GRAPHIC SAVE fl
                          IF LCASE$(RIGHT$(f, 3)) = "ico" THEN
                              'convert it to icon and delete the original
                              ConvertToIcon CB.HNDL, fl
                              KILL fl
                          END IF
                      END IF
    
    
                  CASE %IDC_BTNCLS
                      GRAPHIC ATTACH CB.HNDL, %IDC_GRAPHIC1
                      GRAPHIC CLEAR
                      GRAPHIC REDRAW
    
                  CASE %IDCANCEL
                      DIALOG END CB.HNDL
                  CASE %IDC_TEXT
                    sEntryText = ""
                    DisplayTextEntry CB.HNDL
                    IF LEN(sEntryText) THEN
                        GRAPHIC FONT txt_fontname$,txt_points&, txt_style&
                        SELECT CASE g_textstyle
                            CASE 0
                                GRAPHIC COLOR g_FillColor, -2
                                GRAPHIC SET POS (tx, ty)
                                GRAPHIC PRINT sEntryText
                            CASE 1
                                GRAPHIC COLOR RGB(128, 0, 0), -2
                                GRAPHIC SET POS (tx - 1, ty - 1)
                                GRAPHIC PRINT sEntryText
    
                                GRAPHIC COLOR RGB(255, 255, 255), -2
                                GRAPHIC SET POS (tx + 1, ty + 1)
                                GRAPHIC PRINT sEntryText
    
                                GRAPHIC COLOR g_FillColor, -2
                                GRAPHIC SET POS (tx, ty)
                                GRAPHIC PRINT sEntryText
                            CASE 2
                                GRAPHIC COLOR RGB(255, 255, 255), -2
                                GRAPHIC SET POS (tx - 1, ty - 1)
                                GRAPHIC PRINT sEntryText
    
                                GRAPHIC COLOR RGB(128, 0, 0), -2
                                GRAPHIC SET POS (tx + 1, ty + 1)
                                GRAPHIC PRINT sEntryText
    
                                GRAPHIC COLOR g_FillColor, -2
                                GRAPHIC SET POS (tx, ty)
                                GRAPHIC PRINT sEntryText
                        END SELECT
                        GRAPHIC REDRAW
                    END IF
                  END SELECT
              END IF
    
      END SELECT
    END FUNCTION
    
    
    '====================================================================
    FUNCTION GetQBColor(BYVAL nColor AS LONG) AS LONG
    '--------------------------------------------------------------------
      ' Return RGB color for given QB color value
      '------------------------------------------------------------------
        SELECT CASE nColor
        CASE 0  : FUNCTION=RGB(0,0,0)       ' Black
        CASE 1  : FUNCTION=RGB(0,0,128)     ' Blue
        CASE 2  : FUNCTION=RGB(0,128,0)     ' Green
        CASE 3  : FUNCTION=RGB(0,128,128)   ' Cyan
        CASE 4  : FUNCTION=RGB(196,0,0)     ' Red
        CASE 5  : FUNCTION=RGB(128,0,128)   ' Magenta (Purple)
        CASE 6  : FUNCTION=RGB(128,64,0)    ' Brown
        CASE 7  : FUNCTION=RGB(196,193,196) ' White
        CASE 8  : FUNCTION=RGB(128,128,128) ' Gray
        CASE 9  : FUNCTION=RGB(0,0, 255)    ' Lt. Blue
        CASE 10 : FUNCTION=RGB(0,255,0)     ' Lt. Green
        CASE 11 : FUNCTION=RGB(0,255,255)   ' Lt. Cyan
        CASE 12 : FUNCTION=RGB(255,0,0)     ' Lt. Red
        CASE 13 : FUNCTION=RGB(255,0,255)   ' Lt. magenta (Purple)
        CASE 14 : FUNCTION=RGB(255,255,0)   ' Yellow
        CASE 15 : FUNCTION=RGB(255,255,255) ' Bright White
        CASE 16 : FUNCTION=RGB(164,164,164) ' - Extended QB colors Pastel version -
        CASE 17 : FUNCTION=RGB(128,160,255)
        CASE 18 : FUNCTION=RGB(160,255,160)
        CASE 19 : FUNCTION=RGB(160,255,255)
        CASE 20 : FUNCTION=RGB(255,160,160)
        CASE 21 : FUNCTION=RGB(255,160,255)
        CASE 22 : FUNCTION=RGB(255,255,160)
        CASE 23 : FUNCTION=RGB(212,212,212)
        CASE 24 : FUNCTION=RGB(180,180,180)
        CASE 25 : FUNCTION=RGB(188,220,255)
        CASE 26 : FUNCTION= RGB(220,255,220)
        CASE 27 : FUNCTION=RGB(220,255,255)
        CASE 28 : FUNCTION=RGB(255,220,220)
        CASE 29 : FUNCTION=RGB(255,220,255)
        CASE 30 : FUNCTION=RGB(255,255,220)
        CASE 31 : FUNCTION=RGB(228,228,228)
        CASE ELSE : FUNCTION=RGB(0,0,0)
        END SELECT
    END FUNCTION
    
    
    '====================================================================
    FUNCTION GraphicProc (BYVAL hWnd AS DWORD, BYVAL wMsg AS DWORD, _
                          BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
    '--------------------------------------------------------------------
      ' Subclass procedure
      '------------------------------------------------------------------
      SELECT CASE wMsg
          CASE %WM_LBUTTONDOWN : CALL OnGraphic_LeftButtonDown (hWnd, wParam, lParam)
          CASE %WM_MOUSEMOVE   : CALL OnGraphic_MouseMove      (hWnd, wParam, lParam)
          CASE %WM_LBUTTONUP   : CALL OnGraphic_LeftButtonUp   (hWnd, wParam, lParam)
      END SELECT
    
      FUNCTION = CallWindowProc (OldGraphicProc, hWnd, wMsg, wParam, lParam)
    END FUNCTION
    
    
    '====================================================================
    SUB OnGraphic_LeftButtonDown (BYVAL hWnd AS DWORD, _
                                  BYVAL wParam AS DWORD, BYVAL lParam AS LONG)
    '--------------------------------------------------------------------
      ' %WM_LBUTTONDOWN handler for subclass procedure
      '------------------------------------------------------------------
      LOCAL lRes AS LONG
    
      SetCapture hWnd
      SetFocus hWnd
      GRAPHIC ATTACH GetParent(hWnd), %IDC_GRAPHIC1, REDRAW
    
      x = MAX&(0, LO(INTEGER, lParam))
      y = MAX&(0, HI(INTEGER, lParam))
      OldX  = x
      OldY  = y
      OldX2 = x
      OldY2 = y
    
      SELECT CASE g_DrawOp
      CASE %IDC_OPTLINE ' Draw straight line
          GRAPHIC SET MIX %R2_NOTXORPEN
          GRAPHIC LINE (x,y)-(x,y), g_Color
          GRAPHIC REDRAW
    
      CASE %IDC_OPTFREE ' Draw freehand line
          GRAPHIC SET MIX %R2_COPYPEN
          GRAPHIC LINE (x,y)-(x,y), g_Color
          GRAPHIC REDRAW
    
      CASE %IDC_OPTBEAM     ' Draw Beams
          GRAPHIC SET MIX %R2_COPYPEN
          GRAPHIC LINE (x,y)-(x,y), g_Color
          GRAPHIC REDRAW
    
      CASE %IDC_OPTRBOX, %IDC_OPTRECT  ' Draw Box
          GRAPHIC SET MIX %R2_NOTXORPEN
    
      CASE %IDC_OPTCIRC, %IDC_OPTOVAL  ' Draw Circle or Oval
          GRAPHIC SET MIX %R2_NOTXORPEN
    
      CASE %IDC_OPTFILL     ' Fill area
          GRAPHIC GET PIXEL (x, y) TO lRes
          GRAPHIC PAINT REPLACE (x,y), g_FillColor, lRes, MAX&(0, g_FillStyle)
          GRAPHIC REDRAW
      CASE %IDC_OPTTEXTN    'normal text
          tx = x: ty = y: g_textstyle = 0
          PostMessage maindlg, %WM_COMMAND, MAKDWD(%IDC_TEXT,%BN_CLICKED), GetDlgItem(maindlg,%IDC_TEXT)
      CASE %IDC_OPTTEXTs    'sunken text
          tx = x: ty = y: g_textstyle = 1
          PostMessage maindlg, %WM_COMMAND, MAKDWD(%IDC_TEXT,%BN_CLICKED), GetDlgItem(maindlg,%IDC_TEXT)
      CASE %IDC_OPTTEXTR    'raised text
          tx = x: ty = y: g_textstyle = 2
          PostMessage maindlg, %WM_COMMAND, MAKDWD(%IDC_TEXT,%BN_CLICKED), GetDlgItem(maindlg,%IDC_TEXT)
      END SELECT
    
      g_CanDraw = 1
    
      CONTROL SET TEXT GetParent(hWnd), %IDC_LABELPOS, _
                       "Pos:" + STR$(x) + "," + STR$(y)
    
    END SUB
    
    
    '====================================================================
    SUB OnGraphic_MouseMove (BYVAL hWnd AS DWORD, _
                             BYVAL wParam AS DWORD, BYVAL lParam AS LONG)
    '--------------------------------------------------------------------
      ' %WM_MOUSEMOVE handler for subclass procedure
      '------------------------------------------------------------------
      LOCAL lCorner AS LONG, sText AS STRING
      x2 = LO(INTEGER, lParam)
      y2 = HI(INTEGER, lParam)
    
      IF g_CanDraw AND (wParam AND %MK_LBUTTON) THEN
          SELECT CASE g_DrawOp
          CASE %IDC_OPTLINE     ' Draw straight line
              IF OldX > -1 THEN
                  GRAPHIC LINE (OldX,OldY)-(OldX2,OldY2), g_Color
              END IF
              GRAPHIC LINE (x,y)-(x2,y2), g_Color
              OldX  = x
              OldY  = y
              OldX2 = x2
              OldY2 = y2
    
          CASE %IDC_OPTFREE     ' Draw freehand line
              GRAPHIC LINE (x,y)-(x2,y2), g_Color
              x = x2
              y = y2
    
          CASE %IDC_OPTBEAM     ' Draw Beams
              GRAPHIC LINE (x,y)-(x2,y2), g_Color
    
          CASE %IDC_OPTRBOX, %IDC_OPTRECT  ' Draw Box
              IF g_DrawOp = %IDC_OPTRBOX THEN
                  lCorner = 20
              END IF
              IF OldX > -1 THEN
                  IF (OldX <= OldX2) AND (OldY >= OldY2) THEN
                      GRAPHIC BOX (OldX,OldY2)-(OldX2,OldY), lCorner, g_Color, -2, 0
                  ELSEIF (OldX > OldX2) AND (OldY > OldY2) THEN
                      GRAPHIC BOX (OldX2,OldY2)-(OldX,OldY), lCorner, g_Color, -2, 0
                  ELSEIF (OldX >= OldX2) AND (OldY <= OldY2) THEN
                      GRAPHIC BOX (OldX2,OldY)-(OldX,OldY2), lCorner, g_Color, -2, 0
                  ELSE
                      GRAPHIC BOX (OldX,OldY)-(OldX2,OldY2), lCorner, g_Color, -2, 0
                  END IF
              END IF
              IF (x <= x2) AND (y >= y2) THEN
                  GRAPHIC BOX (x,y2)-(x2,y), lCorner, g_Color, -2, 0
              ELSEIF (x > x2) AND (y > y2) THEN
                  GRAPHIC BOX (x2,y2)-(x,y), lCorner, g_Color, -2, 0
              ELSEIF (x >= x2) AND (y <= y2) THEN
                  GRAPHIC BOX (x2,y)-(x,y2), lCorner, g_Color, -2, 0
              ELSE
                  GRAPHIC BOX (x,y)-(x2,y2), lCorner, g_Color, -2, 0
              END IF
              OldX  = x
              OldY  = y
              OldX2 = x2
              OldY2 = y2
    
          CASE %IDC_OPTCIRC, %IDC_OPTOVAL  ' Draw Circle or Oval
              IF OldX > -1 THEN
                  GRAPHIC ELLIPSE (OldX, OldY)-(OldX2,OldY2), g_Color, -2, 0
              END IF
              IF g_DrawOp = %IDC_OPTCIRC THEN
                  IF x2 - x > y2 - y THEN
                      y2 = y + x2 - x
                  ELSE
                      x2 = x + y2 - y
                  END IF
              END IF
              GRAPHIC ELLIPSE (x,y)-(x2,y2), g_Color, -2, 0
              OldX  = x
              OldY  = y
              OldX2 = x2
              OldY2 = y2
    
          CASE %IDC_OPTFILL     ' Fill area - is done on LButtonDown
              EXIT SUB
    
          END SELECT
    
          GRAPHIC REDRAW
          '--------------------------------------------------------------
          sText = "Pos:" + STR$(x) + "," + STR$(y) + _
                  "  - " + STR$(x2) + "," + STR$(y2)
    
          SELECT CASE g_DrawOp
          CASE %IDC_OPTFREE
              sText = "Pos:" + STR$(x) + "," + STR$(y)
          CASE %IDC_OPTRBOX, %IDC_OPTRECT, %IDC_OPTCIRC, %IDC_OPTOVAL
              sText = sText + $CRLF + "Size:" + STR$(ABS(x2 - x)) + " x" + STR$(ABS(y2 - y))
          END SELECT
    
          CONTROL SET TEXT GetParent(hWnd), %IDC_LABELPOS, sText
          '--------------------------------------------------------------
    
      ELSE
          CONTROL SET TEXT GetParent(hWnd), %IDC_LABELPOS, _
                           "Pos:" + STR$(x2) + "," + STR$(y2)
      END IF
    
    END SUB
    
    
    '====================================================================
    SUB OnGraphic_LeftButtonup (BYVAL hWnd AS DWORD, _
                                BYVAL wParam AS DWORD, BYVAL lParam AS LONG)
    '--------------------------------------------------------------------
      ' %WM_LBUTTONUP handler for subclass procedure
      '------------------------------------------------------------------
      LOCAL lCorner, lFillColor AS LONG
    
      IF g_CanDraw THEN
          g_CanDraw = 0
          SELECT CASE g_DrawOp
          CASE %IDC_OPTLINE     ' Draw straight line
              GRAPHIC SET MIX %R2_COPYPEN
              GRAPHIC LINE (OldX,OldY)-(OldX2,OldY2), g_Color
              GRAPHIC REDRAW
    
          CASE %IDC_OPTRBOX, %IDC_OPTRECT  ' Draw Box
              lCorner    = IIF&(g_DrawOp = %IDC_OPTRBOX, 20, 0)
              lFillColor = IIF&(g_FillStyle < 0, -2, g_FillColor)
              GRAPHIC SET MIX %R2_COPYPEN
              IF (OldX <= OldX2) AND (OldY >= OldY2) THEN
                  GRAPHIC BOX (OldX,OldY2)-(OldX2,OldY), lCorner, g_Color, lFillColor, MAX&(0, g_FillStyle)
              ELSEIF (OldX > OldX2) AND (OldY > OldY2) THEN
                  GRAPHIC BOX (OldX2,OldY2)-(OldX,OldY), lCorner, g_Color, lFillColor, MAX&(0, g_FillStyle)
              ELSEIF (OldX >= OldX2) AND (OldY <= OldY2) THEN
                  GRAPHIC BOX (OldX2,OldY)-(OldX,OldY2), lCorner, g_Color, lFillColor, MAX&(0, g_FillStyle)
              ELSE
                  GRAPHIC BOX (OldX,OldY)-(OldX2,OldY2), lCorner, g_Color, lFillColor, MAX&(0, g_FillStyle)
              END IF
              GRAPHIC REDRAW
    
          CASE %IDC_OPTCIRC, %IDC_OPTOVAL  ' Draw Circle or Oval
              lFillColor = IIF&(g_FillStyle < 0, -2, g_FillColor)
              GRAPHIC SET MIX %R2_COPYPEN
              GRAPHIC ELLIPSE (OldX,OldY)-(OldX2,OldY2), g_Color, lFillColor, MAX&(0, g_FillStyle)
              GRAPHIC REDRAW
    
          END SELECT
    
          OldX   = -1
          OldY   = 0
          OldX2  = 0
          OldY2  = 0
          g_Radius = 0
    
          ReleaseCapture
      END IF
    
    END SUB
    FUNCTION AppPath(BYVAL hDlg AS LONG) AS STRING
        DIM tbuf AS ASCIIZ * 255
    
        ' Get the module filename
        CALL GetModuleFileName(GetWindowLong(hDlg, %GWL_HINSTANCE), tbuf, 255)
    
        AppPath = ExtractPath(BYCOPY tbuf)
    
    END FUNCTION
    FUNCTION ExtractPath(PathName AS STRING) AS STRING
        DIM f$, n%
        ' Return the directory path portion of a full pathname
    
        f$ = PathName
    
        DO
            n% = INSTR(f$, "\")
            IF n% > 0 THEN f$ = RIGHT$(f$, LEN(f$) - n%)
        LOOP WHILE n% > 0
    
        ExtractPath = LEFT$(PathName, LEN(PathName) - LEN(f$))
    
    END FUNCTION
    'end of 'pbIconMaker.bas

    '-------------------------------------------------------------------------

    'bmp2icon.bas
    Code:
    '-------------------------------------------------------------------------
    ' Author: Peter Redei, November, 2008
    ' Public Domain
    '
    ' Converts BMP files to ICO files
    '-------------------------------------------------------------------------
    TYPE tIconInfo
        iWidth      AS LONG
        iHeight     AS LONG
        iBitCnt     AS LONG
        iFileName   AS ASCIIZ * %MAX_PATH
        iDC         AS LONG
        iBitmap     AS LONG
    END TYPE
    
    TYPE ICONDIRENTRY
       bWidth AS BYTE               ' Width of the image
       bHeight AS BYTE              ' Height of the image (times 2)
       bColorCount AS BYTE          ' Number of colors in image (0 if >=8bpp)
       bReserved AS BYTE            ' Reserved
       wPlanes AS INTEGER           ' Color Planes
       wBitCount AS INTEGER         ' Bits per pixel
       dwBytesInRes AS LONG         ' how many bytes in this resource?
       dwImageOffset AS LONG        ' where in the file is this image
    END TYPE
    TYPE ICONDIR
       idReserved AS INTEGER        ' Reserved
       idType AS INTEGER            ' resource type (1 for icons)
       idCount AS INTEGER           ' how many images?
       idEntries AS ICONDIRENTRY    'array follows.
    END TYPE
    
    TYPE BITMAPINFO1Bit
        bmiHeader AS BITMAPINFOHEADER
        bmiColors(0 TO 1) AS RGBQUAD
    END TYPE
    
    TYPE BITMAPINFO4Bit
        bmiHeader AS BITMAPINFOHEADER
        bmiColors(0 TO 15) AS RGBQUAD
    END TYPE
    
    TYPE BITMAPINFO8Bit
        bmiHeader AS BITMAPINFOHEADER
        bmiColors(0 TO 255) AS RGBQUAD
    END TYPE
    
    GLOBAL BitCnt AS LONG
    GLOBAL TransCol AS LONG
    
    DECLARE FUNCTION GetDIBits LIB "GDI32.DLL" ALIAS "GetDIBits" (BYVAL hdc AS DWORD, BYVAL hBitmap AS DWORD, BYVAL nStartScan AS DWORD, BYVAL nNumScans AS DWORD, lpBits AS ANY, lpBI AS ANY, BYVAL wUsage AS DWORD) AS LONG
    
    SUB ConvertToIcon(BYVAL hDlg AS DWORD, BYVAL BmpName AS STRING)
        LOCAL ret, nFile, nWidth, nHeight, hBmp AS LONG
        LOCAL bmpPicInfo AS BITMAPINFO
        LOCAL ico AS tIconInfo
        LOCAL bi24BitInfo AS BITMAPINFO
       
        
        LOCAL hndl, hDC AS LONG
    
        TransCol = RGB(197, 197, 197)   'Color to be Transparent
        BitCnt = 24                     'this gives the best result. Change to 1 or 4 or 8 if you wish
        
        nFile = FREEFILE
        OPEN BmpName FOR BINARY AS nFile
        GET #nFile, 19, nWidth
        GET #nFile, 23, nHeight
        CLOSE nFile
    
        IF nWidth = nHeight THEN    'size to 32 x 32 pixels
            GRAPHIC BITMAP LOAD BmpName, 32, 32 ,%HALFTONE TO hBmp
            LOCAL x, y AS LONG
            DIALOG PIXELS hDlg, 32, 32 TO UNITS x, y
            CONTROL ADD GRAPHIC, hDlg, 1234, "", 0, 0, x, y
            GRAPHIC ATTACH hBmp, 1234
            GRAPHIC GET DC TO hDC
    
            bmpPicInfo.bmiHeader.biBitCount = 24
            bmpPicInfo.bmiHeader.biCompression = %BI_RGB
            bmpPicInfo.bmiHeader.biPlanes = 1
            bmpPicInfo.bmiHeader.biSize = SIZEOF(bmpPicInfo.bmiHeader)
            bmpPicInfo.bmiHeader.biWidth = 32
            bmpPicInfo.bmiHeader.biHeight = 32
    
            ico.iDC = CreateCompatibleDC(0)
            ico.iWidth = 32
            ico.iHeight = 32
    
            bi24BitInfo.bmiHeader.biWidth = 32
            bi24BitInfo.bmiHeader.biHeight = 32
         
            ico.iBitmap = CreateDIBSection(ico.iDC, bmpPicInfo, %DIB_RGB_COLORS, BYVAL 0&, BYVAL 0&, BYVAL 0&)
            SelectObject ico.iDC, ico.iBitmap
            ret = BitBlt(ico.iDC, 0, 0, 32, 32, hDC, 0, 0, %SrcCopy)
            IF Ret = 0 THEN
                MSGBOX "Unable to BitBlt Picture."
                EXIT SUB
            END IF
           
            SaveIcon hDlg, LEFT$(BmpName, LEN(BmpName) - 3) + "ico", ico.iDC, ico.iBitmap, bi24BitInfo, ico
            
        ELSE
            MSGBOX "The image (" & FORMAT$(nWidth) & " x " & FORMAT$(nHeight) & ") is not a square and cannot be sized to 32 x 32", %MB_OK, "PBIconMaker"
        END IF
        CONTROL KILL hDlg, 1234
    END SUB
    SUB SaveIcon(BYVAL hDlg AS LONG, sFileName AS STRING, nDC AS LONG, nBitmap AS LONG, bi24BitInfo AS BITMAPINFO, ico AS tIconInfo)
        LOCAL CopyDC, CopyBitmap AS LONG
        
        CopyDC = CreateCompatibleDC(nDC)
        bi24BitInfo.bmiHeader.biWidth = 32
        bi24BitInfo.bmiHeader.biHeight = 32
    
        bi24BitInfo.bmiHeader.biBitCount = 24
        bi24BitInfo.bmiHeader.biCompression = %BI_RGB
        bi24BitInfo.bmiHeader.biPlanes = 1
        bi24BitInfo.bmiHeader.biSize = SIZEOF(bi24BitInfo.bmiHeader)
        bi24BitInfo.bmiHeader.biWidth = 32
        bi24BitInfo.bmiHeader.biHeight = 32
    
        CopyBitmap = CreateDIBSection(nDC, bi24BitInfo, %DIB_RGB_COLORS, BYVAL 0&, BYVAL 0&, BYVAL 0&)
        SelectObject CopyDC, CopyBitmap
        ChangePixels ico.iDC, 0, 0, 32, 32, TransCol, %BLACK, CopyDC, bi24BitInfo
    
        SaveIconForBit hDlg, sFileName, nDC, nBitmap, CopyDC, CopyBitmap
        DeleteDC CopyDC
        DeleteObject CopyBitmap
    END SUB
    FUNCTION ChangePixels(hSrcDC AS LONG, x AS LONG, y AS LONG, lWidth AS LONG, lHeight AS LONG, OldColor AS LONG, NewColor AS LONG, hDestDC AS LONG, bi24BitInfo AS BITMAPINFO) AS LONG
        DIM r AS RECT, mBrush AS LONG, CopyDC AS LONG, CopyBitmap AS LONG
        SetRect r, 0, 0, lWidth, lHeight
        mBrush = CreateSolidBrush(NewColor)
        CopyDC = CreateCompatibleDC(hSrcDC)
        bi24BitInfo.bmiHeader.biWidth = lWidth
        bi24BitInfo.bmiHeader.biHeight = lHeight
    
        bi24BitInfo.bmiHeader.biBitCount = 24
        bi24BitInfo.bmiHeader.biCompression = %BI_RGB
        bi24BitInfo.bmiHeader.biPlanes = 1
        bi24BitInfo.bmiHeader.biSize = SIZEOF(bi24BitInfo.bmiHeader)
    
        CopyBitmap = CreateDIBSection(hSrcDC, bi24BitInfo, %DIB_RGB_COLORS, BYVAL 0&, BYVAL 0&, BYVAL 0&)
        IF SelectObject(CopyDC, CopyBitmap) = 0 THEN
            MSGBOX "In ChangePixels - SelectObject(CopyDC, CopyBitmap) = 0"
            EXIT FUNCTION
        END IF
        IF FillRect(CopyDC, r, mBrush) = 0 THEN EXIT FUNCTION
        IF TransBlt(hSrcDC, x, y, lWidth, lHeight, OldColor, CopyDC, hDestDC, bi24BitInfo) = %False THEN EXIT FUNCTION
        DeleteDC CopyDC
        DeleteObject CopyBitmap
        DeleteObject mBrush
        ChangePixels = %True
    END FUNCTION
    
    FUNCTION TransBlt(hSrcDC AS LONG, x AS LONG, y AS LONG, lWidth AS LONG, lHeight AS LONG, MaskColor AS LONG, hBackDC AS LONG, hDestDC AS LONG, bi24BitInfo AS BITMAPINFO) AS LONG
        LOCAL MonoDC, MonoBitmap, CopyDC, CopyBitmap AS LONG
        LOCAL AndDC, AndBitmap AS LONG
        LOCAL rct AS RECT
    
        MonoDC = CreateCompatibleDC(hSrcDC)
        MonoBitmap = CreateBitmap(lWidth, lHeight, 1, 1, BYVAL 0&)
        IF SelectObject(MonoDC, MonoBitmap) = 0 THEN EXIT FUNCTION
        IF CreateMask(hSrcDC, x, y, lWidth, lHeight, MonoDC, MaskColor) = 0 THEN EXIT FUNCTION
        CopyDC = CreateCompatibleDC(hSrcDC)
        bi24BitInfo.bmiHeader.biWidth = lWidth
        bi24BitInfo.bmiHeader.biHeight = lHeight
        CopyBitmap = CreateDIBSection(hSrcDC, bi24BitInfo, %DIB_RGB_COLORS, BYVAL 0&, BYVAL 0&, BYVAL 0&)
        IF SelectObject(CopyDC, CopyBitmap) = 0 THEN EXIT FUNCTION
        AndDC = CreateCompatibleDC(hSrcDC)
        bi24BitInfo.bmiHeader.biWidth = lWidth
        bi24BitInfo.bmiHeader.biHeight = lHeight
        AndBitmap = CreateDIBSection(hSrcDC, bi24BitInfo, %DIB_RGB_COLORS, BYVAL 0&, BYVAL 0&, BYVAL 0&)
        IF SelectObject(AndDC, AndBitmap) = 0 THEN EXIT FUNCTION
        BitBlt AndDC, 0, 0, lWidth, lHeight, hSrcDC, x, y, %SrcCopy
        BitBlt CopyDC, 0, 0, lWidth, lHeight, hBackDC, 0, 0, %SrcCopy
        BitBlt CopyDC, 0, 0, lWidth, lHeight, MonoDC, 0, 0, %SrcAnd
        SetRect rct, 0, 0, lWidth, lHeight
        InvertRect MonoDC, rct
        BitBlt AndDC, 0, 0, lWidth, lHeight, MonoDC, 0, 0, %SrcAnd
        BitBlt CopyDC, 0, 0, lWidth, lHeight, AndDC, 0, 0, %SrcPaint
        IF BitBlt(hDestDC, x, y, lWidth, lHeight, CopyDC, 0, 0, %SrcCopy) = 0 THEN EXIT FUNCTION
        DeleteDC MonoDC
        DeleteDC CopyDC
        DeleteDC AndDC
        DeleteObject MonoBitmap
        DeleteObject CopyBitmap
        DeleteObject AndBitmap
        TransBlt = %True
    END FUNCTION
    
    SUB SaveIconForBit(BYVAL hDlg AS LONG, sFileName AS STRING, hDC AS LONG, nBitmap AS LONG, CopyDC AS LONG, CopyBitmap AS LONG)
        LOCAL fID AS ICONDIR, MaskInfo AS BITMAPINFO1Bit
        LOCAL bt1 AS BITMAPINFO1Bit, bt4 AS BITMAPINFO4Bit, bt8 AS BITMAPINFO8Bit
        LOCAL nMaskDC, nMaskBitmap AS LONG
        LOCAL ClrUsed AS LONG
        LOCAL SizeImage AS LONG
    
        REDIM IconPal(0 TO 255) AS RGBQUAD
        REDIM MaskBits(0 TO 127) AS BYTE
    
        SetSaveData hDC, MaskInfo, fID, nMaskDC, nMaskBitmap
        SELECT CASE BitCnt
            CASE 1
                ClrUsed = 0
                SizeImage = 128
                fID.idEntries.wPlanes = 5
                fID.idEntries.wBitCount = 7
                fID.idEntries.dwBytesInRes = 304
                fID.idEntries.dwImageOffset = 22
                bt1.bmiHeader.biSize = SIZEOF(bt1.bmiHeader)
                bt1.bmiHeader.biBitCount = BitCnt
                bt1.bmiHeader.biSizeImage = SizeImage
                bt1.bmiHeader.biClrUsed = ClrUsed
                bt1.bmiHeader.biCompression = %BI_RGB
                bt1.bmiHeader.biHeight = 64
                bt1.bmiHeader.biPlanes = 1
                bt1.bmiHeader.biWidth = 32
            CASE 4
                ClrUsed = 0
                SizeImage = 2
                bt4.bmiHeader.biSize = SIZEOF(bt4.bmiHeader)
                bt4.bmiHeader.biBitCount = BitCnt
                bt4.bmiHeader.biSizeImage = SizeImage
                bt4.bmiHeader.biClrUsed = ClrUsed
                bt4.bmiHeader.biCompression = %BI_RGB
                bt4.bmiHeader.biHeight = 64
                bt4.bmiHeader.biPlanes = 1
                bt4.bmiHeader.biWidth = 32
            CASE 8
                ClrUsed = 256
                SizeImage = 1152
                fID.idEntries.dwBytesInRes = 2216
                bt8.bmiHeader.biSize = SIZEOF(bt8.bmiHeader)
                bt8.bmiHeader.biBitCount = BitCnt
                bt8.bmiHeader.biSizeImage = SizeImage
                bt8.bmiHeader.biClrUsed = ClrUsed
                bt8.bmiHeader.biCompression = %BI_RGB
                bt8.bmiHeader.biHeight = 64
                bt8.bmiHeader.biPlanes = 1
                bt8.bmiHeader.biWidth = 32
            CASE 24
                ClrUsed = 1
                SizeImage = 1153
                fID.idEntries.dwBytesInRes = 3244
                bt4.bmiHeader.biSize = SIZEOF(bt4.bmiHeader)
                bt4.bmiHeader.biBitCount = BitCnt
                bt4.bmiHeader.biSizeImage = SizeImage
                bt4.bmiHeader.biClrUsed = ClrUsed
                bt4.bmiHeader.biCompression = %BI_RGB
                bt4.bmiHeader.biHeight = 64
                bt4.bmiHeader.biPlanes = 1
                bt4.bmiHeader.biWidth = 32
        END SELECT
        REDIM bBits(0 TO (BitCnt * 128) - 1) AS BYTE
        OPEN sFileName FOR BINARY AS #1
        PUT #1, , fID
        SELECT CASE BitCnt
            CASE 1
                PUT #1, , bt1.bmiHeader
                DoIconBits bBits(), CopyDC, CopyBitmap, VARPTR(bt1.bmiColors(0))
            CASE 4
                PUT #1, , bt4.bmiHeader
                DoIconBits bBits(), CopyDC, CopyBitmap, VARPTR(bt4.bmiColors(0))
            CASE 8
                PUT #1, , bt8.bmiHeader
                DoIconBits bBits(), CopyDC, CopyBitmap, VARPTR(bt8.bmiColors(0))
            CASE 24
                PUT #1, , bt4.bmiHeader
                DoIconBits bBits(), CopyDC, CopyBitmap, VARPTR(bt4.bmiColors(0))
        END SELECT
            
        LOCAL tmp AS STRING
        tmp = "    "
        PUT #1, , tmp
        PUT #1, , bBits()
        GetDIBits nMaskDC, nMaskBitmap, 0, 32, MaskBits(0), MaskInfo, %DIB_RGB_COLORS
        PUT #1, , MaskBits()
        CLOSE #1
        DeleteDC nMaskDC
        DeleteObject nMaskBitmap
    END SUB
    
    SUB DoIconBits(bBits() AS BYTE, nDC AS LONG, nBitmap AS LONG, captr AS DWORD)
        LOCAL CopyArr() AS RGBQUAD
    
        SELECT CASE BitCnt
            CASE 1
                REDIM CopyArr(0 TO 1) AT captr
                LOCAL BI1 AS BITMAPINFO8Bit
                BI1.bmiHeader.biBitCount = BitCnt
                BI1.bmiHeader.biCompression = %BI_RGB
                BI1.bmiHeader.biPlanes = 1
                BI1.bmiHeader.biHeight = 32
                BI1.bmiHeader.biWidth = 32
                BI1.bmiHeader.biSize = SIZEOF(BI1.bmiHeader)
                GetDIBits nDC, nBitmap, 0, 32, bBits(0), BI1, %DIB_RGB_COLORS
                CopyMemory VARPTR(CopyArr(0)), VARPTR(BI1.bmiColors(0)), LEN(CopyArr(0)) * 2
            CASE 4
                REDIM CopyArr(0 TO 15) AT captr
                LOCAL BI2 AS  BITMAPINFO8Bit
                BI2.bmiHeader.biBitCount = BitCnt
                BI2.bmiHeader.biCompression = %BI_RGB
                BI2.bmiHeader.biPlanes = 1
                BI2.bmiHeader.biHeight = 32
                BI2.bmiHeader.biWidth = 32
                BI2.bmiHeader.biSize = SIZEOF(BI2.bmiHeader)
                GetDIBits nDC, nBitmap, 0, 32, bBits(0), BI2, %DIB_RGB_COLORS
                CopyMemory VARPTR(CopyArr(0)), VARPTR(BI2.bmiColors(0)), LEN(CopyArr(0)) * 16
            CASE 8
                LOCAL BI3 AS BITMAPINFO8Bit
                BI3.bmiHeader.biBitCount = BitCnt
                BI3.bmiHeader.biCompression = %BI_RGB
                BI3.bmiHeader.biPlanes = 1
                BI3.bmiHeader.biHeight = 32
                BI3.bmiHeader.biWidth = 32
                BI3.bmiHeader.biSize = SIZEOF(BI3.bmiHeader)
                GetDIBits nDC, nBitmap, 0, 32, bBits(0), BI3, %DIB_RGB_COLORS
                REDIM CopyArr(0 TO 255) AT captr
                CopyMemory VARPTR(CopyArr(0)), VARPTR(BI3.bmiColors(0)), SIZEOF(RGBQUAD) * 256
            CASE 24
                LOCAL BI4 AS BITMAPINFO8Bit
                BI4.bmiHeader.biBitCount = BitCnt
                BI4.bmiHeader.biCompression = %BI_RGB
                BI4.bmiHeader.biPlanes = 1
                BI4.bmiHeader.biHeight = 32
                BI4.bmiHeader.biWidth = 32
                BI4.bmiHeader.biSize = SIZEOF(BI4.bmiHeader)
                GetDIBits nDC, nBitmap, 0, 32, bBits(0), BI4, %DIB_RGB_COLORS
                REDIM CopyArr(0 TO 15) AT captr
        END SELECT
    END SUB
    
    FUNCTION CreateMask(hSrcDC AS LONG, x AS LONG, y AS LONG, nWidth AS LONG, nHeight AS LONG, hDestDC AS LONG, MaskColor AS LONG) AS LONG
        LOCAL MonoDC, MonoBitmap, OldBkColor AS LONG
        MonoDC = CreateCompatibleDC(hSrcDC)
        MonoBitmap = CreateBitmap(nWidth, nHeight, 1, 1, BYVAL 0&)
        IF SelectObject(MonoDC, MonoBitmap) = 0 THEN EXIT FUNCTION
        OldBkColor = SetBkColor(hSrcDC, MaskColor)
        BitBlt MonoDC, 0, 0, nWidth, nHeight, hSrcDC, x, y, %SrcCopy
        IF BitBlt(hDestDC, 0, 0, nWidth, nHeight, MonoDC, 0, 0, %SrcCopy) = 0 THEN EXIT FUNCTION
        SetBkColor hSrcDC, OldBkColor
        DeleteObject MonoBitmap
        DeleteDC MonoDC
        CreateMask = %True
    END FUNCTION
    SUB SetSaveData(nDC AS LONG, MaskInfo AS BITMAPINFO1Bit, fID AS ICONDIR, nMaskDC AS LONG, nMaskBitmap AS LONG)
        SELECT CASE BitCnt
            CASE 1
                fID.idEntries.bColorCount = 0
            CASE 4
                fID.idEntries.bColorCount = 16
            CASE 8
                fID.idEntries.bColorCount = 0
           CASE 24
                fID.idEntries.bColorCount = 0
        END SELECT
        fID.idCount = 1
        fID.idType = 1
        fID.idEntries.bHeight = 32
        fID.idEntries.bWidth = 32
        fID.idEntries.dwImageOffset = LEN(fID)
        fID.idEntries.wBitCount = 0
        fID.idEntries.wPlanes = 0
        fID.idEntries.dwBytesInRes = 744
        MaskInfo.bmiHeader.biSize = SIZEOF(MaskInfo.bmiHeader)
        MaskInfo.bmiHeader.biBitCount = 1
        MaskInfo.bmiHeader.biClrUsed = 2
        MaskInfo.bmiHeader.biHeight = 32
        MaskInfo.bmiHeader.biPlanes = 1
        MaskInfo.bmiHeader.biWidth = 32
        nMaskDC = CreateCompatibleDC(GetDC(0))
        nMaskBitmap = CreateBitmap(32, 32, 1, 1, BYVAL 0&)
        SelectObject nMaskDC, nMaskBitmap
        SetBkColor nDC, TransCol
        SetBkColor nMaskDC, %BLACK
        BitBlt nMaskDC, 0, 0, 32, 32, nDC, 0, 0, %SrcCopy
    END SUB
    'end of bmp2icon.bas

    '--------------------------------------------------------------------------------
    ' textentry.bas
    Code:
    '--------------------------------------------------------------------------------
    '   ** Constants **
    '--------------------------------------------------------------------------------
    %IDCF_TEXTENTRYDLG      = 201
    %IDCF_TEXTBOX1           = 2001
    %IDCF_ABORT             = 2003
    %IDCF_CHANGEFONTBUTTON  = 2002
    %IDCF_EXIT              = 2004
    '--------------------------------------------------------------------------------
    GLOBAL sEntryText AS STRING
    GLOBAL txt_fontname$, txt_points&, txt_style&, txt_color&, txt_charset&
    '--------------------------------------------------------------------------------
    '   ** Declarations **
    '--------------------------------------------------------------------------------
    DECLARE CALLBACK FUNCTION DisplayTextEntryProc()
    DECLARE FUNCTION DisplayTextEntry(BYVAL hParent AS DWORD) AS LONG
    '--------------------------------------------------------------------------------
    '   ** CallBacks **
    '--------------------------------------------------------------------------------
    CALLBACK FUNCTION DisplayTextEntryProc()
        LOCAL hFont1 AS LONG
        SELECT CASE CB.MSG
            CASE %WM_COMMAND
                SELECT CASE CB.CTL
                    CASE %IDCF_TEXTBOX1
                    CASE %IDCF_CHANGEFONTBUTTON
                        IF CBCTLMSG = %BN_CLICKED OR CBCTLMSG = 1 THEN
                            IF txt_fontname$ = "" THEN
                                txt_fontname$ = "MS Sans Serif"
                                txt_points& = 8
                                txt_style& = 0
                            END IF
                            DISPLAY FONT CB.HNDL, , , txt_fontname$, txt_points&, txt_style&, %CF_SCREENFONTS TO txt_fontname$, txt_points&, txt_style&, txt_color&, txt_charset&
                            FONT NEW txt_fontname$,txt_points&, txt_style&, txt_charset& TO hFont1
                            CONTROL SEND CB.HNDL, %IDCF_TEXTBOX1, %WM_SETFONT, hFont1, 0
                            FONT END hFont1
                            CONTROL REDRAW CB.HNDL, %IDCF_TEXTBOX1
                        END IF
                    CASE %IDCF_ABORT
                        IF CB.CTLMSG = %BN_CLICKED OR CB.CTLMSG = 1 THEN
                            DIALOG END CB.HNDL
                        END IF
                    CASE %IDCF_EXIT
                        IF CB.CTLMSG = %BN_CLICKED OR CB.CTLMSG = 1 THEN
                            CONTROL GET TEXT CB.HNDL, %IDCF_TEXTBOX1 TO sEntryText
                            DIALOG END CB.HNDL
                        END IF
    
                END SELECT
        END SELECT
    
    END FUNCTION
    '--------------------------------------------------------------------------------
    
    '--------------------------------------------------------------------------------
    '   ** Dialogs **
    '--------------------------------------------------------------------------------
    FUNCTION DisplayTextEntry(BYVAL hParent AS DWORD) AS LONG
        LOCAL lRslt AS LONG
    #PBFORMS Begin Dialog %IDCF_TEXTENTRYDLG->->
        LOCAL hDlg AS DWORD
    
        DIALOG NEW hParent, "Enter Text", 315, 263, 244, 102, %WS_POPUP OR _
            %WS_BORDER OR %WS_DLGFRAME OR %WS_CLIPSIBLINGS OR %WS_VISIBLE OR _
            %DS_MODALFRAME OR %DS_CENTER OR %DS_3DLOOK OR %DS_NOFAILCREATE OR _
            %DS_SETFONT, %WS_EX_WINDOWEDGE OR %WS_EX_CONTROLPARENT OR %WS_EX_LEFT _
            OR %WS_EX_LTRREADING OR %WS_EX_RIGHTSCROLLBAR, TO hDlg
        CONTROL ADD TEXTBOX, hDlg, %IDCF_TEXTBOX1, "Enter text", 5, 5, 150, 90, _
            %WS_CHILD OR %WS_VISIBLE OR %WS_TABSTOP OR %ES_LEFT OR %ES_MULTILINE OR _
            %ES_AUTOHSCROLL OR %ES_WANTRETURN, %WS_EX_CLIENTEDGE OR %WS_EX_LEFT OR _
            %WS_EX_LTRREADING OR %WS_EX_RIGHTSCROLLBAR
        CONTROL ADD BUTTON, hDlg, %IDCF_CHANGEFONTBUTTON, "Change Font", 165, 5, 70, _
            15
        CONTROL ADD BUTTON, hDlg, %IDCF_ABORT, "Abort", 165, 35, 70, 15
        CONTROL ADD BUTTON, hDlg, %IDCF_EXIT, "Exit", 165, 80, 70, 15
    
        DIALOG SHOW MODAL hDlg, CALL DisplayTextEntryProc TO lRslt
    
        FUNCTION = lRslt
    END FUNCTION
    '--------------------------------------------------------------------------------
    ' end of textentry.bas
    Last edited by Peter Redei; 30 Nov 2008, 02:12 PM.
Working...
X