Custom Fonts and Window Bitmaps

[Mike Trader]

I have been reading the archive about creating text with a custom font and color and applying a custom background to my MainDialog.

Here is a snippet of what I am using from the SMTP.BAS example in the TCP folder ...

SELECT CASE CBMSG

CASE %WM_INITDIALOG
hFont = MakeFont("Courier New", 10)
CONTROL SEND hDlgMain, 105, %WM_SETFONT,hFont, 1

DIALOG SEND hDlgMain, %WM_GETFONT, 0, 0 TO hFont
GetObject hFont, SIZEOF(lf), BYVAL VARPTR(lf)
lf.lfWeight = %FW_BOLD
hFont = CreateFontIndirect(lf)

CONTROL SET FOCUS hDlgMain, 103

DIALOG GET SIZE CBHNDL TO x, y
DIALOG UNITS CBHNDL, x, y TO PIXELS x, y

' Load the bitmap from a file
GetModuleFilename %NULL, bmpfile, SIZEOF(bmpfile)
bmpfile = UCASE$(bmpfile)
REPLACE ".EXE" WITH ".BMP" IN bmpfile
hBmp = LoadImage(BYVAL %NULL, bmpfile, %IMAGE_BITMAP, x, y, %LR_LOADFROMFILE)
FUNCTION = 1

CASE %WM_CTLCOLOREDIT
SetTextColor CBWPARAM, %BLUE
FUNCTION = GetStockObject(%WHITE_BRUSH)

CASE %WM_CTLCOLORSTATIC
SelectObject CBWPARAM, hFont
SetBkMode CBWPARAM, %TRANSPARENT
SetTextColor CBWPARAM, %YELLOW
FUNCTION = GetStockObject(%NULL_BRUSH)

CASE %WM_ERASEBKGND
hBmpDC = CreateCompatibleDC(CBWPARAM)
SelectObject hBmpDC, hBmp
BitBlt CBWPARAM, 0, 0, x, y, hBmpDC, 0, 0, %SRCCOPY
DeleteDC hBmpDC
FUNCTION = 1

END SELECT

This works great.
The problem is that I send text to the window MANY times with:
CONTROL SET TEXT hDlg, 104, MyString

Each time I send the text it IS displayed but ON TOP of whats allready there. How do i delete whats allredy there just befor i display the new text.

Thanks


------------------
Kind Regards
Mike

[Borje Hagsten]

You could use FillRect, but easier is to change
SetBkMode CBWPARAM, %TRANSPARENT
to
SetBkMode CBWPARAM, %OPAQUE

(or skip that line at all, since I think OPAQUE is default mode)

You may have to set SetBkColor too, for proper background color.
If text is of different lengths, add/insert enough spaces to
overwrite previous text.


------------------

[Jules Marchildon]

Mike;

From Borje's Code drawer...

'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
' Rotate text in any angle (degr%) - x and y are Left and Top position of text
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
SUB RotateText(BYVAL hWnd&, BYVAL degr%, BYVAL Txt$, BYVAL x&, BYVAL y&)
 
  LOCAL lFont AS LOGFONT, rc AS RECT
  LOCAL hDc AS LONG, hfont AS LONG, newfont AS LONG
  IF degr% = 0 THEN degr% = 360
 
  lFont.lfescapement  = degr% * 10                         '<- Set Angle
  lFont.lforientation = degr% * 10
  lFont.lfHeight = -18                                     '<- Font Size
  lFont.lfWeight = %FW_BOLD                                '<- Bold
  lFont.lfItalic = %FALSE
  lFont.lfCharSet = %ANSI_CHARSET
  lFont.lfOutPrecision = %OUT_TT_PRECIS
  lFont.lfClipPrecision =%CLIP_DEFAULT_PRECIS
  lFont.lfQuality = %DEFAULT_QUALITY
  lFont.lfPitchAndFamily = %FF_DONTCARE
  lFont.lfFaceName = "Times New Roman"
 
 'create font and assign handle to a variable
  hFont = CreateFontIndirect(BYVAL VARPTR(lFont))
 
  hDC = getDc(hWnd&)
    newfont = selectobject(hDC, hfont)
 
    GetClientRect hWnd&, rc : rc.nBottom = rc.nBottom - 40
    FillRect hDC, rc, GetStockObject(%LTGRAY_BRUSH)        '<- Erase background
 
    SetBkColor   hDC, RGB(192, 192, 192)
    SetTextColor hDC, RGB(128,   0, 128)
 
    TextOut hDC, x&, y&, BYVAL STRPTR(Txt$), LEN(Txt$)     '<- Print text
 
  ReleaseDC hWnd&, hDC
  deleteobject hfont
END SUB

You will need to clean the ID=104 control up first before you put new
text on it, so Borje FillRect() suggestion would be the one to use. You
can get the Idea from his code snippet above.

HTH
Regards,
Jules

[Mike Trader]

Thx for your replys.
I have spent alot of time reading and experimenting and getting nowhere. I tried your suggestions, but I get a white hole punched in the background (Smtp.BMP) and grey text on the white.

SO, i have rewritten the code as simply as i can from Smtp.bas to illustrate the problem.

You need to put the file in the same folder as the Smtp.BMP so that the program can find it. It compiles and runs to illustrate the problem.

Can someone take a look and suggest a way to fix it pls

'==============================================================================
' Rewritten SMTP example for PB/DLL 6.0 - to illustrate color font on background problem
' Copyright (c) 1999 PowerBASIC, Inc.
'==============================================================================
#COMPILE EXE "Smtp.exe"
#INCLUDE "WIN32API.INC"
GLOBAL hDlgMain AS LONG
'------------------------------------------------------------------------------
FUNCTION MakeFont(BYVAL Font AS STRING, BYVAL PointSize AS LONG) AS LONG
LOCAL hDC AS LONG
LOCAL CyPixels AS LONG
hDC = GetDC(%HWND_DESKTOP)
CyPixels = GetDeviceCaps(hDC, %LOGPIXELSY)
ReleaseDC %HWND_DESKTOP, hDC
PointSize = (PointSize * CyPixels) \ 72
FUNCTION = CreateFont(0 - PointSize, 0, 0, 0, %FW_NORMAL, 0, 0, 0, _
%ANSI_CHARSET, %OUT_TT_PRECIS, %CLIP_DEFAULT_PRECIS, _
%DEFAULT_QUALITY, %FF_DONTCARE, BYCOPY Font)
END FUNCTION
'------------------------------------------------------------------------------
CALLBACK FUNCTION DlgProc () AS LONG
STATIC hFont AS LONG
STATIC hBmp AS LONG
STATIC x AS LONG
STATIC y AS LONG
LOCAL hBmpDC AS LONG
LOCAL e AS LONG
LOCAL lf AS LOGFONT
LOCAL bmpfile AS ASCIIZ * 64

SELECT CASE CBMSG
CASE %WM_INITDIALOG
hFont = MakeFont("Courier New", 10)
CONTROL SEND hDlgMain, 105, %WM_SETFONT,hFont, 1

DIALOG SEND hDlgMain, %WM_GETFONT, 0, 0 TO hFont
GetObject hFont, SIZEOF(lf), BYVAL VARPTR(lf)
lf.lfWeight = %FW_BOLD
hFont = CreateFontIndirect(lf)

CONTROL SET FOCUS hDlgMain, 103
DIALOG GET SIZE CBHNDL TO x, y
DIALOG UNITS CBHNDL, x, y TO PIXELS x, y

' Load the bitmap from a file
GetModuleFilename %NULL, bmpfile, SIZEOF(bmpfile)
bmpfile = UCASE$(bmpfile)
REPLACE ".EXE" WITH ".BMP" IN bmpfile
' MSGBOX(bmpfile)
hBmp = LoadImage(BYVAL %NULL, bmpfile, %IMAGE_BITMAP, x, y, %LR_LOADFROMFILE)
FUNCTION = 1

CASE %WM_CTLCOLOREDIT
SetTextColor CBWPARAM, %BLUE
FUNCTION = GetStockObject(%WHITE_BRUSH)

CASE %WM_CTLCOLORSTATIC
SelectObject CBWPARAM, hFont
SetBkMode CBWPARAM, %TRANSPARENT
SetTextColor CBWPARAM, %YELLOW
FUNCTION = GetStockObject(%NULL_BRUSH)

CASE %WM_ERASEBKGND
hBmpDC = CreateCompatibleDC(CBWPARAM)
SelectObject hBmpDC, hBmp
BitBlt CBWPARAM, 0, 0, x, y, hBmpDC, 0, 0, %SRCCOPY
DeleteDC hBmpDC
FUNCTION = 1
END SELECT
END FUNCTION
'------------------------------------------------------------------------------
CALLBACK FUNCTION CancelButton() AS LONG
DIALOG END hDlgMain, 1
END FUNCTION
'------------------------------------------------------------------------------
CALLBACK FUNCTION OkButton() AS LONG ' to illustrate the text problem
LOCAL AllStr AS STRING, SendStr AS STRING
AllStr = "PowerBASIC offers three distinct ways TO store AND retrieve information FROM disk" _
+"sequential, RANDOM, AND BINARY file INPUT AND OUTPUT (I/O). Each has advantages"
SendStr = " " + MID$(AllStr,RND(1,(LEN(allStr)-14)),RND(10,150))
CONTROL SET TEXT hDlgMain, 2, SendStr
FUNCTION = 1
END FUNCTION
'------------------------------------------------------------------------------
FUNCTION PBMAIN () AS LONG
DIALOG NEW 0, "Color Example", ,, 300, 100, 0, %WS_SYSMENU TO hDlgMain
CONTROL ADD LABEL, hDlgMain, 2, "Please rewrite DlgProc", 20, 30, 250, 8,
CONTROL ADD BUTTON, hDlgMain, 101, "& Show Me Da Problem", 100, 80, 80, 14, %BS_DEFPUSHBUTTON OR %WS_TABSTOP CALL OkButton
CONTROL ADD BUTTON, hDlgMain, 102, "&Quit", 200, 80, 40, 14, 0 CALL CancelButton
DIALOG SHOW MODAL hDlgMain CALL DlgProc
END FUNCTION
'-----------------------------------------------------------------------------



------------------
Kind Regards
Mike

[Timm Motl]

Originally posted by Mike Trader:
Can someone take a look and suggest a way to fix it pls

Mike:

In the CALLBACK FUNCTION for your OKButton, replace the following line...

   CONTROL SET TEXT hDlgMain, 2, SendStr

With these three lines...

   CONTROL SET TEXT hDlgMain, 2, ""
   InvalidateRgn hDlgMain, %NULL, %TRUE
   CONTROL SET TEXT hDlgMain, 2, SendStr

That should give you what you've been looking for.

Timm

[Mike Trader]

Arrgh. I hate when its that simple! I feel so dumb.
thx so much

------------------
Kind Regards
Mike