Tweet
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 ?)
'end of 'pbIconMaker.bas
'-------------------------------------------------------------------------
'bmp2icon.bas
'end of bmp2icon.bas
'--------------------------------------------------------------------------------
' textentry.bas
' end of textentry.bas
'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
'-------------------------------------------------------------------------
'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
'--------------------------------------------------------------------------------
' 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
'--------------------------------------------------------------------------------