Windows Button Image
Re: Windows Button Image
@UEZ
Your button draw code doesn't work... I just get a blank button , with no circle or X.
@Dodicat
How would you transfer an FB ImageCreate Image , to a Windows bitmap ? to stick on the Button?
Without saving and loading the image as a *.bmp . Is it possible?
Your button draw code doesn't work... I just get a blank button , with no circle or X.
@Dodicat
How would you transfer an FB ImageCreate Image , to a Windows bitmap ? to stick on the Button?
Without saving and loading the image as a *.bmp . Is it possible?
Re: Windows Button Image
Hmm, that's odd. It works here on Win10albert wrote:@UEZ
Your button draw code doesn't work... I just get a blank button , with no circle or X.
@Dodicat
How would you transfer an FB ImageCreate Image , to a Windows bitmap ? to stick on the Button?
Without saving and loading the image as a *.bmp . Is it possible?
You can convert any FB image to GDI or GDIPlus.
For GDI you have to create:
Code: Select all
Dim as BITMAPINFO tBITMAP
With tBITMAP.bmiheader
.biSize = Sizeof(BITMAPINFOHEADER)
.biWidth = iW
.biHeight = -iH
.biPlanes = 1
.biBitCount = 32
.biCompression = BI_RGB
End With
Dim As ULong Ptr aBits
Dim As HBitmap hBitmapGDI
hBitmapGDI = CreateDIBSection(hDC, @tBITMAP, DIB_RGB_COLORS, @aBits, NULL, NULL)
For GDIPlus you have to create an empty bitmap, lock the bitmap using GdipBitmapLockBits and put the pixels to the bitmap. Alternatively, you can use also GdipBitmapSetPixel which is much slower than GdipBitmapLockBits method.
Re: Windows Button Image
@UEZ
I'm on a Linux box , running the program under wine? wine might not have the proper libs?
I'm on a Linux box , running the program under wine? wine might not have the proper libs?
Re: Windows Button Image
Sorry, but my Linux skills are very low to give you any hint. I even don't know how to install FB in my Linux VM. :-(albert wrote:@UEZ
I'm on a Linux box , running the program under wine? wine might not have the proper libs?
Re: Windows Button Image
Using bitmaps is very easy Albert, and you can make sure everything is cleaned up by a destructor sub.
But I shall investigate other ways (I am a bit rusty on win api)
run this in a temp folder.
But I shall investigate other ways (I am a bit rusty on win api)
run this in a temp folder.
Code: Select all
#include once "windows.bi"
dim shared as any ptr i(1 to 88 )
DIM szBitmap(lbound(i) to ubound(i)) AS STRING
dim as long w,h
w=100
h=50
'=======================================
screenres w,h,32,,-1 'create a temp [hidden] screen
for n as long=lbound(i) to ubound(i)
var clr=rnd*rgb(255,255,255)
i(n)=imagecreate(w,h,clr)
draw string i(n),(5,10),"Click "+str(n),0
bsave ("small"+str(n)+".bmp",i(n))
szbitmap(n)="small"+str(n)+".bmp"
next n
screen 0 'return to console
'=========================================
Dim As MSG msg
Dim Shared As HWND hWnd, edit(lbound(i) to ubound(i))
dim hbitmap as handle
hWnd = CreateWindowEx( 0, "#32770", "Bitmap Button Test",WS_OVERLAPPEDWINDOW Or WS_VISIBLE , 100, 0, 800, 600, 0, 0, 0, 0 )
dim as integer k,y=0,start
for n as long=lbound(i) to ubound(i)
if n=lbound(i) then start=9 else start=8
k+=1
if (k) mod 9=0 then y+=h+1:k=1
edit(n) = CreateWindowEx( 0, "BUTTON", "" , WS_BORDER Or WS_VISIBLE Or WS_CHILD or ANSI_CHARSET OR BS_PUSHBUTTON OR BS_BITMAP, (k-1)*100 , y , w , h , hWnd, 0, 0, 0 )
next n
for n as long=lbound(i) to ubound(i)
hBitmap = LoadImage(0, szBitmap(n), IMAGE_BITMAP, w, h, LR_LOADFROMFILE )
IF hbitmap THEN SendMessage(edit(n), BM_SETIMAGE, IMAGE_BITMAP, CAST(LPARAM, hbitmap))
next n
While GetMessage( @msg, 0, 0, 0 )
TranslateMessage( @msg )
DispatchMessage( @msg )
Select Case msg.hwnd
Case hWnd
Select Case msg.message
Case 273 : PostQuitMessage(0)
End Select
End Select
Wend
PostQuitMessage(0)
sub finish destructor
for n as long=lbound(i) to ubound(i)
imagedestroy(i(n)):i(n)=0
kill "small"+str(n)+".bmp"
print "destroying ";n
next
end sub
End
Re: Windows Button Image
@Dodicat
I'm gonna pull the subs out of Picto-Font to draw the *.pft files. and stick them on a button..
With FB Line( ? , ? ) - ( ? , ? ) , there's no way to specify a brush size , all lines are single pixel.
I'm gonna pull the subs out of Picto-Font to draw the *.pft files. and stick them on a button..
With FB Line( ? , ? ) - ( ? , ? ) , there's no way to specify a brush size , all lines are single pixel.
Re: Windows Button Image
@Dodicat
I got it loading a *.pft file...
But can't get it to put the image on a button. It shows the image in a FB window..
You have to download "Picto-Font" from the projects section of the forum , and draw a doodle and save it.. Just click "Save" to save as *.pft
Then run the below code and select *.pft file to load..
Can you help?
I got it loading a *.pft file...
But can't get it to put the image on a button. It shows the image in a FB window..
You have to download "Picto-Font" from the projects section of the forum , and draw a doodle and save it.. Just click "Save" to save as *.pft
Then run the below code and select *.pft file to load..
Can you help?
Code: Select all
#define WIN_INCLUDEALL
#include once "windows.bi"
#include once "win\commdlg.bi"
#include once "file.bi"
#include once "fbgfx.bi"
declare Sub Load_Font(byval hWnd as HWND , byval rct as RECT)
declare Sub Create_Output_Grid_And_Pen(byval hWnd as HWND , byref bc as ulongint , byref bs_10 as single , byref bs_01 as single)
declare sub Delete_OutPut_Grid_And_Pen(byval hWnd as HWND)
declare Sub Select_Pens(byval hWnd as HWND , byref bc as ulongint , byref bs_10 as single , byref bs_01 as single)
declare sub Resize_Grids(byval hWnd as HWND)
declare sub Bit_blt(byval hWnd as HWND)
declare sub Update(BYVAL hWnd as HWND , BYVal rct as RECT)
declare Sub ReDraw(byval hWnd as HWND , byval rct as RECT)
declare sub getfilename()
dim shared as integer glyph_x = 32
dim shared as integer glyph_y = 32
dim shared as ulongint b_color = &H000000
dim shared as single b_size_01 = 0
dim shared as single b_size_10 = 0
dim shared as integer ratio = 10
'drawing storage strings for saving and loading
dim shared as string glyph_size
dim shared as string xpos
dim shared as string ypos
dim shared as string brush_color
dim shared as string brush_size
dim shared as string connected
dim shared as string file , ext , filename , File_type
dim shared rct as RECT
dim shared pnt as PAINTSTRUCT
dim shared hDC as HDC
'setup output window objs
dim shared OutPut_Grid as HBITMAP
dim shared OutPut_Grid_Pen as HPEN
dim shared OutPutDC as hDC
dim shared OutPutobj as HGDIOBJ
dim shared OutPutpen_obj as HGDIOBJ
Dim As MSG msg
Dim Shared As HWND hWnd, edit
hWnd = CreateWindowEx( 0, "#32770", "Bitmap Button Test", WS_OVERLAPPEDWINDOW Or WS_VISIBLE , 100, 0, 800, 600, 0, 0, 0, 0 )
edit = CreateWindowEx( 0, "BUTTON", "Button" , WS_BORDER Or WS_VISIBLE Or WS_CHILD or BS_PUSHBUTTON OR BS_BITMAP, 10 , 10 , 50 , 25 , hWnd, 0, 0, 0 )
Load_Font(hWnd,rct)
Dim As Any Ptr MYIMG
Dim As hDC MYDC
Dim As HBitmap MYBMP
Dim As BITMAPINFOHEADER MYBMPINFO
Dim As Integer sx, sy
Screenres 128,128,32
'Screeninfo sx, sy
sx = glyph_x
sy = glyph_y
MYIMG = ImageCreate(sx, sy)
'TMPWND = GetDesktopWindow()
'GetClientRect(TMPWND, @WNDRECT)
'WNDDC = GetDC(TMPWND)
MYDC = CreateCompatibleDC(OutPutDC)
MYBMP = CreateCompatibleBitmap(OutputDC, sx, sy)
SelectObject(MYDC, MYBMP)
With MYBMPINFO
.biSize = Sizeof(MYBMPINFO)
.biWidth = sx
.biHeight = -sy
.biPlanes = 1
.biBitCount = 32
.biCompression = BI_RGB
.biSizeImage = 0
End With
BitBlt(MYDC, 0, 0, sx, sy, OutputDC, 0, 0, SRCCOPY)
GetDIBits(MYDC, MYBMP, 0, sy, MYIMG + Sizeof(FB.IMAGE), Cptr(BITMAPINFO Ptr, @MYBMPINFO), DIB_RGB_COLORS)
Put (0, 0), MYIMG, Pset
'BSave( file , MYIMG)
'screen 0
'ReleaseDC(TMPWND,WNDDC)
DeleteDC(MYDC)
DeleteObject(MYBMP)
imagedestroy(MYIMG)
SendMessage(edit , BM_SETIMAGE , IMAGE_BITMAP , CAST(LPARAM, OutPut_Grid))
'===============================================================================
'===============================================================================
'===============================================================================
'===============================================================================
While GetMessage( @msg, 0, 0, 0 )
TranslateMessage( @msg )
DispatchMessage( @msg )
Select Case msg.hwnd
Case hWnd
Select Case msg.message
Case 273 : PostQuitMessage(0)
End Select
End Select
Wend
PostQuitMessage(0)
End
'===============================================================================
'===============================================================================
'===============================================================================
'Sub and function below here.
'===============================================================================
'===============================================================================
'===============================================================================
Sub Load_Font(byval hWnd as HWND , byval rct as RECT)
file = ""
file_type="pft"
getfilename()
if file <> "" then
open file for input as #1
line input #1,glyph_size
line input #1,xpos
line input #1,ypos
line input #1,brush_color
line input #1,brush_size
line input #1,connected
close #1
if glyph_x and glyph_y = 0 then
glyph_x=val( left(glyph_size,2))
glyph_y=val(right(glyph_size,2))
end if
print "Glyph Size = " ; glyph_size
print "X Positions = " ; xpos
print "Y positions = " ; ypos
print "Brush Colors = " ; brush_color
print "Brush Sizes = " ; brush_size
print "Draw To = " ; connected
print "Bytes For CHR= " ; len(glyph_size)+len(xpos)+len(ypos)+len(brush_color)+len(brush_size)+len(connected)
print string(78,"=")
Resize_Grids(hWnd)
end if
end sub
'===============================================================================
'===============================================================================
Sub Create_Output_Grid_And_Pen(byval hWnd as HWND , byref bc as ulongint , byref bs_10 as single , byref bs_01 as single)
dim hDC as HDC
OutPut_Grid = CreateCompatibleBitmap(GetDC(hWnd), glyph_x , glyph_y )
OutPut_Grid_Pen = CreatePen(PS_SOLID,sqr(glyph_x*glyph_y)*(((bs_01*.01)+(bs_10*.1))*1 ),bc)
OutPutDC = CreateCompatibleDC(HDC)
Dim As RECT OutPut_Grid_Rect = ( 0 , 0 , glyph_x*ratio , glyph_y*ratio )
SelectObject OutPutDC , OutPut_Grid
FillRect .OutPutDC , @OutPut_Grid_Rect , null
outputobj = SelectObject(OutPutDC , OutPut_Grid )
outputpen_obj = SelectObject(OutPutDC , OutPut_Grid_Pen )
end sub
'===============================================================================
'===============================================================================
sub Delete_Output_Grid_And_Pen(byval hWnd as HWND)
dim hDC as HDC
SelectObject( OutPutDC, outputobj )
SelectObject( OutPutDC, outputpen_obj )
DeleteObject( OutPut_Grid )
DeleteObject( OutPut_Grid_Pen )
DeleteDC( OutPutDC )
end sub
'===============================================================================
'===============================================================================
Sub Select_Pens(byval hWnd as HWND , byref bc as ulongint , byref bs_10 as single , byref bs_01 as single)
OutPut_Grid_Pen = CreatePen( PS_SOLID , sqr(glyph_x*glyph_y)*(((bs_01*.01)+(bs_10*.1))*1 ) , bc )
outputpen_obj = SelectObject( OutputDC, OutPut_Grid_Pen )
end sub
'===============================================================================
'===============================================================================
sub Bit_blt(byval hWnd as HWND)
dim hDC as HDC
hDC = BeginPaint( hWnd, @pnt )
BitBlt(hDC ,(glyph_x*ratio)+60, 0 , glyph_x , glyph_y , OutputDC , 0, 0 , SRCCOPY)
EndPaint( hWnd, @pnt )
end sub
'===============================================================================
'===============================================================================
sub Update(BYVAL hWnd as HWND , BYVal rct as RECT)
InvalidateRect( hwnd, 0, TRUE )
UpdateWindow(hWnd)
end sub
'===============================================================================
'===============================================================================
sub Resize_Grids(byval hWnd as HWND)
Delete_OutPut_Grid_And_Pen( hWnd )
Create_OutPut_Grid_And_Pen( hWnd , b_color , b_size_10 , b_size_01)
ReDraw(hWnd,rct)
end sub
'===============================================================================
'===============================================================================
'ReDraw() goes through strorage strings and replots the character.
'===============================================================================
'===============================================================================
Sub ReDraw(byval hWnd as HWND , byval rct as RECT)
dim hDC as HDC
dim as ulongint count_xy
dim as ulongint count_color
dim as ulongint count_size
dim as ulongint count_connected
dim as ulongint connect
dim as ulongint lx , ly ,mx , my , bc
dim as single bs_10 , bs_01
count_xy =1
count_color =1
count_size =1
count_connected =2
do
lx = (val(mid( xpos ,count_xy +0,3))/100) * (glyph_x*ratio)
ly = (val(mid( ypos ,count_xy +0,3))/100) * (glyph_y*ratio)
mx = (val(mid( xpos ,count_xy +3,3))/100) * (glyph_x*ratio)
my = (val(mid( ypos ,count_xy +3,3))/100) * (glyph_y*ratio)
bc =valulng(mid( brush_color,count_color , 8))
bs_10 = val(mid( brush_size ,count_size +0,1))
bs_01 = val(mid( brush_size ,count_size +1,1))
connect=val(mid( connected ,count_connected,1))
Select_Pens(hWnd,bc,bs_10,bs_01)
hDC = BeginPaint( hWnd, @pnt )
if connect=1 then 'two points are connected
'MoveToEx(FontDC , (lx)-1 , (ly)-1 , 0)
' LineTo(FontDC , (mx)-1 , (my)-1)
MoveToEx(OutPutDC , (lx/ratio)-1 , (ly/ratio)-1 , 0)
LineTo(OutPutDC , (mx/ratio)-1 , (my/ratio)-1)
else ' two points are not connected
'MoveToEx(FontDC , (lx)-1 , (ly)-1 , 0)
' LineTo(FontDC , (lx)-1 , (ly)-1)
MoveToEx(OutPutDC , (lx/ratio)-1 , (ly/ratio)-1 , 0)
LineTo(OutPutDC , (lx/ratio)-1 , (ly/ratio)-1)
end if
EndPaint( hWnd, @pnt )
count_xy +=3
count_color +=8
count_size +=2
count_connected +=1
loop until count_size>=len(brush_size)
'last_x = lx
'last_y = ly
'mouse_x = mx
'mouse_y = my
Update(hWnd,rct)
end sub
'===============================================================================
'===============================================================================
sub getfilename()
dim ofn as OPENFILENAME
dim filename as zstring * MAX_PATH+1
with ofn
.lStructSize = sizeof( OPENFILENAME )
.hwndOwner = hWnd
.hInstance = GetModuleHandle( NULL )
if file_type="pft" then .lpstrFilter = strptr( !"Picto-Font Files , (*.pft)\0*.pft\0\0")
if file_type="bmp" then .lpstrFilter = strptr( !"BitMap Files , (*.bmp)\0*.bmp\0\0")
.lpstrCustomFilter = NULL
.nMaxCustFilter = 0
.nFilterIndex = 1
.lpstrFile = @filename
.nMaxFile = sizeof( filename )
.lpstrFileTitle = NULL
.nMaxFileTitle = 0
.lpstrInitialDir = NULL
.lpstrTitle = @"Save File"
.Flags = OFN_EXPLORER 'or OFN_FILEMUSTEXIST or OFN_PATHMUSTEXIST
.nFileOffset = 0
.nFileExtension = 0
.lpstrDefExt = NULL
.lCustData = 0
.lpfnHook = NULL
.lpTemplateName = NULL
end with
if( GetOpenFileName( @ofn ) = FALSE ) then
file = ""
return
else
dim ext as string
ext = right$(filename,4)
if file_type="pft" then
if ext <> ".pft" then
filename = filename + ".pft"
end if
end if
if file_type="bmp" then
if ext <> ".bmp" then
filename = filename + ".bmp"
end if
end if
file = filename
endif
end sub
Re: Windows Button Image
@Dodicat
I got it working!!
I can now load images to the button...Now just to clean up the code.
You have to download "Picto-Font" from the projects section of the forum, create a doodle and then "Save" it as a *.pft file.
Then you can run the below code and see the doodle on the button.
I got it working!!
I can now load images to the button...Now just to clean up the code.
You have to download "Picto-Font" from the projects section of the forum, create a doodle and then "Save" it as a *.pft file.
Then you can run the below code and see the doodle on the button.
Code: Select all
#define WIN_INCLUDEALL
#include once "windows.bi"
#include once "win\commdlg.bi"
#include once "file.bi"
#include once "fbgfx.bi"
declare Sub Load_Font(byval hWnd as HWND , byval rct as RECT)
declare Sub Create_Output_Grid_And_Pen(byval hWnd as HWND , byref bc as ulongint , byref bs_10 as single , byref bs_01 as single)
declare sub Delete_OutPut_Grid_And_Pen(byval hWnd as HWND)
declare Sub Select_Pens(byval hWnd as HWND , byref bc as ulongint , byref bs_10 as single , byref bs_01 as single)
declare sub Resize_Grids(byval hWnd as HWND)
declare sub Bit_blt(byval hWnd as HWND)
declare sub Update(BYVAL hWnd as HWND , BYVal rct as RECT)
declare Sub ReDraw(byval hWnd as HWND , byval rct as RECT)
declare sub getfilename()
dim shared as integer glyph_x = 16
dim shared as integer glyph_y = 16
dim shared as ulongint b_color = &H000000
dim shared as single b_size_01 = 0
dim shared as single b_size_10 = 0
dim shared as integer ratio = 1
'drawing storage strings for saving and loading
dim shared as string glyph_size
dim shared as string xpos
dim shared as string ypos
dim shared as string brush_color
dim shared as string brush_size
dim shared as string connected
dim shared as string file , ext , filename , File_type
dim shared rct as RECT
dim shared pnt as PAINTSTRUCT
dim shared hDC as HDC
'setup output window objs
dim shared OutPut_Grid as HBITMAP
dim shared OutPut_Grid_Pen as HPEN
dim shared OutPutDC as hDC
dim shared OutPutobj as HGDIOBJ
dim shared OutPutpen_obj as HGDIOBJ
Dim As MSG msg
Dim Shared As HWND hWnd, edit
hWnd = CreateWindowEx( 0, "#32770", "Bitmap Button Test", WS_OVERLAPPEDWINDOW Or WS_VISIBLE , 100, 0, 800, 600, 0, 0, 0, 0 )
edit = CreateWindowEx( 0, "BUTTON", "Button" , WS_BORDER Or WS_VISIBLE Or WS_CHILD or BS_PUSHBUTTON OR BS_BITMAP, 10 , 10 , 50 , 25 , hWnd, 0, 0, 0 )
Load_Font(hWnd,rct)
Dim As Any Ptr MYIMG
Dim As hDC MYDC
Dim As HBitmap MYBMP
Dim As BITMAPINFOHEADER MYBMPINFO
Dim As Integer sx, sy
sx = glyph_x
sy = glyph_y
MYDC = CreateCompatibleDC(OutPutDC)
MYBMP = CreateCompatibleBitmap(OutputDC, sx, sy)
SelectObject(MYDC, MYBMP)
With MYBMPINFO
.biSize = Sizeof(MYBMPINFO)
.biWidth = sx
.biHeight = -sy
.biPlanes = 1
.biBitCount = 32
.biCompression = BI_RGB
.biSizeImage = 0
End With
BitBlt(MYDC, 0, 0, sx, sy, OutputDC, 0, 0, SRCCOPY)
DeleteDC(MYDC)
SendMessage(edit , BM_SETIMAGE , IMAGE_BITMAP , CAST(LPARAM, MYBMP))
'===============================================================================
'===============================================================================
'===============================================================================
'===============================================================================
While GetMessage( @msg, 0, 0, 0 )
TranslateMessage( @msg )
DispatchMessage( @msg )
Select Case msg.hwnd
Case hWnd
Select Case msg.message
Case 273 : PostQuitMessage(0)
End Select
End Select
Wend
Delete_Output_Grid_And_Pen(hWnd)
DeleteObject( MYBMP )
PostQuitMessage(0)
End
'===============================================================================
'===============================================================================
'===============================================================================
'Sub and function below here.
'===============================================================================
'===============================================================================
'===============================================================================
Sub Load_Font(byval hWnd as HWND , byval rct as RECT)
file = ""
file_type="pft"
getfilename()
if file <> "" then
open file for input as #1
line input #1,glyph_size
line input #1,xpos
line input #1,ypos
line input #1,brush_color
line input #1,brush_size
line input #1,connected
close #1
if glyph_x and glyph_y = 0 then
glyph_x=val( left(glyph_size,2))
glyph_y=val(right(glyph_size,2))
end if
print "Glyph Size = " ; glyph_size
print "X Positions = " ; xpos
print "Y positions = " ; ypos
print "Brush Colors = " ; brush_color
print "Brush Sizes = " ; brush_size
print "Draw To = " ; connected
print "Bytes For CHR= " ; len(glyph_size)+len(xpos)+len(ypos)+len(brush_color)+len(brush_size)+len(connected)
print string(78,"=")
Resize_Grids(hWnd)
end if
end sub
'===============================================================================
'===============================================================================
Sub Create_Output_Grid_And_Pen(byval hWnd as HWND , byref bc as ulongint , byref bs_10 as single , byref bs_01 as single)
dim hDC as HDC
OutPut_Grid = CreateCompatibleBitmap(GetDC(hWnd), glyph_x , glyph_y )
OutPut_Grid_Pen = CreatePen(PS_SOLID,sqr(glyph_x*glyph_y)*(((bs_01*.01)+(bs_10*.1))*1 ),bc)
OutPutDC = CreateCompatibleDC(HDC)
Dim As RECT OutPut_Grid_Rect = ( 0 , 0 , glyph_x*ratio , glyph_y*ratio )
SelectObject OutPutDC , OutPut_Grid
FillRect .OutPutDC , @OutPut_Grid_Rect , null
outputobj = SelectObject(OutPutDC , OutPut_Grid )
outputpen_obj = SelectObject(OutPutDC , OutPut_Grid_Pen )
end sub
'===============================================================================
'===============================================================================
sub Delete_Output_Grid_And_Pen(byval hWnd as HWND)
dim hDC as HDC
SelectObject( OutPutDC, outputobj )
SelectObject( OutPutDC, outputpen_obj )
DeleteObject( OutPut_Grid )
DeleteObject( OutPut_Grid_Pen )
DeleteDC( OutPutDC )
end sub
'===============================================================================
'===============================================================================
Sub Select_Pens(byval hWnd as HWND , byref bc as ulongint , byref bs_10 as single , byref bs_01 as single)
OutPut_Grid_Pen = CreatePen( PS_SOLID , sqr(glyph_x*glyph_y)*(((bs_01*.01)+(bs_10*.1))*1 ) , bc )
outputpen_obj = SelectObject( OutputDC, OutPut_Grid_Pen )
end sub
'===============================================================================
'===============================================================================
sub Bit_blt(byval hWnd as HWND)
dim hDC as HDC
hDC = BeginPaint( hWnd, @pnt )
BitBlt(hDC ,(glyph_x*ratio)+60, 0 , glyph_x , glyph_y , OutputDC , 0, 0 , SRCCOPY)
EndPaint( hWnd, @pnt )
end sub
'===============================================================================
'===============================================================================
sub Update(BYVAL hWnd as HWND , BYVal rct as RECT)
InvalidateRect( hwnd, 0, TRUE )
UpdateWindow(hWnd)
end sub
'===============================================================================
'===============================================================================
sub Resize_Grids(byval hWnd as HWND)
Delete_OutPut_Grid_And_Pen( hWnd )
Create_OutPut_Grid_And_Pen( hWnd , b_color , b_size_10 , b_size_01)
ReDraw(hWnd,rct)
end sub
'===============================================================================
'===============================================================================
'ReDraw() goes through strorage strings and replots the character.
'===============================================================================
'===============================================================================
Sub ReDraw(byval hWnd as HWND , byval rct as RECT)
dim hDC as HDC
dim as ulongint count_xy
dim as ulongint count_color
dim as ulongint count_size
dim as ulongint count_connected
dim as ulongint connect
dim as ulongint lx , ly ,mx , my , bc
dim as single bs_10 , bs_01
count_xy =1
count_color =1
count_size =1
count_connected =2
do
lx = (val(mid( xpos ,count_xy +0,3))/100) * (glyph_x*ratio)
ly = (val(mid( ypos ,count_xy +0,3))/100) * (glyph_y*ratio)
mx = (val(mid( xpos ,count_xy +3,3))/100) * (glyph_x*ratio)
my = (val(mid( ypos ,count_xy +3,3))/100) * (glyph_y*ratio)
bc =valulng(mid( brush_color,count_color , 8))
bs_10 = val(mid( brush_size ,count_size +0,1))
bs_01 = val(mid( brush_size ,count_size +1,1))
connect=val(mid( connected ,count_connected,1))
Select_Pens(hWnd,bc,bs_10,bs_01)
hDC = BeginPaint( hWnd, @pnt )
if connect=1 then 'two points are connected
'MoveToEx(FontDC , (lx)-1 , (ly)-1 , 0)
' LineTo(FontDC , (mx)-1 , (my)-1)
MoveToEx(OutPutDC , (lx/ratio)-1 , (ly/ratio)-1 , 0)
LineTo(OutPutDC , (mx/ratio)-1 , (my/ratio)-1)
else ' two points are not connected
'MoveToEx(FontDC , (lx)-1 , (ly)-1 , 0)
' LineTo(FontDC , (lx)-1 , (ly)-1)
MoveToEx(OutPutDC , (lx/ratio)-1 , (ly/ratio)-1 , 0)
LineTo(OutPutDC , (lx/ratio)-1 , (ly/ratio)-1)
end if
EndPaint( hWnd, @pnt )
count_xy +=3
count_color +=8
count_size +=2
count_connected +=1
loop until count_size>=len(brush_size)
'last_x = lx
'last_y = ly
'mouse_x = mx
'mouse_y = my
Update(hWnd,rct)
end sub
'===============================================================================
'===============================================================================
sub getfilename()
dim ofn as OPENFILENAME
dim filename as zstring * MAX_PATH+1
with ofn
.lStructSize = sizeof( OPENFILENAME )
.hwndOwner = hWnd
.hInstance = GetModuleHandle( NULL )
if file_type="pft" then .lpstrFilter = strptr( !"Picto-Font Files , (*.pft)\0*.pft\0\0")
if file_type="bmp" then .lpstrFilter = strptr( !"BitMap Files , (*.bmp)\0*.bmp\0\0")
.lpstrCustomFilter = NULL
.nMaxCustFilter = 0
.nFilterIndex = 1
.lpstrFile = @filename
.nMaxFile = sizeof( filename )
.lpstrFileTitle = NULL
.nMaxFileTitle = 0
.lpstrInitialDir = NULL
.lpstrTitle = @"Save File"
.Flags = OFN_EXPLORER 'or OFN_FILEMUSTEXIST or OFN_PATHMUSTEXIST
.nFileOffset = 0
.nFileExtension = 0
.lpstrDefExt = NULL
.lCustData = 0
.lpfnHook = NULL
.lpTemplateName = NULL
end with
if( GetOpenFileName( @ofn ) = FALSE ) then
file = ""
return
else
dim ext as string
ext = right$(filename,4)
if file_type="pft" then
if ext <> ".pft" then
filename = filename + ".pft"
end if
end if
if file_type="bmp" then
if ext <> ".bmp" then
filename = filename + ".bmp"
end if
end if
file = filename
endif
end sub
Re: Windows Button Image
Hey Albert
Code: Select all
randomize
#include once "windows.bi"
#include "fbgfx.bi"
Declare Sub DrawFont(Byref BUFFER As Any Ptr=0,Byval POSX As Long, Byval POSY As Long, _
Byref FTEXT As String, Byref FNAME As String,Byval FSIZE As Long, _
Byval FCOLOR As Ulong=Rgba(220,86,37,255),Byval FSTYLE As Long=0, _
Byval CHARSET As Integer=DEFAULT_CHARSET)
Dim Shared As Any Ptr i(1 To 16)
Dim szBitmap(Lbound(i) To Ubound(i)) As String
Dim As Point p(1 To 16)
#define distance(p1,p2) sqr( (p1.x-p2.x)^2 + (p1.y-p2.y)^2 )
#define r(f,l) int(Rnd*(((l)+1)-(f)))+(f)
Dim As Long w,h
w=150
h=150-5
Dim As String fnt="arial"
'=======================================
Screenres w,h,32,,-1 'create a temp [hidden] screen
For n As Long=Lbound(i) To Ubound(i)
If n<>Ubound(i) Then i(n)=Imagecreate(w,h,0) Else i(n)=Imagecreate(w,h,Rgb(255,255,255))
Var ln=80-30*Len(Str(n))
If n<>Ubound(i) Then drawfont(i(n),ln,30,Str(n),fnt,60)
Bsave ("small"+Str(n)+".bmp",i(n))
szbitmap(n)="small"+Str(n)+".bmp"
Next n
Screen 0 'return to console
'=========================================
Dim As MSG msg
Dim Shared As HWND hWnd, edit(Lbound(i) To Ubound(i))
Dim shared hbitmap(1 to 16) As handle
hWnd = CreateWindowEx( 0, "#32770", "Bitmap Button Test",WS_OVERLAPPEDWINDOW Or WS_VISIBLE , 100, 0, 620, 620, 0, 0, 0, 0 )
Dim As Integer k,y=0,start
For n As Long=Lbound(i) To Ubound(i)
k+=1
If (k) Mod 5=0 Then y+=h:k=1
p(n)=Type((k-1)*150+w/2,y+h/2)
edit(n) = CreateWindowEx( 0, "BUTTON", "" , WS_VISIBLE Or WS_CHILD Or ANSI_CHARSET Or BS_PUSHBUTTON Or BS_BITMAP, (k-1)*150 , y , w , h , hWnd, 0, 0, 0 )
Next n
#macro update
For n As Long=Lbound(i) To Ubound(i)
deleteobject(hbitmap(n))
hBitmap(n) = LoadImage(0, szBitmap(n), IMAGE_BITMAP, w, h, LR_LOADFROMFILE )
If hbitmap(n) Then SendMessage(edit(n), BM_SETIMAGE, IMAGE_BITMAP, Cast(LPARAM, hbitmap(n)))
Next n
#endmacro
update
Dim As Long n1,n2
For n As Long=1 To 300
Do
n1=r(1,15)
n2=r(1,15)
Loop Until n1<>n2
If distance(p(n1),p(n2))<155 Then
Swap szBitmap(n1),szBitmap(n2)
update
End If
Next n
Dim As Long fnum=16
While GetMessage( @msg, 0, 0, 0 )
TranslateMessage( @msg )
DispatchMessage( @msg )
Select Case msg.hwnd
Case hWnd
Select Case msg.message
Case 273 : PostQuitMessage(0)
End Select
End Select
For n As Long=1 To 16
Select Case msg.hwnd
Case edit(n)
If msg.message = WM_LBUTTONDOWN Then
If distance(p(n),p(fnum))<155 Then
Swap szBitmap(n),szBitmap(fnum)
fnum=n
Swap p(n),p(fnum)
update
End If
End If
End Select
Next n
Wend
PostQuitMessage(0)
#define BOLD 2
#define ITALIC 4
Sub DrawFont(Byref BUFFER As Any Ptr=0,Byval POSX As Long, Byval POSY As Long, _
Byref FTEXT As String, Byref FNAME As String,Byval FSIZE As Long, _
Byval FCOLOR As Ulong,Byval FSTYLE As Long=0, _
Byval CHARSET As Integer)
Static FINIT As Long
Static As hdc THEDC
Static As hbitmap THEBMP
Static As Any Ptr THEPTR
Static As fb.image Ptr FBBLK
Static As Long TXTSZ,RESU,RESUU
Static As hfont THEFONT
Static As Long FW,FI,TXYY',FCOR
Static DSKWND As hwnd, DSKDC As hdc
Static MYBMPINFO As BITMAPINFO
Static As TEXTMETRIC MYTXINFO
Static As SIZE TXTSIZE
Static As RECT RCT
Static As Ubyte Ptr ubp
ubp=Cptr(Ubyte Ptr,@FCOLOR)
Swap ubp[0],ubp[2]
Dim As Ubyte alphaval =ubp[3]
ubp[3]=0
#define FontSize(PointSize) - MulDiv(PointSize, GetDeviceCaps(THEDC, LOGPIXELSY), 72)
If FINIT = 0 Then
FINIT = 1
With MYBMPINFO.bmiheader
.biSize = Sizeof(BITMAPINFOHEADER)
.biWidth = 2048
.biHeight = -513
.biPlanes = 1
.biBitCount = 32
.biCompression = BI_RGB
End With
DSKWND = GetDesktopWindow()
DSKDC = GetDC(DSKWND)
THEDC = CreateCompatibleDC(DSKDC)
THEBMP = CreateDIBSection(THEDC,@MYBMPINFO,DIB_RGB_COLORS,@THEPTR,null,null)
ReleaseDC(DSKWND,DSKDC)
End If
If (FSTYLE And 2) Then FW = FW_BOLD Else FW = FW_NORMAL
If (FSTYLE And 4) Then FI = True Else FI = False
THEFONT = CreateFont(FontSize(FSIZE),0,0,0,FW,FI,0,0,CHARSET,0,0,0,0,Cast(Any Ptr,Strptr(FNAME)))
SelectObject(THEDC,THEBMP)
SelectObject(THEDC,THEFONT)
GetTextMetrics(THEDC,@MYTXINFO)
GetTextExtentPoint32(THEDC,Strptr(FTEXT),Len(FTEXT),@TXTSIZE)
TXTSZ = TXTSIZE.CX
TXYY = TXTSIZE.CY
If (FSTYLE And 4) Then
If MYTXINFO.tmOverhang Then
TXTSZ += MYTXINFO.tmOverhang
Else
TXTSZ += 1+(FSIZE/2)
End If
TXYY += 1+(FSIZE/8)
End If
RCT.LEFT = 0
RCT.TOP = 1
RCT.RIGHT = TXTSZ
RCT.BOTTOM = TXYY+1
TXTSZ -= 1
TXYY -= 1
SetBkColor(THEDC,Rgba(255,0,255,0))
SetTextColor(THEDC,FCOLOR)
SystemParametersInfo(SPI_GETFONTSMOOTHING,null,@RESU,null)
If RESU Then SystemParametersInfo(SPI_SETFONTSMOOTHING,False,@RESUU,null)
ExtTextOut(THEDC,0,1,ETO_CLIPPED Or ETO_OPAQUE,@RCT,Strptr(FTEXT),Len(FTEXT),null)
If RESU Then SystemParametersInfo(SPI_SETFONTSMOOTHING,True,@RESUU,null)
FBBLK = THEPTR+(2048*4)-Sizeof(fb.image)
FBBLK->Type = 7
FBBLK->bpp = 4
FBBLK->Width = 2048
FBBLK->height = 512
FBBLK->pitch = 2048*4
Put BUFFER,(POSX,POSY),FBBLK,(0,0)-(TXTSZ-1,TXYY),Alpha,alphaval
DeleteObject(THEFONT)
End Sub
Sub finish Destructor
For n As Long=Lbound(i) To Ubound(i)
deleteobject(hbitmap(n))
Imagedestroy(i(n)):i(n)=0
Kill "small"+Str(n)+".bmp"
Print "destroying ";n
Next
End Sub
End
Last edited by dodicat on Feb 11, 2019 2:25, edited 1 time in total.
Re: Windows Button Image
@Dodicat
That's a good puzzle program..
That's a good puzzle program..
Re: Windows Button Image
Thanks albert.
I have just edited it( deleteobject(hbitmap(n)) ... to free the memory at each loadimage update.
I have just edited it( deleteobject(hbitmap(n)) ... to free the memory at each loadimage update.