Windows Button Image

Windows specific questions.
albert
Posts: 6000
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Windows Button Image

Post by albert »

@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?
UEZ
Posts: 972
Joined: May 05, 2017 19:59
Location: Germany

Re: Windows Button Image

Post by UEZ »

albert 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?
Hmm, that's odd. It works here on Win10
Image

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)
Read out the FB pixel colors and put it to aBits.

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.
albert
Posts: 6000
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Windows Button Image

Post by albert »

@UEZ

I'm on a Linux box , running the program under wine? wine might not have the proper libs?
UEZ
Posts: 972
Joined: May 05, 2017 19:59
Location: Germany

Re: Windows Button Image

Post by UEZ »

albert wrote:@UEZ

I'm on a Linux box , running the program under wine? wine might not have the proper libs?
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. :-(
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Windows Button Image

Post by dodicat »

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.

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


 
albert
Posts: 6000
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Windows Button Image

Post by albert »

@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.
albert
Posts: 6000
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Windows Button Image

Post by albert »

@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?

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

albert
Posts: 6000
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Windows Button Image

Post by albert »

@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.

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

dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Windows Button Image

Post by dodicat »

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.
albert
Posts: 6000
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Windows Button Image

Post by albert »

@Dodicat

That's a good puzzle program..
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Windows Button Image

Post by dodicat »

Thanks albert.
I have just edited it( deleteobject(hbitmap(n)) ... to free the memory at each loadimage update.
Post Reply