Win: Use arbitrary fonts & load GIF/JPG/PNG to gfx, API only

[Zippy]

[Windows-only, Win2k and newer.]
[Need "bitmapobject.bi", included below,
or next post if not enough space here.]
[Notes, CREDITS, and another example in 3rd post, below.]

This relatively-small and relatively easy to use object will
load these 24/32bit bitmap types: BMP/GIF/JPEG/EXIF/PNG/TIFF
to an automatically created and sized fb Image, from where it
may then be put() to a GFX screen. The source bitmaps may be
from local files OR from an http: URL. If from URL the bitmap
is downloaded to memory-only, not written to disk.

Example image download (image reduced in size, here):
http://www.mediafire.com/view/o9ldn7e9f ... test-3.jpg
Note text annotation.

What may be of more general interest is the objects facility
to generate on-the-fly arbitrary font text. You specify the
text, the font name [font family, i.e., "Arial"], the font
size desired [in points], the font style [i.e., Bold], and
the foreground and background colors for the text. The text
is then rendered to a fb Image, from where it may be put()
to a GFX screen.

Example font test (see below for include file):
http://www.mediafire.com/view/2my96aunz ... test-6.jpg

Usage can be as simple as this (with no error-checking, this
is for demo only):

Code: Select all

'bitmapobject test #1
#include once "bitmapobject.bi"
'
dim bmp as bitmapobject ptr = new bitmapobject
'
bmp->Loadbmp("http://freebasic.net/sites/default/files/horse_original_r_0.gif")
'
put (0,0),bmp->Sprite
'
bmp->ReleaseSprite 'like ImageDestroy()
'
'please cleanup:
delete bmp
sleep

The above code bit, by default, creates both a GFX screen sized
to the size of the downloaded bitmap, and an Image sized to the
size of the downloaded bitmap.

Same code with recommended error checking:

Code: Select all

'bitmapobject test #2
#include once "bitmapobject.bi"
'
dim as integer res
dim as string filename
'
dim bmp as bitmapobject ptr = new bitmapobject
'
filename = "http://freebasic.net/sites/default/files/horse_original_r_0.gif"
'
res=bmp->Loadbmp(filename) 'if res=1 then success
if bmp->IsValid then       'if bmp->IsValid = 1 then is OK
    put(0,0),bmp->Sprite,pset
    bmp->ReleaseSprite     'like ImageDestroy, necessary!
else
    if ScreenPtr=0 then
        screenres(640,480,32)
    end if
    print "Error:"
    print res;" ";bmp->errmess
    print "Sleeping to Exit"
    sleep
    end
end if 
'
'please cleanup:
delete bmp

The usage procedure is:

1. include the include...

2. Dim a new bitmapobject.
You may dim multiples, limited only by variable name validity
and memory (objects and especially bitmaps occupy MEMORY).
You may also Dim arrays, as in:

Code: Select all

#include once "bitmapobject.bi"
dim bmp(1 to 6) as bitmapobject ptr
'
for i as integer = 1 to 6
    bmp(i) = new bitmapobject
next i
'
'use them...
'
'free them...
for i as integer = 1 to 6
    delete bmp(i)
next i
'

3. Load a bitmap (or create "fonted" text)
May load from local file or http: URL. Please test IsValid
after loading or creating fonted text.

4. put(x,y) the Sprite somewhere, eventually.
Then you MUST ->ReleaseSprite, eventually. MUST do this
before reusing the object. If you dont ->ReleaseSprite you
will have a memory leak if the object is reused.

5. delete the object.
I dont know how fb will treat "new" objects when they go out
of scope. You should test with each new fb iteration.

Documentation and code examples in subsequent posts.
This is bitmapobject.bi (if not enough space for it in this post, see next):

Code: Select all

'bitmapobject.bi v20140427
' SAVEAS "bitmapobject.bi"
'
#include once "win\gdiplus.bi"
    using gdiplus
#include once "windows.bi"
#include once "win\wininet.bi"
'
Type FBGDI_Image_Struct
    hDC      As HDC
    jBitmap  As HBITMAP
    hPalette As HPALETTE
    Sprite   As Any Ptr
    Buffer   As Any Ptr
    Data     As UByte Ptr
end type
type FBGDI_Image As FBGDI_Image_Struct Ptr
'
type bitmapobject
'
    declare destructor()
    '
    declare function LoadBmp(_
                byval filename as string,_
                noscreen as integer = 0,_
                xsize as integer = 0,_
                ysize as integer = 0,_
                noresize as integer = 0) as integer
    '
    declare function LoadFont(_
                byval strtext as string = "Feed Me",_
                byval fontname as string = "Arial",_
                fontsize as integer = 12,_
                fstyle as integer = 0,_
                forecolor as integer = rgba(255,255,255,255),_
                backcolor as integer = rgba(0,0,0,255)) as integer
    '
    declare function FBGDI_Create Alias "FBGDI_Create" (_
                ByVal w As Integer,_
                ByVal h As Integer,_
                d As Integer = 32) As FBGDI_Image
    '            
    declare sub ReColor(_
                byval img as any ptr,_
                ReplaceThis As Uinteger,_
                WithThis As Uinteger)
    '
    declare sub ReleaseSprite()
    '
    declare sub keepalive()
    '
    declare function dlfile(_
                sURL as string,_
                ByRef DLbuffer as string,_
                mode as integer =0) as integer
    '
    declare function SetScreen(_
                ontop as integer =0,_
                showhide as integer =0) as integer        
    '
    dim as integer iwidth,iheight,filesize,IsValid
    dim as double begintime,endtime,loadtime
    dim as any ptr ImgPtr,Sprite
    dim as FBGDI_Image TSprite
    dim as string errmess,orgname
'
end type
'
'===================================================
destructor bitmapobject
    ReleaseSprite
end destructor
'
sub bitmapobject.ReleaseSprite()
'
    if this.Tsprite <> 0 then
        DeleteDC(TSprite->hDC)
        DeleteObject(TSprite->buffer)
        DeleteObject(TSprite->jbitmap)
        TSprite->Sprite=0
        TSprite=0
    end if
    this.IsValid=0
'
end sub
'
'===================================================
function bitmapobject.LoadBmp(_
                byval filename as string,_
                noscreen as integer = 0,_
                xsize as integer = 0,_
                ysize as integer = 0,_
                noresize as integer = 0) as integer
'
    this.Sprite=0
    this.IsValid=0
    errmess="No Error"
    begintime=timer
    '
    if filename="" then
        errmess="No filename specified"
        return -1
    else
        orgname=filename
    end if
    '
    dim as GdiplusStartupInput gdipsi
    dim as ULONG_PTR gdipToken
    dim as GpImage ptr pImage=0,pThumb=0
    '    
    dim as integer res
    dim as integer filehandle
    dim as double wratio
    dim as string sbuffer
    '
    dim as HBITMAP iBmp=0
    dim as HGLOBAL hglobal = 0
    dim as any ptr pGlobalBuffer = 0
    dim as LPSTREAM iImageStream = 0
    dim as RECT dc
    '
    '=====================================
    '
    gdipsi.GdiplusVersion = 1
    if (GdiplusStartup(@gdipToken,@gdipsi,null)<>0) then
        errmess="GdiplusStartup failed"
        return -2
    end if
    '
    if instr(ucase(filename),"HTTP")=1 then
        filesize=dlfile(filename,sbuffer)
        if filesize<=0 then
            GdiplusShutdown(gdipToken)
            return filesize
        end if
        hglobal=GlobalAlloc(&H42,filesize)
        pGlobalBuffer = GlobalLock(hGlobal)
        CopyMemory(pGlobalBuffer,strptr(sbuffer),filesize)
        CreateStreamOnHGlobal(hGlobal,0,@iImageStream)
        GdipCreateBitmapFromStream(iImageStream,@pImage)
        sbuffer=""
    else
        if (GdipCreateBitmapFromFile(wstr(filename),@pimage)<>0) then
            errmess="CreateBitmapFromFile failed, bad file type or name"
            res= -4
            if iImageStream<>0 then IUnknown_Release(iImageStream)
            if pGlobalBuffer<>0 then GlobalUnlock(pGlobalBuffer)
            if hGlobal<>0 then GlobalFree(hGlobal)
            if pImage<>0 then GdipDisposeImage(pImage)
            if pThumb<>0 then GdipDisposeImage(pThumb)
            if ibmp<>0 then deleteobject(ibmp)
            GdiplusShutdown(gdipToken)
            return res
        end if
        '
    end if
    '
    GdipGetImageWidth  (pimage,@iwidth)
    GdipGetImageheight (pimage,@iheight)
'
'============== allow image scaling       
        if xsize>0 and ysize>0 then
            iwidth = xsize
            iheight = ysize
        elseif xsize>0 then
            wratio = xsize/iwidth
            iwidth = xsize
            iheight = int(iheight * wratio)
        elseif ysize>0 then
            wratio = ysize/iheight
            iheight = ysize
            iwidth = int(iwidth * wratio)
        end if    
'==============
'
        wratio=iwidth/iheight        
'
'============== Make too-large image fit desktop       
        if noresize=0 then
            GetWindowRect(GetDesktopWindow,@dc)
            if iwidth > dc.Right then
                iwidth=dc.right
                iheight = int(iheight * wratio)
            end if
            if iheight > dc.Bottom then
                iheight=dc.bottom
                iwidth = int(iheight * wratio)
            end if
        end if
'==============
'    
    GdipGetImageThumbnail( pImage, iwidth, iheight, @pThumb, null, null )
    '    
    dim as HWND vhwnd = GetDesktopWindow
    dim pDC as HDC = getDC(vhwnd)
    dim as HDC MemDC = CreateCompatibleDC(pDC)
    '
    res=GdipCreateHBITMAPFromBitmap(pThumb,@ibmp,0)
    '
    if res=0 then
        SelectObject(MemDC,iBmp)
        TSprite = FBGDI_Create(iwidth,iheight)
        res=BitBlt(_
            TSprite->hDC,_
            0, 0,_
            iwidth,_
            iheight,_
            MemDC, 0, 0, SRCCOPY)
        '
        this.Sprite= *(@TSprite->Sprite)
    else
        errmess="GdipCreateHBITMAPFromBitmap or BitBlt failed in LoadBmp()"
        res= -5
    end if 
    '
    if iImageStream<>0 then IUnknown_Release(iImageStream)
    if pGlobalBuffer<>0 then GlobalUnlock(pGlobalBuffer)
    if hGlobal<>0 then GlobalFree(hGlobal)
    if pImage<>0 then GdipDisposeImage(pImage)
    if pThumb<>0 then GdipDisposeImage(pThumb)
    if ibmp<>0 then deleteobject(ibmp)
    ReleaseDC(vhwnd,pDc)
    DeleteDC(MemDC)
    GdiplusShutdown(gdipToken)
    '
    if noscreen=0 then
        screenres(iwidth,iheight,32,,4)
        if res<0 then print errmess:return res
    end if
    '
    endtime=timer
    loadtime=endtime-begintime
    this.IsValid=1
    return 1
'
end function
'
'===================================================
'See: http://www.ampsoft.net/webdesign-l/WindowsMacFonts.html for fontnames
'See: http://en.wikipedia.org/wiki/List_of_Microsoft_Windows_fonts
function bitmapobject.LoadFont(_
                byval strtext as string = "Feed Me",_
                byval fontname as string = "Arial",_
                fontsize as integer = 12,_
                fstyle as integer = 0,_
                forecolor as integer = rgba(255,255,255,255),_
                backcolor as integer = rgba(0,0,0,255)) as integer
'
    dim as GdiplusStartupInput gdipsi
    dim as ULONG_PTR gdipToken
    dim as integer hStatus
    '
    dim as GpGraphics ptr     pGraphics
    dim as Gpfont ptr         pFont
    dim as GpFontFamily ptr   pFontFamily = NULL
    dim as Gpbrush ptr        pBlackBrush,tpen,tbrush 
    dim as GpStringFormat ptr pformat
    dim as GpBitmap ptr       gbmp
    '
    dim as RECTF rcf,layoutRect,boundRect
    dim as HBITMAP iBmp=0
    dim as integer res
    '
    this.Sprite=0
    this.IsValid=0
    errmess="No Error"
    res=0
    '
    if strtext ="" then errmess="No text to print":return -1
    if fontname="" then errmess="No fontname specified":return -1
    if fontsize<6  then errmess="Font size too small, <6": return -1
    '    
    gdipsi.GdiplusVersion = 1
    if (GdiplusStartup(@gdipToken,@gdipsi,null)<>0) then
        errmess="GdiplusStartup failed"
        return -2
    end if
    '
    dim as HWND vhwnd = GetDesktopWindow
    dim pDC as HDC = getDC(vhwnd)
    dim as HDC MemDC = CreateCompatibleDC(pDC)
'
'============================================================
'
    'check if fontname is valid, then get size
    hStatus = GdipCreateFromHDC(pDC, @pGraphics)
    hStatus = GdipCreateFontFamilyFromName(wstr(fontname),NULL,@pFontFamily)
    if hStatus = 0 and pFontFamily <> NULL then
        hStatus = GdipCreateFont(_
            pFontFamily,_
            fontsize,_
            fstyle,_
            UnitPoint,_
            @pFont)
        '  
        GdipDeleteFontFamily(pFontFamily)
    else
        res= -3
        errmess="This font is unavailable"
        if pFontFamily <> NULL then GdipDeleteFontFamily(pFontFamily)
        goto cleanupafterfont:
    end if
    '
    layoutRect.x = 0.0: layoutRect.y = 0.0: layoutRect.Width = 800.0: layoutRect.Height = 200.0
    hStatus = GdipCreateStringFormat(0, LANG_NEUTRAL,@pFormat)
    hStatus = GdipSetStringFormatAlign(pFormat,0)' %StringAlignmentFar)
    '
    'measure the string
    hStatus = GdipMeasureString(_
            pGraphics,_
            wstr(strText),_
            len(strText),_
            pFont,_
            @layoutRect,_
            pFormat,_
            @boundRect,_
            0,0)
    '
    iwidth = int(boundRect.Width + 1)
    iheight= int(boundRect.Height + 1)
    '
    if pFormat then GdipDeleteStringFormat(pFormat)
    if pGraphics then GdipDeleteGraphics(pGraphics)
    '
    if iwidth<4 or iheight<4 then
        res= -3
        errmess = "Unable to get font size in LoadFont()"
        goto cleanupafterfont:
    end if
'    
'============================================================
'
    hstatus=GdipCreateBitmapFromScan0(iwidth,iheight,NULL,PixelFormat32bppARGB,NULL,@Gbmp)
    hstatus=GdipGetImageGraphicsContext(Gbmp,@pGraphics)
    '
    GdipCreateSolidFill(backcolor,@tbrush)
    GdipFillRectangle(pGraphics,tbrush,0,0,iwidth,iheight)
    '
    hStatus = GdipCreateSolidFill(forecolor,@pBlackBrush)
    '
    rcf.x = 0.0 : rcf.y = 0.0
    hStatus = GdipDrawString(_
            pGraphics,_
            wstr(strText),_
            LEN(strText),_
            pFont,_
            @rcf,_
            NULL,_
            pBlackBrush)
    '
    hstatus=GdipCreateHBITMAPFromBitmap(gbmp,@ibmp,0)
    '
    if hstatus=0 then
        SelectObject(MemDC,iBmp)
        TSprite = FBGDI_Create(iwidth,iheight)
        res=BitBlt(_
            TSprite->hDC,_
            0, 0,_
            iwidth,_
            iheight,_
            MemDC, 0, 0, SRCCOPY)
        '
        this.Sprite= *(@TSprite->Sprite)
    else
        errmess="GdipCreateHBITMAPFromBitmap or BitBlt failed in LoadFont()"
        res= -5
        goto cleanupafterfont:
    end if 
    '
    this.IsValid=1
    res=1
    '
cleanupafterfont:
    '
    'cleanup
    if pFont then GdipDeleteFont(pFont)
    if tpen then GdipDeleteBrush(tpen)
    if tbrush then GdipDeleteBrush(tbrush)
    if pBlackBrush then GdipDeleteBrush(pBlackBrush)
    if pGraphics then GdipDeleteGraphics(pGraphics)
    if ibmp<>0 then deleteobject(ibmp)
    if gbmp<>0 then GdipDisposeImage(gbmp)
    '    
    ReleaseDC(vhwnd,pDc)
    DeleteDC(MemDC)
    GdiplusShutdown(gdipToken)
    '  
    return res
'
end function
'
'===================================================
'@jofer's code, modified
private function bitmapobject.FBGDI_Create Alias "FBGDI_Create" (ByVal w As Integer, ByVal h As Integer, d As Integer = 32) As FBGDI_Image
'
    dim BitmapInfo As BITMAPINFO Ptr
    dim Image as FBGDI_Image
    dim iUsage as integer
    dim as integer r, g, b, x,res
    '
    if (w < 4) then return 0
    '
    Image = CAllocate(SizeOf(FBGDI_Image_Struct))
    Image->hDC = CreateCompatibleDC(GetDC(0))
    '
    BitmapInfo = CAllocate(SizeOf(BITMAPINFO) + 255*SizeOf(RGBQUAD))
    with BitmapInfo->bmiHeader
        .biSize = SizeOf(BITMAPINFOHEADER)
        .biWidth = w
        .biHeight = -(h+1)
        .biPlanes = 1
        .biBitCount = d
        .biCompression = BI_RGB
    end with
    '
    Image->jBitmap = CreateDIBSection(Image->hDC, BitmapInfo, DIB_RGB_COLORS, @Image->Buffer, NULL, 0)
    SelectObject Image->hDC, Image->jBitmap
    '
    'Map the viewport origin to (0, 1) and clip it
    ' so the top line can be used for FB sprite data
    SelectClipRgn Image->hDC, CreateRectRgn(0, 1, w, h+1)
    SetViewportOrgEx Image->hDC, 0, 1, NULL
    '
    'Set the FB Sprite header
    Image->Data = Cast(UByte Ptr, Image->Buffer) + w*(d Shr 3)
    Image->Sprite = Cast(Any Ptr, Image->Data - 4)
    '    
    CPtr(UShort Ptr, Image->Sprite)[0] = (w Shl 3) Or (d Shr 3)
    CPtr(UShort Ptr, Image->Sprite)[1] = h
    '
    Deallocate BitmapInfo
    '
    return Image
'
end function
'
'this is @dodicat's code, modified.
sub bitmapobject.ReColor(byval img as any ptr,ReplaceThis as uinteger,WithThis as uinteger)
'
    dim as integer _x,_y
    dim as integer pitch,pitch2
    dim as any pointer row,row2
    dim as uinteger pointer pixel,pixel2
    dim as uinteger col
    '
    Imageinfo img,_x,_y,,pitch2,row2
    '
    for y as integer=0 to _y-1
        for x as integer=0 to _x-1
            pixel=row2+pitch2*((y))+((x)) Shl 2
            (col)=*pixel
            if col=ReplaceThis then col=WithThis
            pixel2=row2+pitch2*((y))+((x)) Shl 2
            *pixel2=(col)
        next x
    next y
'
end sub
'
'===================================================
function bitmapobject.dlfile(_
            sURL as string,_
            ByRef DLbuffer as string,_
            mode as integer =0) as integer
'
    this.filesize=0
    '
    dim as HINTERNET hOpen,hFile
    dim as integer ctot,fh,nret,res,timeout
    dim as string tbuff,ts
    dim as string scUserAgent = "FreeBASIC"
    dim as string mybuff,filename
    '
    if mode<>0 then filename=DLbuffer
    '
    'Test for internet connection..
    res=InternetAttemptConnect(0)
    if res<>0 then
        errmess="InternetAttemptConnect failed in dlfile()" 
        return  -1
    end if
    '
    'create an internet connection
    hOpen=InternetOpen(scUserAgent,INTERNET_OPEN_TYPE_PRECONFIG,NULL,NULL,0)
    if hOpen=0 then
        errmess="InternetOpen failed in dlfile()" 
        return -2 'failed..
    end if
    '
    'set timeout in milliseconds
    timeout=5000
    res=InternetSetOption(_
  	                hOpen,_
  	                INTERNET_OPTION_RECEIVE_TIMEOUT,_
  	                @timeout,_
  	                SizeOf(timeout))
    '
    'Open the url
    hFile=InternetOpenUrl(hOpen,sURL,NULL,0,INTERNET_FLAG_RELOAD or INTERNET_FLAG_NO_CACHE_WRITE,0)
    if hFile=0 then
        errmess="InternetOpenUrl failed in dlfile()" 
        return -3 'failed..
    end if
    '
    ctot=0
    DLbuffer=""
    nret=99
    while nret>0
        mybuff=space(2048)
        res=InternetReadFile(hFile,strptr(mybuff),2048,@nret)
        if nret>0 then
            DLbuffer += left(mybuff,nret)
            ctot+=nret
        end if
    wend
    '
    if mode<>0 then
        if ctot>0 then
            kill filename
            fh=freefile
            open filename for binary access write as fh
            put #fh,,DLbuffer
            close fh
        end if
    end if
    '
    InternetCloseHandle(hFile)
    InternetCloseHandle(hOpen)
    '
    this.filesize=ctot
    '
    if ctot=0 then
        errmess="0 bytes downloaded in dlfile, failed"
        return -4
    end if
    '
    return ctot
'
end function
'
'===================================================
sub bitmapobject.keepalive()
'
    dim as integer res
    dim as HWND hwnd
    ' 
    screencontrol(2,cast(integer,hwnd))
    keybd_event(VK_MENU,0, KEYEVENTF_EXTENDEDKEY,0)
    keybd_event(VK_MENU,0, KEYEVENTF_EXTENDEDKEY OR KEYEVENTF_KEYUP, 0)
    res=SetForegroundWindow(hwnd)
'
end sub
'
function bitmapobject.SetScreen(ontop as integer =0,showhide as integer =0) as integer
'
    if Screenptr=0 then return 0
    if  (ontop>1 orElse ontop<0) _
        orElse _
        (showhide>1 orElse showhide<0) then return 0
    '
    dim as integer res
    dim as integer flags = SWP_NOMOVE Or SWP_NOSIZE Or SWP_NOREDRAW
    dim as HWND zhwnd,placement
    '
    ScreenControl(2,cast(integer,zhwnd))
    if zhwnd=0 then return 0
    '
    if showhide=1 then
        flags Or= SWP_HIDEWINDOW
    else
        flags Or= SWP_SHOWWINDOW
    end if
    '
    if ontop=1 then
        placement = cast(..HWND,-1)
    else
        placement = cast(..HWND,-2)
    end if
    '
    res=SetWindowPos(zhwnd,placement,0,0,0,0,flags)
    '
    return res
'
end function

Z.

ETA: bi mod, to include "https:" files.

[Zippy]

bitmapobject documentation [partial]

Code: Select all

Method:
LoadBmp(
    filename              (local file or http: URL)
    Dont Create Gfx Scrn  (1=TRUE, default is 0 = Create Gfx Scrn)
    x axis size           (*)
    y axis size           (*) 
    Dont Auto-Resize bmp  (1=TRUE, default is 0 = will auto-resize)

The default is to load the bitmap and create a correctly-sized
  gfx screen [you still need to put() the Sprite]. Using "1" as
  the 2nd parameter prevents the automatic gfx screen creation.
  
The default is to automatically resize the bitmap if it is larger
  than your primary desktop, the size reduction will be proportional. 
  Using "1" as the 4th parameter will prevent automatic resizing.
  
* You may aribtrarily resize the bitmap when loading it (not after).
  You may proportionally resize by specifying ONE of the axis
  dimensions, i.e., 0,800 would proportionally resize the bitmap to
  800 pixels tall (y).
  
Properties:
    ->IsValid             = 1 if load to Sprite successful, else 0
    ->errmess             Error text if not IsValid
    ->iWidth              bitmap width
    ->iHeight             bitmap height

'====================================================================
    
Method:
LoadFont(_
    text to create on sprite
    font name             (passed as string, see below)   
    font point size       (>=6)
    font style            (bold, underline, etc.)
    foreground text color rgba()
    background text color rgba()
    
Windows font names [Family]:

"Arial"
"Comic Sans MS"
"Courier New"
"Lucida Console"
"Palatino Linotype"
"Tahoma"
"Times New Roman"
"Trebuchet MS"
"Verdana"
 
You are not limited to using these fonts. These are most likely found
  on all Win2k & forward Latin-based systems. You should test for
  IsValid() if attempting to use a non-standard font "blind" 
  [your program is run on a system not under your purview].
  
Font styles are integer values, variable names|values set by GDI+:
 
FontStyleRegular          (value = 0) 
FontStyleBold             ( = 1)
FontStyleItalic           ( = 2)
FontStyleBoldItalic       ( = 3)
FontStyleUnderline        ( = 4)
FontStyleStrikeout        ( = 8)

The font styles may be ored togather, i.e.,  
  FontStyleBold OR FontStyleUnderline
  
Fore and Back text colors are passed as RGBA values. Failure to
  specify a [reasonable] Alpha value will leave you with
  invisible text. 
  
Properties:

Same as for LoadBmp().

Example #3 (ex image in first OP):

Code: Select all

'bitmapobject test #3
#include once "bitmapobject.bi"
'
dim as string filename
'
dim bmp as bitmapobject ptr = new bitmapobject
'
filename="http://upload.wikimedia.org/wikipedia/commons/thumb/0/00/Crab_Nebula.jpg/600px-Crab_Nebula.jpg"
'
bmp->LoadBmp(filename)
if bmp->IsValid then
    put (0,0),bmp->Sprite,pset
end if
bmp->Releasesprite
'
bmp->LoadFont("Crab Nebula","Lucida Console",16,,rgba(255,255,255,255),rgba(0,0,0,255))
put(0,0),bmp->Sprite,or
bmp->ReleaseSprite
'
'please cleanup:
delete bmp
sleep

Example #4:
[reduced sized result image here: http://www.mediafire.com/view/go12jigvj ... test-4.jpg]

Code: Select all

'bitmapobject test #4
#include once "bitmapobject.bi"
'
dim as integer res
dim as string filename
'
dim bmp1 as bitmapobject ptr = new bitmapobject
dim bmp2 as bitmapobject ptr = new bitmapobject
'
filename = "http://radar.weather.gov/Conus/RadarImg/hawaii.gif"
bmp1->LoadBmp(filename,1,,480)
'
filename = "http://www.goes.noaa.gov/GIFS/HAIR.JPG"
bmp2->LoadBmp(filename,1,,480)
'
if bmp1->IsValid and bmp1->IsValid then
    screenres(bmp1->iwidth + bmp2->iwidth,480,32,1,4)
    put (0,0),bmp1->Sprite
    put (bmp1->iwidth,0),bmp2->Sprite
else
    screenres(640,480,32)
    print "Error:"
    print "bmp1: ";bmp1->errmess
    print "bmp2: ";bmp2->errmess
end if
'
'we're done with sprites/images, get in habit of destroying them:
bmp1->ReleaseSprite
bmp2->ReleaseSprite        
'
'please cleanup:
'
delete bmp1
delete bmp2
'
sleep

Example #5 (begin font tests):
[result image here: http://www.mediafire.com/view/umb4h3jkm ... test-5.jpg]

Code: Select all

'bitmapobject test #5 font example
#include once "bitmapobject.bi"
'
dim as string ts
'
dim bmp as bitmapobject ptr = new bitmapobject
'
screenres(640,480,32,1,4)
'
ts="Now is the time"
for i as integer = 1 to 9
    bmp->LoadFont(ts,"Arial",i*6,,rgba(rnd*255,rnd*255,rnd*255,255),rgba(0,0,0,255))
    'if bmp->IsValid...
    put (0,i*i*4),bmp->Sprite
    bmp->ReleaseSprite        'very important
next i
'
for i as integer = 1 to len(ts)
    bmp->LoadFont(mid(ts,i,1),"Lucida Console",14,,rgba(rnd*255,rnd*255,rnd*255,255),rgba(0,0,0,255))
    put (606-(bmp->iwidth/2),i*19),bmp->Sprite
    bmp->ReleaseSprite
next i
'
delete bmp
sleep

Example #6 (font testing, font Name/Family):
[result image here: http://www.mediafire.com/view/2my96aunz ... test-6.jpg]

Code: Select all

'bitmapobject test #6 another font example
#include once "bitmapobject.bi"
'
dim as string ts,fontname
'
dim bmp as bitmapobject ptr = new bitmapobject
'
screenres(640,480,32,1,4)
'
restore
for i as integer = 1 to 9
    read fontname
    bmp->LoadFont(fontname & " " &str(i*6),fontname,i*6,,rgba(rnd*255,rnd*255,rnd*255,255),rgba(0,0,0,255))
    'if bmp->IsValid...
    put (0,i*i*4),bmp->Sprite
    bmp->ReleaseSprite        'very important
next i
'
delete bmp
sleep
'
Data "Arial"
Data "Comic Sans MS"
Data "Courier New"
Data "Lucida Console"
Data "Palatino Linotype"
Data "Tahoma"
Data "Times New Roman"
Data "Trebuchet MS"
Data "Verdana"
'

Example #7 (more font testing, FontStyle):

Code: Select all

'bitmapobject test #7 another font example
#include once "bitmapobject.bi"
'
dim as string ts
dim as integer fstyle
'
dim bmp as bitmapobject ptr = new bitmapobject
'
screenres(640,480,32,1,4)
'
restore
for i as integer = 1 to 6
    read ts,fstyle
    bmp->LoadFont(ts,"Arial",32,fstyle,rgba(rnd*255,rnd*255,rnd*255,255),rgba(0,0,0,255))
    'if bmp->IsValid...
    put (0,i*58),bmp->Sprite
    bmp->ReleaseSprite        'very important
next i
'
delete bmp
sleep
'
Data "FontStyleRegular",FontStyleRegular 
Data "FontStyleBold",FontStyleBold
Data "FontStyleItalic",FontStyleItalic 
Data "FontStyleBoldItalic",FontStyleBoldItalic
Data "FontStyleUnderline",FontStyleUnderline
Data "FontStyleStrikeout",FontStyleStrikeout
'

Example #8 (more fonts, varying alpha channel):

Code: Select all

'bitmapobject test #8 font example, alpha
#include once "bitmapobject.bi"
'
dim as string ts
'
dim bmp as bitmapobject ptr = new bitmapobject
'
screenres(640,480,32,1,4)
'
ts="Now is the time"
for i as integer = 1 to 9
    bmp->LoadFont(ts,"Arial",i*6,,rgba(rnd*255,rnd*255,rnd*255,255-i*20),rgba(0,0,0,255))
    'if bmp->IsValid...
    put (0,i*i*4),bmp->Sprite
    bmp->ReleaseSprite        'very important
next i
'
for i as integer = 1 to len(ts)
    bmp->LoadFont(mid(ts,i,1),"Lucida Console",14,,rgba(rnd*255,rnd*255,rnd*255,255),rgba(0,0,0,255))
    put (606-(bmp->iwidth/2),i*19),bmp->Sprite
    bmp->ReleaseSprite
next i
'
delete bmp
sleep

Example #9 (more fonts testing, comparo of courier 10 with fb internal draw string):

Code: Select all

'bitmapobject test #9 another font example
#include once "bitmapobject.bi"
#include once "vbcompat.bi"
'
randomize
'
dim as ubyte c,p
dim as string ts
dim as double tv,tot
'
dim bmp as bitmapobject ptr = new bitmapobject
'
screenres(640,480,32,1,4)
color rgb(255,255,255),rgb(255,255,255)
width 640\8,480\16
'
ScreenLock
'
for i as integer = 1 to 18
    tv=rnd*9999
    tot+=tv
    ts=format(tv,"000000.00000000")
    p=0:c=ts[p]:while c<49:ts[p]=32:p+=1:c=ts[p]:wend

    bmp->LoadFont(ts,"Courier New",10,,rgba(0,0,0,255),rgba(255,255,255,255))
    put (0,i*21),bmp->Sprite,pset
    bmp->ReleaseSprite
    
    draw string (180,i*21+2),ts,0
    
next i
'
ts= string(15,"-")
bmp->LoadFont(ts,"Courier New",10,,rgba(0,0,0,255),rgba(255,255,255,255))
put (0,19*21),bmp->Sprite,pset
bmp->ReleaseSprite
draw string (180,19*21+2),ts,0
'
ts=format(tot,"000000.00000000")
p=0:c=ts[p]:while c<49:ts[p]=32:p+=1:c=ts[p]:wend
bmp->LoadFont(ts,"Courier New",10,,rgba(0,0,0,255),rgba(255,255,255,255))
put (0,20*21),bmp->Sprite,pset
bmp->ReleaseSprite
draw string (180,20*21+2),ts,0
'
ScreenUnlock
'
delete bmp
sleep

.
That's enough. I'll add supplemental documentation later.

Z.

[Zippy]

Notes:

RE: UNICODE support

As-is, as posted, bitmapobject.bi will not support UNICODE.

I believe that LoadFont() will support UNICODE if the 2 "as string" references in the declaration and the bitmapobject.LoadBmp() header are changed to "as wstring ptr", and then (of course) wstrings are passed to the function. GDI+ uses wide strings by default; as-is I'm converting the filename and fontname to wide strings within the function using wstr() - passing wstrings to wstr() is not, according to fb docmentation, a problem.

LoadBmp() is more... problematic as it calls other functions (mine) that call other functions (Internet-type) that MAY or MAY NOT be easily transformed to accomodate UNICODE. I will attempt a conversion upon request, if the requestor is willing and capable of testing the modified code. No guarantees.

=====

RE: CREDITS

I'm using part of a proof-of-concept code bit posted by fb community member @jofers ca 2006. Thanks, jofers, albeit I've cursed you a dozen times while trying to figure out how to stop the code bit memory leaks (my failing, not yours).

-----

I'm [now] using part of a code bit posted by fb community user @dodicat, code that "recolours" fb images; useful when translating a background color to transparency [rgba(255,0,255,255]. Use of ->ReColor() appears first in the program example below. Yes, I've translated "recolour" to "recolor" - Imperialism ;-)

-----

He'd otherwise never know it, but one line from a post by fb community user @MichaelW was the key to get a GpGraphics draw to occur on a Gpbitmap [the latter required, in order to get an HBITMAP]. One line makes or breaks the final product.

-----

I might thank Jose Roca and PowerBasic for the GDI+ Flat examples. I do so, reluctantly. The PB lack of strict typing makes translation to fb a freaking nightmare process.

=================== Fully-functional example program:

One of my interests is meteorology ("weather"). Below is a bit of code that displays the current US National Weather Service Radar image for a specific [radar] location. This utilizes 1 JPEG background image and 5 GIF overlays. I begged the NWS years ago to use a common background color for their GIFs - they previously used a variety of transparent colors - we settled on BLACK. I've used other methods in the past, now @dodicat's, to transform the BLACK to rgb(255,0,255) which is the color that fb uses for transparency. I'm not happy with their "Cities" overlay, I use my own elsewhere.

I've used radar loc "ENX" (Albany, NY, USA) here because there was discernible activity there at the time I posted this.

Code: Select all

'Windows bitmapobject test
' US "radar"
' Compile as -s gui
'
'  SEE: http://forecast.weather.gov/jetstream/doppler/ridge_download.htm#radar
'       for US radar sites
'
#include once "bitmapobject.bi"
'
#define DoLoop
'
dim as string rad="ENX"   'radar site
dim as double interval=15 'minutes to loop
'
dim as integer c=0
dim as double delay
dim as string filename,wtitle
'
'create six instances of the bitmap object
dim as bitmapobject ptr bmp(1 to 6)
for i as integer =1 to 6
    bmp(i) = new bitmapobject
next i
'
'open/load the bitmaps - these are static, only loading them once
filename = "http://radar.weather.gov/ridge/Overlays/Topo/Short/" & _
            rad & "_Topo_Short.jpg"

bmp(1)->LoadBmp(filename,1)
if bmp(1)->IsValid then
    screenres(bmp(1)->iwidth,bmp(1)->iheight,32,1,4)
else
    screenres(640,480,32,,4)
    print "Load failed, bailing..."
    print "  Sleeping to Exit"
    sleep
    end
end if
'
filename = "http://radar.weather.gov/ridge/Overlays/Highways/Short/" & _
            rad & "_Highways_Short.gif"
bmp(2)->LoadBmp(filename,1)
bmp(2)->ReColor(bmp(2)->Sprite,0,rgb(255,0,255))
'
filename = "http://radar.weather.gov/ridge/Overlays/Cities/Short/" & _
            rad & "_City_Short.gif"
bmp(4)->LoadBmp(filename,1)
bmp(4)->ReColor(bmp(4)->Sprite,0,rgb(255,0,255))
'
'========================== Loop
'
'these w/filename below are dynamic images, reloaded each interval minutes

#ifdef DoLoop
do
#endif
'
    put (0,0),bmp(1)->Sprite,pset
    put (0,0),bmp(2)->Sprite,trans
    
    filename = "http://radar.weather.gov/ridge/RadarImg/N0R/" & _
                rad & "_N0R_0.gif"
    bmp(3)->LoadBmp(filename,1)
    bmp(3)->ReColor(bmp(3)->Sprite,0,rgb(255,0,255))
    put (0,0),bmp(3)->Sprite,trans
    bmp(3)->ReleaseSprite
    '
    put (0,0),bmp(4)->Sprite,trans
    '
    filename = "http://radar.weather.gov/ridge/Warnings/Short/" & _
                rad & "_Warnings_0.gif"
    bmp(6)->LoadBmp(filename,1)
    bmp(6)->ReColor(bmp(6)->Sprite,0,rgb(255,0,255))
    put (0,0),bmp(6)->Sprite,trans
    bmp(6)->ReleaseSprite
    '
    filename = "http://radar.weather.gov/ridge/Legend/N0R/" & _
                rad & "_N0R_Legend_0.gif"
    bmp(5)->LoadBmp(filename,1)
    bmp(5)->ReColor(bmp(5)->Sprite,0,rgb(255,0,255))    
    put (0,0),bmp(5)->Sprite,trans
    bmp(5)->ReleaseSprite
    '
    wtitle=rad & " requested at " & time & " on " & date

#ifndef DoLoop
windowtitle wtitle
#endif

    c+=1
    '
#ifdef DoLoop
    delay = timer + (interval * 60)
    while timer<delay
        windowtitle wtitle & "  (Next: " & str((delay-timer)\60) & " minutes)"
        sleep 60000
        if inkey<>"" then exit do
    wend
loop
#endif
'
'========================== End Loop
'
'cleanup, please
for i as integer=1 to 6
    '
    delete bmp(i) 'remaining sprites will be destroyed
                  '  when program exits - as would the objects.
                  '  Just a good habit to delete them all
next i    
'
#ifndef DoLoop
sleep
#endif
'done

Z.

[Zippy]

bitmapobject.bi, supplemental documentation

Method:
dlfile(
sURL
DLbuffer
mode

This is a combination of 2 methods to [down]load files (from internet, not local) that I've posted recently.

This is an exposed method, one independent of LoadBmp() and LoadFont(). You can use it in mid-stream without affecting other methods. You don't need to use in order to use bitmapobject, it's simply left exposed if you have use for it. Or you can copy it from bitmapobject.bi and use it wherever.

dlfile [as implemented in bitmapobect.bi] defaults to downloading to a string buffer.

Code: Select all

#include once "bitmapobject.bi"
dim bmp as bitmapobject ptr = new bitmapobject
'
dim as integer res
dim as string url,ts=""
url="http://www.freebasic.net/forum/"
'
res=bmp->dlfile(url,ts)
'
'if res>0 then res = num bytes downloaded

Will dl the fb forum page to internal string ts.

This:

Code: Select all

#include once "bitmapobject.bi"
dim bmp as bitmapobject ptr = new bitmapobject
'
dim as integer res
dim as string url,ts="fbforum.txt"
url="http://www.freebasic.net/forum/"
'
res=bmp->dlfile(url,ts,1) 'note the mode = 1 value
'
'if res>0 then res = num bytes downloaded

Will dl the fb forum page to disk file "fbforum.txt"

I use dlfile() internally [bitmapobject.bi] to dl internet-based bitmap files to a string buffer, then use GDI+ to read from that string-based stream.

=====

Method:
keepalive()

Eh. Modern Windows versions freak out if you try something like this, compiled "-s gui":

Code: Select all

#include once "bitmapobject.bi"
dim bmp as bitmapobject ptr = new bitmapobject
'
dim as string filename
'
filename="http://freebasic.net/sites/default/files/horse_original_r_0.gif"
bmp->Loadbmp(filename) 'note that this creates a new GFX screen
put (0,0),bmp->Sprite
bmp->ReleaseSprite
'
sleep 2000
'
filename="http://upload.wikimedia.org/wikipedia/commons/thumb/0/00/Crab_Nebula.jpg/600px-Crab_Nebula.jpg"
bmp->Loadbmp(filename) 'this creates another new GFX screen
put (0,0),bmp->Sprite
bmp->ReleaseSprite
'
sleep

The SECOND GFX screen creation will be minimized, left flashing on the Taskbar. This is Windows excellent attempt to keep SPAM programs from keeping themselves in your face (always on top with focus).

keepalive() used like this:

Code: Select all

#include once "bitmapobject.bi"
dim bmp as bitmapobject ptr = new bitmapobject
'
dim as string filename
'
filename="http://freebasic.net/sites/default/files/horse_original_r_0.gif"
bmp->Loadbmp(filename) 'note that this creates a new GFX screen
put (0,0),bmp->Sprite
bmp->ReleaseSprite
'
sleep 2000
'
filename="http://upload.wikimedia.org/wikipedia/commons/thumb/0/00/Crab_Nebula.jpg/600px-Crab_Nebula.jpg"
bmp->Loadbmp(filename) 'this creates another new GFX screen
bmp->keepalive 'and on any subsequent gfx screen creates...
put (0,0),bmp->Sprite
bmp->ReleaseSprite
'
sleep

Will pacify Windows and keep the focus on your new screen(s). If you really want an image slideshow program, then get and use Irfanview - it's WAY better for this.

Done.
Z.

[BasicScience]

Works beautifully. I especially like the arbitrary font load feature.
Thanks.

[Thorham]

Thanks, now I can finally read PNGs in a sane way 8^)

[noop]

Great work, zippy, thanks!

A couple of things I want to mention (concerning the loadFont()-routine):

1) You're using

Code: Select all

layoutRect.Width = 800.0: layoutRect.Height = 200.0

which limits the size of the font-image one can have.
So if anyone needs more text in one line, just increase the appropriate value. [see also 6)]

2) If someone wants to use several lines (Windows will automatically break lines) then just use layoutRect in the GdipDrawString(...) call instead of rcf. layoutRect needs to be fed with the appropriate values of the box you want the text to be in [see also 6)].
Here, layoutRect can also be used to vertically center text by specifying the .y value (you will need the boundRect values to determine the layoutRect.y value) [see 4) for why I personally needed this].

3) In the call to GdipSetStringFormatAlign() one can specify the horizontal alignment,
see http://msdn.microsoft.com/en-us/library ... s.85).aspx for possible values. Move the line

Code: Select all

if pFormat then GdipDeleteStringFormat(pFormat)

to the "cleanupafterfont" section.
Replace the "NULL" in the call of GdipDrawString() with "pFormat":

Code: Select all

hStatus = GdipDrawString(_
            pGraphics,_
            wstr(strTextNew),_
            LEN(strTextNew),_
            pFont,_
            @layoutRect,_
            pFormat,_
            pBlackBrush)

4) If someone needs to call loadFont() many times then the calls become slower and slower.
I'm not entirely sure why but it might be the calls of callocate/deallocate in FBGDI_Create() since
the line

Code: Select all

TSprite = FBGDI_Create(iwidth,iheight)

is the time-culprit.
So if you need many calls to loadFont() you might consider not calling releaseSprite() but
saving the sprite if it's going to be the same size.
I implemented this by saving the height and width of the Sprite in the FBGDI_Image type and then,
instead of calling FBGDI_Create(), I wrote:

Code: Select all

if (TSprite = 0) orElse _
      ((iwidth <> TSprite->width) orElse (iheight <> TSprite->height)) then
   if (TSprite <> 0) then
      this.ReleaseSprite()
   end if
   TSprite = FBGDI_Create(iwidth,iheight)
   TSprite->width = iwidth
   TSprite->height = iheight
end if

Of course this will only fix the issue if the sprite size doesn't change too often.

5) I got "unclean" font output when I used certain colours as a background but used black as the font background (not a problem of the loadFont()-routine).
I fixed this by calling loadFont() with the actual background colour and using "pset" instead of "or"
while putting the image onto the screen.
I'm not sure what to do in the case one has a non solid background colour.

6) Half question, half answer: As far as I can see Windows doesn't tell us if the string we passed didn't fit into the layoutRect we specified and how much got cut off.
What I did to get this info was to specify a larger layoutRect (so that at least one extra line fits in it) and
then loop over GdipMeasureString(). Then boundRect will tell us how much space Windows needed.
As long as boundRect doesn't fit into the box we want the text to be in, reduce the length of the string.
This however seems like an ugly workaround.

[BasicScience]

This is a GREAT tool, especially for custom fonts, but it requires modification (beyond my skill set) to run in 64 bit.

The problem is the namespace gdiplus does not get set up when the ifdef__FB_64bit__ is executed in GdiPlus.bi. Here's the code

Code: Select all

#ifdef __FB_64BIT__

#include "gdiplus-c.bi"

#else

''
''
'' GdiPlus -- header translated with help of SWIG FB wrapper
''
'' NOTICE: This file is part of the FreeBASIC Compiler package and can't
''         be included in other distributions without authorization.
''
''
#ifndef __win_GdiPlus_bi__
#define __win_GdiPlus_bi__

#inclib "gdiplus"

#include once "win/ole2.bi"

namespace Gdiplus

In gdiplus-c.bi, the namespace gdiplus is not established.