sendmessage <window handle>, %WM_SETFONT, <fonthandle>, 0
Tweet
#Dim All
#Include "WIN32API.INC"
#Include "RICHEDIT.INC"
'------------------/
%RE_TEST = 101
%BTN_Test = 102
%BTN_Test2 = 103
%BTN_Test3 = 104
'------------------/
Sub SetRfColor(ByVal hEdit As Dword, ByVal fontcolor As Long) 'TT Borje
Local cf As CHARFORMAT
cf.cbsize = Len(cf)
cf.dwmask = %cfm_color
cf.crtextcolor = fontcolor
SendMessage(hEdit, %em_setcharformat, %scf_word Or %scf_selection, VarPtr(cf))
End Sub
'------------------/SetRfColor
Function MakeFont(ByVal FFont 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 FFont)
End Function
'------------------/MakeFont
Sub Control_Set_Font(ByVal hControl As Dword) ' DDT lacks "Control Set Font"
Local hLogFont As Dword
hLogFont = MakeFont("Courier New Bold",12)
'hLogFont = GetStockObject(%SYSTEM_FIXED_FONT)
'hLogFont = MakeFont("System_Fixed_Font Bold",9)
SendMessage (hControl, %WM_SETFONT, hLogFont, 0)
DeleteObject hLogFont
End Sub
'------------------/Control_Set_Font
CallBack Function DlgProc()
Select Case As Long CbMsg
Case %WM_COMMAND
Select Case As Long CbCtl
Case %BTN_Test ' fill label manuallly - could use %EM_STREAMIN here
If CbCtlMsg = %BN_CLICKED Then
Local RE_Header, RE_Text As String
RE_Header = _ ' RT header starts with {
"{"+ _ ' <- Opening brace **
"\rtf1\ansi\ansicpg1252\deff0\deflang1033"+ _ ' Version and Char set
"{\fonttbl"+ _ ' Font table
"{\f0\fswiss\fprq2\fcharset0 Microsoft Sans Serif;}"+ _ ' \f0 = default/initial font
"{\f1\fswiss\fprq2\fcharset0 Arial;}"+ _
"{\f2\fnil\fprq2\fcharset2 Wingdings;}}"+ _
"{\colortbl"+ _ ' Colour table
"\red0\green0\blue0;"+ _ ' black \cf0
"\red255\green0\blue0;"+ _ ' red \cf1
"\red0\green0\blue255;}" ' blue \cf2
RE_Text = _ ' marked up text
"\fs18 "+ _ ' fs18 = use 9 point text
"You \i \b could \b0 \i0 use WM_SETFONT to set the font for a richedit control. \line "+ _
"\b Or even 'CONTROL_SET_FONT'. \b0 "+ _ ' \b BOLD \b0
"\fs22 \f2 J "+ _ ' \f2 font: "Wingdings" J = :)
"\fs18 \f0 \line "+ _ ' \f0 font: "MS Sans Serif"
"You can set the font at design time (easily when using PBForms!), \line "+ _
"but if you want to have varied fonts \i within \i0 the control, "+ _
"you \b can \b0 with a richedit control - by using other methods. \line \line "+ _
"\fs22 \f1 "+ _ ' \f1 font: "Arial"
"Of course a richedit control can have not only different "+ _
"fonts but \cf1 colours \cf0 \cf2 too \cf0! "+ _
"\fs24 \f2 J \Line \Line"+ _ ' \f2 font: "Wingdings" J = :)
"\fs18 \f0"+ _ ' \f0 font: "MS Sans Serif"
"In this sample, the initial text of the RE control is replaced at run time \line "+ _
"with text that was prepared with markup codes at design time. \Line \line "+ _"
"At runtime text is (usually) changed using EM_STREAMIN with alternative \line "+ _"
"strings written into the source code or loaded from an external file. \Line "+ _
"EM_SETCHARFORMAT can also be used to change formats. \line "+ _
" - Select some text and click Sel2Red for example."+ _
"}" ' <- Closing brace **
RE_Text = RE_Header + RE_Text ' Add RT Header to marked up text
Control Set Text CbHndl, %RE_TEST, RE_Text ' RichEdit SET TEXT
Control Add Button, CbHndl, %BTN_Test3, "Sel2Red", 150, 100, 50, 15,
Dialog ReDraw CbHndl ' Paint scroll bar properly
End If
Case %BTN_Test2
If CbCtlMsg = %BN_CLICKED Then
CONTROL_SET_FONT (GetDlgItem(CbHndl, %RE_Test))
End If
Case %BTN_Test3
If CbCtlMsg = %BN_CLICKED Then
Local szSel As Asciiz * 256
Local LenSel As Long
szSel = Space$(255) & Chr$(0) ' Prepare buffer for selected text
LenSel = SendMessage( GetDlgItem(CbHndl, %RE_Test),%EM_GETSELTEXT, 0, ByVal VarPtr(szSel))
If LenSel < 1 Then Exit Function
SetRfColor (GetDlgItem(CbHndl, %RE_Test), %Red)
End If
Case %RE_Test
If CbCtlMsg = %EN_SETFOCUS Then
Control Send CbHndl, %RE_Test, %EM_SETSEL, -1, 0 ' Prevent highlight on entry
End If
End Select
End Select
End Function
'------------------/DlgProc
Function PBMain()
Local hDlg As Dword
Local sInitialText As String
LoadLibrary "RICHED32.DLL"
sInitialText = "RE control pre-loaded with this text when created"
Dialog New 0, "RichEdit fonts etc", 100, 100, 300, 120, %WS_CAPTION Or %WS_SYSMENU, To hDlg
Control Add Button, hDlg, %BTN_Test, "New Text", 85, 100, 50, 15
Control Add Button, hDlg, %BTN_Test2, "WM_SETFONT", 15, 100, 55, 15,
Control Add "RichEdit", hDlg, %RE_Test, sInitialText, 10, 5, 280, 90, %WS_CHILD Or %WS_VISIBLE _
Or %ES_MULTILINE Or %WS_VSCROLL Or %ES_AUTOVSCROLL Or %WS_TABSTOP
Control Send hDlg, %RE_Test, %EM_SETBKGNDCOLOR, 0, GetSysColor(%COLOR_BTNFACE) ' Adjust appearance
Dialog Show Modal hDlg, Call DlgProc
End Function
'------------------/PbMain
'TXT2WNDW.BAS
'compiled with pbwin 8.04
'program reads a file then displays the contents in a window
#COMPILE EXE
#REGISTER NONE
#DIM ALL
#INCLUDE "Win32Api.Inc"
#INCLUDE "COMDLG32.INC" ' Common dialog declares
#INCLUDE "PREVIEW.INC" ' Preview dialog include from tutorials in the samples directory
%IDC_BUTNOPEN = 120 ' Control id's
%IDC_BUTNVIEW = 121
%IDC_BUTNPAGE = 122
%IDC_BUTNFONT = 123
%IDC_BUTNFONT1 = 124
%IDC_BUTNFONT2 = 125
%IDC_BUTNFONT3 = 126
%ListBox = 201
GLOBAL datainthefile() AS STRING
GLOBAL largestwidthline AS LONG
GLOBAL gifontsize AS DWORD
GLOBAL gibuttonfontsize AS DWORD
GLOBAL gstext AS STRING
GLOBAL gstextundo() AS STRING
GLOBAL hFont,hbuttonfont AS DWORD
GLOBAL FONTSIZE AS LONG
GLOBAL gifontbold AS LONG
'FUNCTION DECLARATIONS---------------------------------------------------------------
DECLARE FUNCTION findwidestpart(BYVAL a AS STRING) AS LONG
DECLARE FUNCTION GetFile (BYVAL sFile AS STRING) AS STRING
DECLARE FUNCTION MakeFontEx (BYVAL FontName AS STRING, _
BYVAL PointSize AS LONG, _
BYVAL fBold AS LONG, _
BYVAL fItalic AS LONG, _
BYVAL fUnderline AS LONG) AS DWORD
DECLARE FUNCTION SelectFontProc (BYVAL hDlg AS DWORD, _
BYVAL id AS LONG, _
hFont AS DWORD, _
pd AS PreviewData) AS LONG
'----------------------------------------------------------------------------------------
'====================================================================
FUNCTION GetFile (BYVAL sFile AS STRING) AS STRING
'--------------------------------------------------------------------
' Open and return given file's contents as a string
'--------------------------------------------------------------------
LOCAL ff AS LONG
LOCAL sBuf AS STRING
IF LEN(DIR$(sFile)) = 0 THEN
MSGBOX "The file does not exist.", %MB_TASKMODAL, "Error"
EXIT FUNCTION
END IF
ff = FREEFILE
OPEN sFile FOR BINARY ACCESS READ LOCK SHARED AS ff LEN = 8192
IF ERR THEN ' Always trap ev. errors on file open actions
MSGBOX ERROR$(ERR), %MB_TASKMODAL, "Error"
RESET : ERRCLEAR : EXIT FUNCTION
END IF
GET$ ff, LOF(ff), sBuf
CLOSE ff
FUNCTION = sBuf
END FUNCTION
FUNCTION linesinthefile(file AS STRING) AS LONG
LOCAL filename AS STRING
LOCAL filecount AS LONG
LOCAL linecount AS LONG
LOCAL hfile1 AS INTEGER
LOCAL I AS LONG
LOCAL junk AS STRING
filecount=0&
linecount=-1&
FileName = DIR$(file, 7) '%System OR %ReadOnly OR %Hidden )
DO
IF LEN(FileName) THEN
IF (GETATTR(FileName) AND %SUBDIR) THEN 'It's a subfolder
EXIT FUNCTION
ELSE
linecount=0&
END IF
INCR FILECOUNT
FileName = DIR$ 'Get next file or folder
END IF
LOOP WHILE LEN(Filename) 'Loop if something found
DIR$ CLOSE
hfile1=FREEFILE
IF filecount=1& THEN
OPEN file FOR INPUT ACCESS READ LOCK SHARED AS hfile1
WHILE ISFALSE EOF(1)
LINE INPUT #1, junk
IF LEN(junk)>largestwidthline THEN largestwidthline=LEN(junk)
INCR linecount
IF linecount MOD 10000& =0& THEN SLEEP 10
WEND
CLOSE #1
' FILESCAN #hfile1, RECORDS TO linecount, WIDTH TO largestwidthline
' REDIM Datainthefile(0 TO linecount) 'global as string
'
' LINE INPUT #1, datainthefile() TO linecount
IF linecount&>0& THEN
OPEN file FOR INPUT ACCESS READ LOCK SHARED AS hfile1
REDIM datainthefile(0 TO (LINECOUNT-1&))
FOR i=0& TO linecount
LINE INPUT #1, datainthefile(i)
IF i MOD 10000& =0&THEN SLEEP 10
NEXT i
CLOSE #1
END IF
END IF
FUNCTION=linecount
END FUNCTION
'====================================================================
FUNCTION MakeFontEx (BYVAL FontName AS STRING, _
BYVAL PointSize AS LONG, _
BYVAL fBold AS LONG, _
BYVAL fItalic AS LONG, _
BYVAL fUnderline AS LONG) AS DWORD
'--------------------------------------------------------------------
' Create a desired font and return its handle.
'--------------------------------------------------------------------
LOCAL hDC AS DWORD, CharSet AS LONG, CyPixels AS LONG
IF gifontbold THEN fbold=700 ELSE fbold=400
hDC = GetDC(%HWND_DESKTOP)
CyPixels = GetDeviceCaps(hDC, %LOGPIXELSY)
EnumFontFamilies hDC, BYVAL STRPTR(FontName), CODEPTR(EnumCharSet), BYVAL VARPTR(CharSet)
ReleaseDC %HWND_DESKTOP, hDC
PointSize = 0 - (PointSize * CyPixels) \ 72
FUNCTION = CreateFont(PointSize, 0, _ 'height, width(default=0)
0, 0, _ 'escapement(angle), orientation
fBold, _ 'weight (%FW_DONTCARE = 0, %FW_NORMAL = 400, %FW_BOLD = 700)
fItalic, _ 'Italic
fUnderline, _ 'Underline
%FALSE, _ 'StrikeThru
CharSet, %OUT_TT_PRECIS, _
%CLIP_DEFAULT_PRECIS, %DEFAULT_QUALITY, _
%FF_DONTCARE , BYCOPY FontName)
END FUNCTION
'====================================================================
FUNCTION EnumCharSet (elf AS ENUMLOGFONT, ntm AS NEWTEXTMETRIC, _
BYVAL FontType AS LONG, CharSet AS LONG) AS LONG
'--------------------------------------------------------------------
' Get type of character set - ansi, symbol, etc. A must for some fonts..
' Called from FUNCTION MakeFontEx.
'--------------------------------------------------------------------
CharSet = elf.elfLogFont.lfCharSet
END FUNCTION
'====================================================================
FUNCTION SelectFontProc (BYVAL hDlg AS DWORD, _
BYVAL id AS LONG, _
hFont AS DWORD, _
pd AS PreviewData) AS LONG
'--------------------------------------------------------------------
' Use COMDLG32's Font dialog for font settings
'--------------------------------------------------------------------
LOCAL cf AS CHOOSEFONTAPI, lf AS LOGFONT
IF hFont THEN GetObject hFont, SIZEOF(lf), lf
cf.lStructSize = SIZEOF(CHOOSEFONTAPI)
cf.hwndOwner = hDlg
cf.lpLogFont = VARPTR(lf)
cf.Flags = %CF_BOTH OR %CF_FORCEFONTEXIST OR %CF_INITTOLOGFONTSTRUCT
cf.nFontType = %SCREEN_FONTTYPE
IF ChooseFont(cf) THEN
pd.FontName = lf.lfFaceName
pd.FontSize = cf.iPointSize / 10
pd.FontType = IIF&(lf.lfWeight < 500, 0, 1)
IF lf.lfItalic THEN pd.FontType = pd.FontType OR 2
IF lf.lfUnderline THEN pd.FontType = pd.FontType OR 4
IF hFont THEN DeleteObject hFont
hFont = MakeFontEx (pd.FontName, pd.FontSize, _
lf.lfWeight, lf.lfItalic, lf.lfUnderline)
FUNCTION = %TRUE
END IF
END FUNCTION
'______________________________________________________________________________
CALLBACK FUNCTION DlgProc
LOCAL h, w, x, y AS LONG
LOCAL i AS LONG
SELECT CASE AS LONG CBMSG
CASE %WM_INITDIALOG ' <- Received right before the dialog is shown
'------------------------------------------------------------------
' The main program is responsible for maintaining a Static or Global
' PreviewData variable and calling InitPreviewDlg before the Print
' Preview dialog in Preview.inc is used.
'------------------------------------------------------------------
STATIC pd AS PreviewData ' <- Defined in Preview.inc
InitPreviewDlg pd ' <- Located in Preview.inc
'------------------------------------------------------------------
' Create and set an initial fixed-width font in the TextBox.
'------------------------------------------------------------------
' msgbox "start"
' gstext=""
' FOR i=lbound(datainthefile) to ubound(datainthefile)
' gstext=gstext+Datainthefile(I)+$crlf
' NEXT I
' msgbox "end"
IF LEN(gsText) THEN CONTROL SET TEXT CBHNDL, %listbox , gsText
IF hFont THEN DeleteObject hFont
hFont = MakeFontEx("Courier New", gifontsize, 0, 0, 0)
IF hFont THEN CONTROL SEND CBHNDL, %Listbox, %WM_SETFONT, hFont, 1
CASE %WM_DESTROY ' <- Received right before the dialog is destroyed
IF hFont THEN DeleteObject hFont
CASE %WM_COMMAND
'----------------------------------------------------
' Messages from the controls are handled here.
' Example: Button clicks generates a %BN_CLICKED message
' and menu clicks generates the value 1.
'----------------------------------------------------
SELECT CASE AS LONG CBCTL
' CASE %IDC_BUTNOPEN ' "Open" button was clicked
' IF CBCTLMSG = %BN_CLICKED OR CBCTLMSG = 1 THEN
' sText = OpenFileProc(CBHNDL)
' IF LEN(sText) THEN
' CONTROL SET TEXT CBHNDL, %IDC_TEXTBOX1, sText
' END IF
' END IF
'
' CASE %IDC_BUTNVIEW ' "Preview" button was clicked
' IF CBCTLMSG = %BN_CLICKED OR CBCTLMSG = 1 THEN
' ' Grab TextBox contents, dialog title and show Print Preview
' CONTROL GET TEXT CBHNDL, %IDC_TEXTBOX1 TO sText
' DIALOG GET TEXT CBHNDL TO sTitle
' DlgPreview CBHNDL, sTitle, sText, pd
' END IF
' CASE %IDC_BUTNPAGE
' IF CBCTLMSG = %BN_CLICKED OR CBCTLMSG = 1 THEN
' PageSetupDlgProc CBHNDL, pd
' END IF
'
CASE %IDC_BUTNFONT
IF CBCTLMSG = %BN_CLICKED OR CBCTLMSG = 1 THEN
IF SelectFontProc (CBHNDL, %listbox, hFont, pd) THEN
CONTROL SEND CBHNDL, %listbox, %WM_SETFONT, hFont, 1
END IF
END IF
CASE %IDC_BUTNFONT1
IF CBCTLMSG = %BN_CLICKED OR CBCTLMSG = 1 THEN
IF gifontsize>5 THEN gifontsize=gifontsize-1
IF hFont THEN DeleteObject hFont
hFont = MakeFontEx("Courier New", gifontsize, 0, 0, 0)
IF hFont THEN CONTROL SEND CBHNDL, %Listbox, %WM_SETFONT, hFont, 1
END IF
CASE %IDC_BUTNFONT2
IF CBCTLMSG = %BN_CLICKED OR CBCTLMSG = 1 THEN
IF gifontsize<72 THEN gifontsize=gifontsize+1
IF hFont THEN DeleteObject hFont
hFont = MakeFontEx("Courier New", gifontsize, 0, 0, 0)
IF hFont THEN CONTROL SEND CBHNDL, %Listbox, %WM_SETFONT, hFont, 1
END IF
CASE %IDC_BUTNFONT3
IF CBCTLMSG = %BN_CLICKED OR CBCTLMSG = 1 THEN
IF hFont THEN DeleteObject hFont
IF gifontbold THEN gifontbold=0& ELSE gifontbold=1&
hFont = MakeFontEx("Courier New", gifontsize, 0, 0, 0)
IF hFont THEN
CONTROL SEND CBHNDL, %Listbox, %WM_SETFONT, hFont, 1
END IF
END IF
CASE %IDCANCEL ' "Exit" button or the Esc-key was pressed
IF CBCTLMSG = %BN_CLICKED OR CBCTLMSG = 1 THEN
DIALOG END CBHNDL, 0
END IF
END SELECT
CASE %WM_SIZE ' is sent on resize - auto-size the TextBox
IF CBWPARAM <> %SIZE_MINIMIZED THEN ' avoid minimized state
w = LO(WORD, CBLPARAM) ' dialog client area's width in pixels
h = HI(WORD, CBLPARAM) ' dialog client area's height in pixels
DIALOG PIXELS CBHNDL, w, h TO UNITS w, h ' convert to dialog units
CONTROL GET LOC CBHNDL, %listbox TO x, y ' we need top pos
CONTROL SET SIZE CBHNDL, %listbox, w, h - y ' auto-size..
END IF
END SELECT
END FUNCTION
FUNCTION findwidestpart(BYVAL a AS STRING) AS LONG
LOCAL i AS LONG
LOCAL j AS LONG
LOCAL k AS LONG
LOCAL l AS LONG
k=0&
l=LEN(a)
i=1&
findagain:
j=INSTR(i,a,$CRLF)
IF j THEN
IF j-i>k THEN k=j-i
i=j+2
IF i<l THEN GOTO findagain
END IF
IF i<l AND l-i>k THEN k=l-i
FUNCTION=k
END FUNCTION
'______________________________________________________________________________
FUNCTION PBMAIN()
LOCAL hDlg AS DWORD
LOCAL Root AS STRING
DIM Datainthefile(0 TO 0) AS STRING
LOCAL Filter AS STRING
LOCAL FileCount AS DWORD
LOCAL filename AS STRING
LOCAL linecount AS LONG
LOCAL I AS DOUBLE
LOCAL hfile2 AS LONG
LOCAL aa AS STRING
LOCAL bb AS STRING
LOCAL vscrollbarwidth AS LONG
LOCAL vwindowsize AS LONG
LOCAL hwindowsize AS LONG
REDIM gstextundo(0 TO 3)
Filename=TRIM$(COMMAND$)
IF LEN(filename)=0& THEN filename="C:\list.prn" 'for testing purposes
'linecount = linesinthefile(filename)
'MSGBOX STR$(LINECOUNT)
gstext=getfile(filename)
'msgbox str$(ubound(datainthefile() ))
'gstext=JOIN$(datainthefile(),$CRLF)
I=INSTR(gstext,$CRLF+CHR$(26))
IF I THEN
gstext=LEFT$(gstext,I-1)
ELSE
I=INSTR(gstext,CHR$(26))
IF I THEN gstext=LEFT$(gstext,I-1)
END IF
IF LEN(gstext)>0& THEN
SLEEP 10
largestwidthline=findwidestpart(gstext)
linecount=TALLY(gstext,$CRLF)+1&
FOR i=0 TO 3
gstextundo(i)=gstext
SLEEP 5
NEXT i
ELSE
gstext="the file is empty"+$CRLF+"or there is no file"
END IF
'IF linecount<0& THEN
' IF filename="" THEN
' MSGBOX "filename needed, place a filename on the command line",," "
' ELSE
' MSGBOX filename+" does not exist",," "
' END IF
' EXIT FUNCTION
'END IF
' FOR i=0 TO linecount-1&
' IF LEN(Datainthefile(i))=0& THEN Datainthefile(I)=" " 'an array passed to a listbox cannot have a empty cell(subscript)
' ' IF LEN(Datainthefile(i))>largestwidthline THEN largestwidthline=LEN(datainthefile(i))
' NEXT I
gifontbold=1&
FONTSIZE=10&
gifontsize=fontsize
gibuttonfontsize=8
vscrollbarwidth=largestwidthline*(fontsize-2&)
vwindowsize=vscrollbarwidth+fontsize
IF vwindowsize>550& THEN vwindowsize=550&
IF vwindowsize<100 THEN vwindowsize=100&
hwindowsize=linecount*(fontsize+2&)
IF hwindowsize>300& THEN hwindowsize=300&
IF hwindowsize<100 THEN hwindowsize=100&
DIALOG FONT "Courier New",FONTSIZE
DIALOG NEW %HWND_DESKTOP, filename, , , vwindowsize, hwindowsize, _
%WS_CAPTION OR %WS_SYSMENU OR _
%WS_MINIMIZEBOX OR %WS_MAXIMIZEBOX OR %WS_THICKFRAME OR %WS_BORDER OR %WS_CLIPSIBLINGS OR %WS_CLIPCHILDREN, 0 TO hDlg
SetClassLong hDlg, %GCL_HICON, LoadIcon(BYVAL %NULL, BYVAL %IDI_INFORMATION)
' CONTROL ADD LISTBOX, hDlg, %ListBox, Datainthefile(), 0, 10, vwindowsize, hwindowsize, %LBS_NOTIFY OR _
' %WS_TABSTOP OR %WS_VSCROLL OR %WS_HSCROLL, %WS_EX_CLIENTEDGE
CONTROL ADD TEXTBOX, hDlg, %listbox, "", 0, 10, vwindowsize, hwindowsize, _
%WS_HSCROLL OR %ES_MULTILINE OR %ES_WANTRETURN OR _
%WS_VSCROLL , %WS_EX_CLIENTEDGE
CONTROL SET COLOR hDlg,%listbox,-1,-1
CONTROL SEND hDlg, %ListBox, %LB_SETHORIZONTALEXTENT, vscrollbarwidth+(fontsize*3&), 0
CONTROL ADD BUTTON, hDlg, %IDC_BUTNFONT, "Font", 1, 1, 18, 8
CONTROL ADD BUTTON, hDlg, %IDC_BUTNFONT1, "font", 21, 1, 18, 8
CONTROL ADD BUTTON, hDlg, %IDC_BUTNFONT2, "FONT", 41, 1, 18, 8
CONTROL ADD BUTTON, hDlg, %IDC_BUTNFONT3, "Bold", 61, 1, 18, 8
CONTROL ADD BUTTON, hDlg, %IDCANCEL, "E&xit", 81, 1, 18, 8
hFont = MakeFontEx("Courier New", 10, 2, 0, 0)
IF hFont THEN
CONTROL SEND hDlg, %Listbox, %WM_SETFONT, hFont, 1
SLEEP 20
END IF
hbuttonFont = MakeFontEx("Courier New", gibuttonfontsize, 0, 0, 0)
IF hbuttonFont THEN
CONTROL SEND hDlg, %Listbox, %WM_SETFONT, hbuttonfont, 1
END IF
DIALOG SHOW MODAL hDlg CALL DlgProc
END FUNCTION
'txt2wndw.bas
'compiled with pbwin 8.04
'program reads a file then displays the contents in a window
#COMPILE EXE
#REGISTER NONE
#DIM ALL
#INCLUDE "Win32Api.Inc"
#INCLUDE "COMDLG32.INC" ' Common dialog declares
#INCLUDE "PREVIEW.INC" ' Preview dialog include from tutorials in the samples directory
%IDC_BUTNOPEN = 120 ' Control id's
%IDC_BUTNVIEW = 121
%IDC_BUTNPAGE = 122
%IDC_BUTNFONT = 123
%IDC_BUTNFONT1 = 124
%IDC_BUTNFONT2 = 125
%IDC_BUTNFONT3 = 126
%ListBox = 201
GLOBAL datainthefile() AS STRING
GLOBAL largestwidthline AS LONG
GLOBAL gifontsize AS DWORD
GLOBAL gibuttonfontsize AS DWORD
GLOBAL gstext AS STRING
GLOBAL glinecount AS LONG
GLOBAL gLINESTART AS LONG
GLOBAL gcharactercount AS LONG
GLOBAL glinestartcharactercount AS LONG
GLOBAL hFont,hbuttonfont AS DWORD
GLOBAL FONTSIZE AS LONG
GLOBAL gifontbold AS LONG
GLOBAL ghdlg AS WORD
'FUNCTION DECLARATIONS---------------------------------------------------------------
DECLARE FUNCTION findwidestpart(BYVAL a AS STRING) AS LONG
DECLARE FUNCTION GetFile (BYVAL sFile AS STRING) AS STRING
DECLARE FUNCTION MakeFontEx (BYVAL FontName AS STRING, _
BYVAL PointSize AS LONG, _
BYVAL fBold AS LONG, _
BYVAL fItalic AS LONG, _
BYVAL fUnderline AS LONG) AS DWORD
DECLARE FUNCTION SelectFontProc (BYVAL hDlg AS DWORD, _
BYVAL id AS LONG, _
hFont AS DWORD, _
pd AS PreviewData) AS LONG
'----------------------------------------------------------------------------------------
'====================================================================
FUNCTION GetFile (BYVAL sFile AS STRING) AS STRING
'--------------------------------------------------------------------
' Open and return given file's contents as a string
'--------------------------------------------------------------------
LOCAL ff AS LONG
LOCAL sBuf AS STRING
IF LEN(DIR$(sFile)) = 0 THEN
MSGBOX "The file does not exist.", %MB_TASKMODAL, "Error"
EXIT FUNCTION
END IF
ff = FREEFILE
OPEN sFile FOR BINARY ACCESS READ LOCK SHARED AS ff LEN = 16000
IF ERR THEN ' Always trap ev. errors on file open actions
MSGBOX ERROR$(ERR), %MB_TASKMODAL, "Error"
RESET : ERRCLEAR : EXIT FUNCTION
END IF
GET$ ff, LOF(ff), sBuf
CLOSE ff
FUNCTION = sBuf
END FUNCTION
FUNCTION findcharactercount() AS LONG
LOCAL TEMP1 AS LONG,TEMP2 AS LONG
LOCAL I AS QUAD
TEMP1=1&
TEMP2=1&
FOR i=1 TO glinestart
temp2=INSTR(TEMP1,GSTEXT,$CRLF)
IF glinestart=i THEN
gCHARACTERCOUNT=TEMP1
glinestartcharactercount=INSTR(TEMP1,GSTEXT,$CRLF)-1&-gcharactercount
EXIT FUNCTION
END IF
IF i=glinecount THEN EXIT FOR
temp1=temp2+1
NEXT i
gCHARACTERCOUNT=INSTR(-1,gstext,$CRLF)
gCHARACTERCOUNT=INSTR(gcharactercount-1,gstext,$CRLF)
glinestartcharactercount=2
END FUNCTION
'FUNCTION EmLineScroll(BYVAL hEdit AS LONG, BYVAL x AS LONG, BYVAL y AS LONG) AS LONG
' FUNCTION = SendMessage(hEdit, %EM_LINESCROLL, x, y)
'END FUNCTION
'====================================================================
FUNCTION MakeFontEx (BYVAL FontName AS STRING, _
BYVAL PointSize AS LONG, _
BYVAL fBold AS LONG, _
BYVAL fItalic AS LONG, _
BYVAL fUnderline AS LONG) AS DWORD
'--------------------------------------------------------------------
' Create a desired font and return its handle.
'--------------------------------------------------------------------
LOCAL hDC AS DWORD, CharSet AS LONG, CyPixels AS LONG
IF gifontbold THEN fbold=700 ELSE fbold=400
hDC = GetDC(%HWND_DESKTOP)
CyPixels = GetDeviceCaps(hDC, %LOGPIXELSY)
EnumFontFamilies hDC, BYVAL STRPTR(FontName), CODEPTR(EnumCharSet), BYVAL VARPTR(CharSet)
ReleaseDC %HWND_DESKTOP, hDC
PointSize = 0 - (PointSize * CyPixels) \ 72
FUNCTION = CreateFont(PointSize, 0, _ 'height, width(default=0)
0, 0, _ 'escapement(angle), orientation
fBold, _ 'weight (%FW_DONTCARE = 0, %FW_NORMAL = 400, %FW_BOLD = 700)
fItalic, _ 'Italic
fUnderline, _ 'Underline
%FALSE, _ 'StrikeThru
CharSet, %OUT_TT_PRECIS, _
%CLIP_DEFAULT_PRECIS, %DEFAULT_QUALITY, _
%FF_DONTCARE , BYCOPY FontName)
END FUNCTION
'====================================================================
FUNCTION EnumCharSet (elf AS ENUMLOGFONT, ntm AS NEWTEXTMETRIC, _
BYVAL FontType AS LONG, CharSet AS LONG) AS LONG
'--------------------------------------------------------------------
' Get type of character set - ansi, symbol, etc. A must for some fonts..
' Called from FUNCTION MakeFontEx.
'--------------------------------------------------------------------
CharSet = elf.elfLogFont.lfCharSet
END FUNCTION
'====================================================================
FUNCTION SelectFontProc (BYVAL hDlg AS DWORD, _
BYVAL id AS LONG, _
hFont AS DWORD, _
pd AS PreviewData) AS LONG
'--------------------------------------------------------------------
' Use COMDLG32's Font dialog for font settings
'--------------------------------------------------------------------
LOCAL cf AS CHOOSEFONTAPI, lf AS LOGFONT
IF hFont THEN GetObject hFont, SIZEOF(lf), lf
cf.lStructSize = SIZEOF(CHOOSEFONTAPI)
cf.hwndOwner = hDlg
cf.lpLogFont = VARPTR(lf)
cf.Flags = %CF_BOTH OR %CF_FORCEFONTEXIST OR %CF_INITTOLOGFONTSTRUCT
cf.nFontType = %SCREEN_FONTTYPE
IF ChooseFont(cf) THEN
pd.FontName = lf.lfFaceName
pd.FontSize = cf.iPointSize / 10
pd.FontType = IIF&(lf.lfWeight < 500, 0, 1)
IF lf.lfItalic THEN pd.FontType = pd.FontType OR 2
IF lf.lfUnderline THEN pd.FontType = pd.FontType OR 4
IF hFont THEN DeleteObject hFont
hFont = MakeFontEx (pd.FontName, pd.FontSize, _
lf.lfWeight, lf.lfItalic, lf.lfUnderline)
FUNCTION = %TRUE
END IF
END FUNCTION
'______________________________________________________________________________
CALLBACK FUNCTION DlgProc
LOCAL h, w, x, y AS LONG
LOCAL i AS LONG
SELECT CASE AS LONG CBMSG
CASE %WM_INITDIALOG ' <- Received right before the dialog is shown
'------------------------------------------------------------------
' The main program is responsible for maintaining a Static or Global
' PreviewData variable and calling InitPreviewDlg before the Print
' Preview dialog in Preview.inc is used.
'------------------------------------------------------------------
STATIC pd AS PreviewData ' <- Defined in Preview.inc
InitPreviewDlg pd ' <- Located in Preview.inc
IF LEN(gsText) THEN CONTROL SET TEXT CBHNDL, %listbox , gsText
IF hFont THEN DeleteObject hFont
hFont = MakeFontEx("Courier New", gifontsize, 0, 0, 0)
IF hFont THEN CONTROL SEND CBHNDL, %Listbox, %WM_SETFONT, hFont, 1
CONTROL SET FOCUS ghdlg, %listbox
LISTBOX SELECT ghdlg, %listbox, 4&
' CONTROL SEND ghDlg, %listbox , %Es_readonly, 1&,0&
IF gcharactercount THEN
IF glinecount>=glinestart THEN
CONTROL SEND ghDlg, %listbox , %EM_SETSEL, gcharactercount&, gcharactercount+glinestartcharactercount&
CONTROL SEND ghDlg, %listbox , %Es_readonly, 1&,0&
IF glinestart<=glinecount THEN CONTROL SEND CBHNDL, %LISTBOX, %EM_LINESCROLL,0, glinestart-10
ELSE
CONTROL SEND ghDlg, %listbox , %EM_SETSEL, gcharactercount&, gcharactercount+glinestartcharactercount&
CONTROL SEND CBHNDL, %LISTBOX, %EM_LINESCROLL,0, glinecount
END IF
END IF
FUNCTION=1&
CASE %WM_DESTROY ' <- Received right before the dialog is destroyed
IF hFont THEN DeleteObject hFont
CASE %WM_COMMAND
'----------------------------------------------------
' Messages from the controls are handled here.
' Example: Button clicks generates a %BN_CLICKED message
' and menu clicks generates the value 1.
'----------------------------------------------------
SELECT CASE AS LONG CBCTL
CASE %IDC_BUTNFONT
IF CBCTLMSG = %BN_CLICKED OR CBCTLMSG = 1 THEN
IF SelectFontProc (CBHNDL, %listbox, hFont, pd) THEN
CONTROL SEND CBHNDL, %listbox, %WM_SETFONT, hFont, 1
END IF
END IF
CASE %IDC_BUTNFONT1
IF CBCTLMSG = %BN_CLICKED OR CBCTLMSG = 1 THEN
IF gifontsize>5 THEN gifontsize=gifontsize-1
IF hFont THEN DeleteObject hFont
hFont = MakeFontEx("Courier New", gifontsize, 0, 0, 0)
IF hFont THEN CONTROL SEND CBHNDL, %Listbox, %WM_SETFONT, hFont, 1
END IF
CASE %IDC_BUTNFONT2
IF CBCTLMSG = %BN_CLICKED OR CBCTLMSG = 1 THEN
IF gifontsize<72 THEN gifontsize=gifontsize+1
IF hFont THEN DeleteObject hFont
hFont = MakeFontEx("Courier New", gifontsize, 0, 0, 0)
IF hFont THEN CONTROL SEND CBHNDL, %Listbox, %WM_SETFONT, hFont, 1
END IF
CASE %IDC_BUTNFONT3
IF CBCTLMSG = %BN_CLICKED OR CBCTLMSG = 1 THEN
IF hFont THEN DeleteObject hFont
IF gifontbold THEN gifontbold=0& ELSE gifontbold=1&
hFont = MakeFontEx("Courier New", gifontsize, 0, 0, 0)
IF hFont THEN
CONTROL SEND CBHNDL, %Listbox, %WM_SETFONT, hFont, 1
END IF
END IF
CASE %IDCANCEL ' "Exit" button or the Esc-key was pressed
IF CBCTLMSG = %BN_CLICKED OR CBCTLMSG = 1 THEN
DIALOG END CBHNDL, 0
END IF
END SELECT
CASE %WM_SIZE ' is sent on resize - auto-size the TextBox
IF CBWPARAM <> %SIZE_MINIMIZED THEN ' avoid minimized state
w = LO(WORD, CBLPARAM) ' dialog client area's width in pixels
h = HI(WORD, CBLPARAM) ' dialog client area's height in pixels
DIALOG PIXELS CBHNDL, w, h TO UNITS w, h ' convert to dialog units
CONTROL GET LOC CBHNDL, %listbox TO x, y ' we need top pos
CONTROL SET SIZE CBHNDL, %listbox, w, h - y ' auto-size..
END IF
END SELECT
END FUNCTION
FUNCTION findwidestpart(BYVAL a AS STRING) AS LONG
LOCAL i AS LONG
LOCAL j AS LONG
LOCAL k AS LONG
LOCAL l AS LONG
k=0&
l=LEN(a)
i=1&
findagain:
j=INSTR(i,a,$CRLF)
IF j THEN
IF j-i>k THEN k=j-i
i=j+2
IF i<l THEN GOTO findagain
END IF
IF i<l AND l-i>k THEN k=l-i
FUNCTION=k
END FUNCTION
'______________________________________________________________________________
FUNCTION PBMAIN()
LOCAL hDlg AS DWORD
LOCAL Root AS STRING
DIM Datainthefile(0 TO 0) AS STRING
LOCAL Filter AS STRING
LOCAL FileCount AS DWORD
LOCAL filename AS STRING
LOCAL I AS DOUBLE
LOCAL hfile2 AS LONG
LOCAL aa AS STRING
LOCAL bb AS STRING
LOCAL vscrollbarwidth AS LONG
LOCAL vwindowsize AS LONG
LOCAL hwindowsize AS LONG
LOCAL TEMP1 AS LONG,TEMP2 AS LONG
LOCAL COMMANDLINE$
commandline$=" "+TRIM$(COMMAND$)+" "
TEMP1=INSTR(UCASE$(commandline$),"/L:")
IF TEMP1 THEN
TEMP2=INSTR(TEMP1+3,UCASE$(commandline$)," ")-(TEMP1+3)
gLINESTART=VAL(MID$(COMMANDLINE$,TEMP1+3,TEMP2))
COMMANDLINE$=REMOVE$(COMMANDLINE$,MID$(COMMANDLINE$,TEMP1,TEMP1+TEMP2+3))
END IF
Filename=TRIM$(COMMANDLINE$)
gstext=getfile(filename)
I=INSTR(gstext,$CRLF+CHR$(26))
IF I THEN
gstext=LEFT$(gstext,I+1)
ELSE
I=INSTR(gstext,CHR$(26))
IF I THEN gstext=LEFT$(gstext,I-1&)
END IF
IF LEN(gstext)>0& THEN
SLEEP 10
largestwidthline=findwidestpart(gstext)
glinecount=TALLY(gstext,$CRLF)
IF glinestart THEN findcharactercount
ELSE
gstext="The file is empty or"+$CRLF+"there is no file on "+$CRLF+_
"the command line."+$CRLF+_
"An option to start"+$CRLF+"viewing at a specific"+$CRLF+"line can be added"+$CRLF+_
"using /L:####"
END IF
gifontbold=1&
FONTSIZE=10&
gifontsize=fontsize
gibuttonfontsize=8
vscrollbarwidth=largestwidthline*((fontsize/2)-2&)
vwindowsize=vscrollbarwidth+fontsize
IF vwindowsize>400& THEN vwindowsize=400&
IF vwindowsize<100 THEN vwindowsize=100&
hwindowsize=glinecount*((fontsize/2)+2&)
IF hwindowsize>300& THEN hwindowsize=300&
IF hwindowsize<100 THEN hwindowsize=100&
DIALOG FONT "Courier New",FONTSIZE
DIALOG NEW %HWND_DESKTOP, filename, , , vwindowsize, hwindowsize, _
%WS_CAPTION OR %WS_SYSMENU OR _
%WS_MINIMIZEBOX OR %WS_MAXIMIZEBOX OR %WS_THICKFRAME OR %WS_BORDER OR %WS_CLIPSIBLINGS OR %WS_CLIPCHILDREN, 0 TO hDlg
SetClassLong hDlg, %GCL_HICON, LoadIcon(BYVAL %NULL, BYVAL %IDI_INFORMATION)
' CONTROL ADD LISTBOX, hDlg, %ListBox, Datainthefile(), 0, 10, vwindowsize, hwindowsize, %LBS_NOTIFY OR _
' %WS_TABSTOP OR %WS_VSCROLL OR %WS_HSCROLL, %WS_EX_CLIENTEDGE
CONTROL ADD TEXTBOX, hDlg, %listbox, "", 0, 10, vwindowsize, hwindowsize, _
%WS_HSCROLL OR %ES_MULTILINE OR %ES_NOHIDESEL OR %ES_WANTRETURN OR _
%WS_VSCROLL , %WS_EX_CLIENTEDGE
CONTROL SET COLOR hDlg,%listbox,-1,-1
CONTROL SEND hDlg, %ListBox, %LB_SETHORIZONTALEXTENT, vscrollbarwidth+(fontsize*3&), 0
CONTROL ADD BUTTON, hDlg, %IDC_BUTNFONT, "Font", 1, 1, 18, 8
CONTROL ADD BUTTON, hDlg, %IDC_BUTNFONT1, "font", 21, 1, 18, 8
CONTROL ADD BUTTON, hDlg, %IDC_BUTNFONT2, "FONT", 41, 1, 18, 8
CONTROL ADD BUTTON, hDlg, %IDC_BUTNFONT3, "Bold", 61, 1, 18, 8
CONTROL ADD BUTTON, hDlg, %IDCANCEL, "E&xit", 81, 1, 18, 8
hFont = MakeFontEx("Courier New", 10, 2, 0, 0)
IF hFont THEN
CONTROL SEND hDlg, %Listbox, %WM_SETFONT, hFont, 1
' SLEEP 20
END IF
hbuttonFont = MakeFontEx("Courier New", gibuttonfontsize, 0, 0, 0)
IF hbuttonFont THEN
CONTROL SEND hDlg, %Listbox, %WM_SETFONT, hbuttonfont, 1
END IF
ghdlg=hdlg
DIALOG SHOW MODAL hDlg CALL DlgProc
END FUNCTION
#INCLUDE "c:\pbwin80\samples\ddt\graphic\textview\PREVIEW.INC" '
Comment