'=========================================================================== ' Subject: PRINT TEXT FILE FOR PBDLL Date: 11-11-99 (18:51) ' Author: Fred Buffington Code: PBDLL ' Origin: oasys@telepath.com Packet: PBDLL.ABC '=========================================================================== #COMPILE EXE #INCLUDE "win32api.inc" #INCLUDE "comdlg32.inc" DECLARE CALLBACK FUNCTION winProc() DECLARE FUNCTION EzCreateFont& (BYVAL h&, fn AS ASCIIZ, ih&, iw&, ia&, f&) DECLARE FUNCTION getPrinterDC&() DECLARE SUB displayFont(ht&) DECLARE SUB printFont(ht&) GLOBAL hWin&, hFont&, hBrush&, bkColor& GLOBAL fi$ FUNCTION PBMAIN()AS LONG fi$=COMMAND$ IF fi$="" THEN MSGBOX "You must specify a file ",,"Print Report" EXIT FUNCTION END IF ' fi$="demo\report.txt" DIALOG NEW 0,"Print File "+fi$,,,235,100,%WS_SYSMENU TO hWin& 'CONTROL ADD BUTTON, hWin&, 101, "Display Small",10,10,50,20 'CONTROL ADD BUTTON, hWin&, 102, "Display Big",70,10,50,20 CONTROL ADD BUTTON, hWin&, 103, "Print Small simulate 17CPI",10,20,100,20 CONTROL ADD BUTTON, hWin&, 104, "Print Normal simulate 10CPI",120,20,100,20 'CONTROL ADD LINE, hWin&,105,fi$,80,5,100,14 DIALOG SHOW MODAL hWin& CALL winProc END FUNCTION CALLBACK FUNCTION winProc() SELECT CASE CBMSG CASE %WM_INITDIALOG bkColor=RGB(20,20,155) '(200,200,255) CASE %WM_CTLCOLORDLG hBrush=CreateSolidBrush(bkColor) FUNCTION=hBrush CASE %WM_COMMAND IF CBCTLMSG=%BN_CLICKED THEN displayFont 0 IF CBCTL=101 OR CBCTL=103 THEN displayFont 72'90 IF CBCTL=102 OR CBCTL=104 THEN displayFont 120'180 IF CBCTL=103 THEN printFont 120'72'80 '90 'IF CBCTL=104 THEN printFont 180 IF CBCTL=104 THEN printFont 140'120'140 END IF END SELECT END FUNCTION SUB displayFont(ht AS LONG) LOCAL hdc AS LONG LOCAL hOrigFont AS LONG, n AS LONG LOCAL t AS ASCIIZ * 21 IF ht THEN t="Sample Font" n=11 ELSE t=SPACE$(20) ht=180: n=20 END IF hdc=GetDc(hWin) hFont=EzCreateFont&(hdc,"Times New Roman",ht,0,0,%TRUE) 'hfont=getstockobject(%system_fixed_font) hOrigFont = SelectObject (hdc, hFont) SetTextColor hdc,RGB(200,0,0) SetBkColor hdc, bkColor TextOut hdc, 10, 70, t, n DeleteObject SelectObject(hdc, hOrigFont) ReleaseDC hWin, hdc END SUB SUB printFont(ht AS LONG) LOCAL hPrnDC AS LONG, hOrigFont AS LONG, hdc AS LONG LOCAL flags AS LONG, nCopies AS LONG, nFromPage AS LONG, nToPage AS LONG LOCAL nMinPage AS LONG, nMaxPage AS LONG LOCAL nError AS BYTE LOCAL di AS DOCINFO LOCAL txt1 AS ASCIIZ * 133 LOCAL txt AS ASCIIZ * 81 LOCAL lpSize AS SIZEL txt="Sample Font" flags = %PD_RETURNDC IF PrinterDialog(hWin,flags,hPrnDC,nCopies,nFromPage,nToPage,nMinPage,nMaxPage) THEN ' hFont=EzCreateFont&(hPrnDC,"Courier New",ht,0,0,%FALSE) ' hFont=EzCreateFont&(hPrnDC,"System",ht,0,0,%FALSE) hFont=EzCreateFont&(hPrnDC,"Terminal",ht,0,0,%FALSE) hOrigFont = SelectObject (hPrnDC, hFont) GetTextExtentPoint32 hPrnDC, txt, 11, lpSize IF StartDoc(hPrnDC, di) > 0 THEN IF StartPage(hPrnDC) > 0 THEN hOrigFont = SelectObject(hPrnDC, hFont) 'TextOut hPrnDC, 20, 100, txt, LEN(txt) OPEN fi$ FOR INPUT AS #9 y%=10 IF ht=120 THEN llen%=132 ELSE llen%=80 IF LOF(9)<>0 THEN DO LINE INPUT #9,ll$ l%=INSTR(ll$,CHR$(12)) IF l%<>0 AND l%>1 THEN llx$=CHR$(12) ll$=MID$(ll$,1,l%-1) END IF IF ll$=CHR$(12) OR plines%=63 THEN EndPage hPrnDC plines%=0 ll$=SPACE$(llen%) IF EOF(9) THEN EndDoc hPrnDc EXIT DO ELSE startpage hPrnDC hFont=EzCreateFont&(hPrnDC,"Courier New",ht,0,0,%FALSE) hOrigFont = SelectObject (hPrnDC, hFont) GetTextExtentPoint32 hPrnDC, txt, 11, lpSize y%=10 END IF END IF IF LEN(ll$)<>llen% THEN ll$=MID$(ll$+SPACE$(llen%),1,llen%) IF ht=120 THEN txt1=ll$ TextOut hPrnDC, 10, y%, txt1, LEN(txt1) ELSE txt=ll$ TextOut hPrnDC, 10, y%, txt, LEN(txt) END IF y%=y%+30:plines%=plines%+1 IF llx$=CHR$(12) THEN EndPage hPrnDC plines%=0 ll$=SPACE$(llen%) IF EOF(9) THEN EndDoc hPrnDc EXIT DO ELSE startpage hPrnDC hFont=EzCreateFont&(hPrnDC,"Courier New",ht,0,0,%FALSE) hOrigFont = SelectObject (hPrnDC, hFont) GetTextExtentPoint32 hPrnDC, txt, 11, lpSize y%=10 END IF END IF llx$="" LOOP WHILE NOT EOF(9) CLOSE #9 IF EndPage(hPrnDC) > 0 THEN EndDoc hPrnDC ELSE ' nError=1 END IF END IF END IF ELSE nError=1 END IF IF nError THEN MSGBOX "Printing error", %MB_ICONERROR, "" DeleteObject SelectObject(hPrnDC, hOrigFont) DeleteDC hPrnDC END IF END SUB FUNCTION assign& (cond&,value1&,value2&) IF cond& THEN FUNCTION = value1& ELSE FUNCTION = value2& END FUNCTION FUNCTION EzCreateFont& (BYVAL hdc&, fontName AS ASCIIZ,_ ideciPtHeight&, ideciPtWidth&, iAttributes&, fLogRes&) %EZ_ATTR_BOLD = 1 %EZ_ATTR_ITALIC = 2 %EZ_ATTR_UNDERLINE = 4 %EZ_ATTR_STRIKEOUT = 8 LOCAL cxDpi AS DOUBLE,_ cyDpi AS DOUBLE,_ hFont AS LONG,_ lf AS logFont,_ pt AS pointapi,_ tm AS textmetric CALL saveDC(BYVAL hdc&) CALL SetViewPortOrgEx(BYVAL hdc&, 0, 0, BYVAL %NULL) CALL SetWindowOrgEx(BYVAL hdc&, 0, 0, BYVAL %NULL) IF fLogRes& THEN cxDpi=GetDeviceCaps(BYVAL hdc&, %LOGPIXELSX) cyDpi=GetDeviceCaps(BYVAL hdc&, %LOGPIXELSY) ELSE cxDpi=25.4*GetDeviceCaps(BYVAL hdc&, %HORZRES)/getDeviceCaps(BYVAL hdc&,%HORZSIZE) cyDpi=25.4*GetDeviceCaps(BYVAL hdc&, %VERTRES)/getDeviceCaps(BYVAL hdc&,%VERTSIZE) END IF pt.x=iDeciPtWidth&*cxDpi\72 pt.y=iDeciPtHeight&*cyDpi\72 DPtoLP BYVAL hdc&, pt, 1 'msgbox str$(pt.x),,"point.x" 'assign to lf structure lf.lfHeight = -(ABS(pt.y)/10 + 0.5) 'changed with to 18 (from 0 and weight to 600 'for a darker print IF ideciPtHeight&=120 THEN ' msgbox "height is 72 ",,"height" lf.lfWidth = 10 ELSE lf.lfWidth = 16' END IF lf.lfEscapement = 0 lf.lfOrientation = 0 IF ideciPtHeight&<>120 THEN lf.lfWeight = 100'600'assign(iAttributes& AND %EZ_ATTR_BOLD, 700, 0) ELSE lf.lfWeight = 0'400 END IF lf.lfItalic = assign(iAttributes& AND %EZ_ATTR_ITALIC, 1, 0) lf.lfUnderline = assign(iAttributes& AND %EZ_ATTR_UNDERLINE, 1, 0) lf.lfStrikeOut = assign(iAttributes& AND %EZ_ATTR_STRIKEOUT, 1, 0) 'lf.lfCharSet = 0 lf.lfCharSet =%SYSTEM_FIXED_FONT''%DEFAULT_CHARSET''%OEM_FIXED_FONT''%DEFAULT_CHARSET '%OEM_CHARSET ' lf.lfCharSet =%ANSI_FIXED_FONT''%DEFAULT_CHARSET''%OEM_FIXED_FONT''%DEFAULT_CHARSET '%OEM_CHARSET 'hfont = GetStockObject(%OEM_FIXED_FONT) lf.lfOutPrecision = 0 lf.lfClipPrecision = 0 lf.lfQuality = 0 lf.lfPitchAndFamily = 0 lf.lfFaceName=fontName 'create the font hFont=CreateFontIndirect(lf) 'change the font width if specified 'if ideciPtHeight&=72 then ideciPtHeight&=80 IF (iDeciPtWidth& <> 0) THEN hFont=SelectObject(BYVAL hdc&, BYVAL hFont) 'select new font, save old one as hFont CALL getTextMetrics(BYVAL hdc&,tm) deleteObject SelectObject(BYVAL hdc&, BYVAL hFont) 'reselect old font, delete new one lf.lfWidth=tm.tmAveCharWidth*ABS(pt.x)/ABS(pt.y) + 0.5 hFont=CreateFontIndirect(lf) END IF RestoreDC hdc&, -1 FUNCTION=hFont END FUNCTION 'IP: Logged ' 'Lance Edmonds 'Administrator posted September 25, 1999 10:38 PM '-------------------------------------------------------------------------------- 'The problem is straight forward, but difficult to 'detect... the font change you set is lost during 'the StartPage() API call (per the SDK doc's). 'The correct way to set the font is to call SelectObject() after [each] StartPage(). 'ie, ' IF StartDoc(hPrnDC, di) > 0 THEN ' IF StartPage(hPrnDC) > 0 THEN ' hOrigFont = SelectObject(hPrnDC, hFont) ' TextOut hPrnDC, 20, 100, txt, LEN(txt) ' IF EndPage(hPrnDC) > 0 THEN ' EndDoc hPrnDC ' ELSE ' nError=1 ' END IF ' END IF ' ELSE ' nError=1 ' END IF 'You'll find that will make quite a difference to the application