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