![]() Home |
TestText Text Editor like Notepad |
![]() Home |
This is a text editing program modled after Notepad in a file called TestText.dpr. It will show some API printing procedures in the PrintMe Function. This uses menus and you can drag and drop files from explorer. There are reading and writing Registry functions here. This program uses a Resource Template windows dialog, it's in the Resourse file {$R PNTDLG.RES}. Here is the code lines for the .RC file named PntDlg.rcPrintDlg DIALOG 20, 20, 120, 42
STYLE WS_POPUP | WS_DLGFRAME | WS_CAPTION | WS_SYSMENU | WS_VISIBLE
CAPTION " Stop Printing"
FONT 10, "MS Sans Serif"
{
CTEXT "Stop Printing and Cancel Printing process" -1, 4, 6, 112, 9
DEFPUSHBUTTON "Cancel" IDCANCEL, 44, 22, 32, 14, WS_GROUP
}
Complie this PntDlg.rc file with brcc32.exe
This Dialog is included here because it is in several "How To Code" windows 95 instuction books (in the C language). . And was meant for "Older" types of printers and printer drivers, where one page was sent to the printer and printed before the next page was sent (or the amount of text the printer's Memory would hold). But Newer printers and newer Window's versions, use a different method of printing and Memory usage. They send the entire print job (all pages) to the printer driver, (or as many pages as the driver will accept at once). So you may never see this Dialog box, even with muti-page printing, unless you still use an old Dot-Matrix printer. Under Construction There are not many comments in this to help you understand it. The whole printing thing is rather much to try and do, but the code here should give you something to start with. |
program TestText;
uses
Windows, Messages, Commdlg, WinSpool, ShellApi, smallutils;
{$R *.RES}
{$R PNTDLG.RES}
const
mID_New = 101;
mID_Open = 102;
mID_Save = 103;
mID_SaveAs = 104;
mID_Print = 105;
mID_PageSetup = 106;
mID_Exit = 107;
mID_Undo = 201;
mID_Copy = 202;
mID_Cut = 203;
mID_Paste = 204;
mID_Del = 205;
mID_SelAll = 206;
mID_Date = 207;
mID_Wrap = 208;
mID_Font = 209;
mID_Find = 301;
mID_FindNext = 302;
var
wClass: TWndClass;
hForm1, hMemo1, Font1, Font2, hStatus, hLineNum,
menuFile, menuEdit, menuMain, menuSearch,
hFindWnd, hDlgCancel: Integer;
mainMsg: TMSG;
CurrentFile: String;
PntDrvName: PChar;
Rect1, SetupRect, MinMarRect: TRect;
Wrap, StopPrint, GotSetup, ShowMax: Boolean;
FontLog: TLogFont;
MenuInfo: TMENUITEMINFO;
PMemo1Proc, PExitSave: Pointer;
DataType, Left, Top, sWidth, sHeight, RegTemp: Integer;
TT88Key: HKey;
WndProcPtrAtom: TAtom = 0;
FindMess: Integer;
FindRelp: TFindReplace;
FindTextA: array[0..255] of Char;
{FindTextA is the Array the Pointer lpstrReplaceWith
in FindRelp is set to}
FaceNmA: array[0..31] of Char;
Arry4Byte: Array[0..3] of Byte;
// / / / / / / /
function Write2Reg(Key: HKEY ;const Name: PChar; Buffer: Pointer;
BufSize: Integer; DataType: Integer): Boolean;
begin
Result := False;
if RegSetValueEx(Key, Name, 0, DataType, Buffer, BufSize) = ERROR_SUCCESS then
Result := True;
end;
function OpenRegKey: HKey;
var
TempKey, SoftKey: HKey;
RegOpen: Boolean;
Dispos: Integer;
begin
RegOpen := True;
if RegOpenKeyEx(HKEY_CURRENT_USER, 'Software\TestText88', 0,
KEY_WRITE, TempKey) <> ERROR_SUCCESS then
begin
RegOpen := False;
if RegOpenKeyEx(HKEY_CURRENT_USER, 'Software', 0,
KEY_WRITE, SoftKey) = ERROR_SUCCESS then
begin
if RegCreateKeyEx(SoftKey,'TestText88',0,nil,
REG_OPTION_NON_VOLATILE,KEY_WRITE,nil,TempKey,@Dispos) = ERROR_SUCCESS then
RegOpen := True;
RegCloseKey(SoftKey);
end;
end;
if RegOpen then
Result := TempKey
else Result := 0;
end;
procedure ShutDown;
var
WinPlace: TWindowPlacement;
RegKey: HKey;
Name: PChar;
RegValue, Neg: Cardinal;
begin
WinPlace.length := SizeOf(TWindowPlacement);
GetWindowPlacement(hForm1,@WinPlace);
RegKey := OpenRegKey;
if RegKey <> 0 then
begin
if WinPlace.rcNormalPosition.Top < 0 then
Neg := 0 else
Neg := WinPlace.rcNormalPosition.Top;
if WinPlace.rcNormalPosition.Left < 0 then
WinPlace.rcNormalPosition.Left := 0;
RegValue := abs(Neg shl 16)+WinPlace.rcNormalPosition.Left;
Name := 'Position';
Write2Reg(RegKey, Name, @RegValue, SizeOf(Cardinal), REG_DWORD);
Name := 'WindowSize';
Neg := WinPlace.rcNormalPosition.Right - WinPlace.rcNormalPosition.Left;
RegValue := abs(Neg shl 16) +
abs(WinPlace.rcNormalPosition.Bottom-WinPlace.rcNormalPosition.Top);
Write2Reg(RegKey, Name, @RegValue, SizeOf(Cardinal),REG_DWORD );
Name := 'IsMax';
RegValue := WinPlace.showCmd;
Write2Reg(RegKey, Name, @RegValue, SizeOf(Cardinal),REG_DWORD );
RegCloseKey(RegKey);
end;
DeleteObject(Font1);
DeleteObject(Font2);
PostQuitMessage(0);
end;
function DlgOpenSave(Open: Boolean): String;
var
OFName : TOpenFileName;
FileName: Array[0..2047] of Char;
begin
ZeroMemory(@FileName, SizeOf(FileName));
ZeroMemory(@OFName, SizeOf(OFName));
with OFName do
begin
lStructSize := sizeof(ofName);
hwndowner := hForm1;
nMaxFile := SizeOf(FileName);
lpstrFile := @FileName;
nFilterIndex := 1;
lpstrFilter := 'Text file (*.txt)'#0'*.txt'#0'All files (*.*)'#0'*.*'#0#0;
if Open then
begin
Flags := OFN_EXPLORER or OFN_PATHMUSTEXIST or
OFN_FILEMUSTEXIST or OFN_HIDEREADONLY;
lpstrTitle:='Open a Text file';
end else
begin
FileName := 'New1.txt';
Flags := OFN_EXPLORER or OFN_PATHMUSTEXIST or
OFN_OVERWRITEPROMPT or OFN_HIDEREADONLY;
lpstrTitle:='Save this Text File';
end;
lpstrDefExt := 'txt';
if CurrentFile = '?' then
lpstrInitialDir := 'C:\'
else
begin
if not Open then
StrCopy(FileName, PChar(CurrentFile));
if UpperCase(GetFileExt(CurrentFile)) <> '.TXT' then
begin
lpstrFilter := 'All files (*.*)'#0'*.*'#0#0;
lpstrDefExt := '';
end;
lpstrInitialDir := PChar(GetFilePath(CurrentFile));
end;
end;
Result := '';
if Open then
begin
if GetOpenFileName(OFName) then
Result := FileName;
end else
if GetSaveFileName(OFName) then
Result := FileName;
end;
function CancelProc(hWnd,Msg,wParam,lParam:Longint):Integr; stdcall;
begin
Result := 0;
if Msg = WM_COMMAND then
begin
StopPrint := True;
EnableWindow(hForm1,True);
DestroyWindow(hWnd);
hDlgCancel := 0;
Result := 1;
end;
end;
function AbortProc(PrintDC: HDC; Error1: Integer): Boolean;
var
Msg1: TMsg;
begin
while (not StopPrint) and PeekMessage(Msg1,0,0,0, PM_REMOVE) do
begin
if (hDlgCancel <> 0) or (not IsDialogMessage(hDlgCancel, Msg1)) then
begin
TranslateMessage(Msg1);
DispatchMessage(Msg1);
end;
end;
Result := not StopPrint;
end;
function GetDefaultPrinter: PChar;
var
ByteCnt, StructCnt: DWORD;
DefaultPrinter: array[0..79] of Char;
Cur: PChar;
PrinterInfo: PPrinterInfo5;
function FetchStr(var pStr: PChar): PChar;
var
P: PChar;
begin
Result := pStr;
if pStr = nil then Exit;
P := pStr;
while P^ = ' ' do Inc(P);
Result := P;
while (P^ <> #0) and (P^ <> ',') do Inc(P);
if P^ = ',' then
begin
P^ := #0;
Inc(P);
end;
pStr := P;
end;
begin
Result := '';
ByteCnt := 0;
StructCnt := 0;
if not EnumPrinters(PRINTER_ENUM_DEFAULT, nil, 5, nil, 0, ByteCnt,
StructCnt) and (GetLastError <> ERROR_INSUFFICIENT_BUFFER) then
begin
// With no printers installed, Win95/98 fails above with "Invalid filename".
// NT succeeds and returns a StructCnt of zero.
MessageBox(hForm1, PChar('No Default Printer availible'+#13+
SysErrorMessage(GetLastError)),
'No Default Printer', MB_OK or MB_ICONERROR);
Exit;
end;
PrinterInfo := AllocMem(ByteCnt);
try
EnumPrinters(PRINTER_ENUM_DEFAULT, nil, 5, PrinterInfo, ByteCnt, ByteCnt,
StructCnt);
if StructCnt > 0 then
begin
Result := PrinterInfo.pPrinterName;
end else
begin
GetProfileString('windows', 'device', '', DefaultPrinter, SizeOf(DefaultPrinter) - 1);
Cur := DefaultPrinter;
Result := FetchStr(Cur);
end;
finally
FreeMem(PrinterInfo);
end;
end;
function PageSetup(Def: Boolean): PChar;
var
PgSetupRec: TPageSetupDlg;
DevNames: PDevNames;
DeviceName: PChar;
PaperSize: TPoint;
begin
Result := '';
FillChar(PgSetupRec, SizeOf(PgSetupRec), 0);
{the PgSetupRec must be filled with "0" or the random data in that
memory block will confuse the OS when it tries to read it and will fail}
PgSetupRec.lStructSize := SizeOf(PgSetupRec);
PgSetupRec.hwndOwner := hForm1;
PgSetupRec.hInstance := wClass.hInstance;
if Def then
PgSetupRec.Flags := PSD_INTHOUSANDTHSOFINCHES or PSD_RETURNDEFAULT
else
PgSetupRec.Flags := PSD_INTHOUSANDTHSOFINCHES or PSD_DISABLEORIENTATION or PSD_DISABLEPAPER;
{WARNING , , I have included the PSD_DISABLEORIENTATION and PSD_DISABLEPAPER flags because
the Page Setup Dialog DOES NOT set the Printer driver to use these changes. The selections
are recorded in the TPageSetupDlg Record, but the printer driver is NOT changed. If Landscape
is set in Page Setup it DOES NOT set the printer driver to Landscape. If a paper size is set
it does not change the printer driver to that size}
if PageSetupDlg(PgSetupRec) then
begin
if not Def then
GotSetup := True;
DevNames := PDevNames(GlobalLock(PgSetupRec.hDevNames));
DeviceName := PChar(DevNames) + DevNames.wDeviceOffset;
GlobalUnlock(PgSetupRec.hDevNames);
SetupRect := PgSetupRec.rtMargin;
MinMarRect := PgSetupRec.rtMinMargin;
PaperSize := PgSetupRec.ptPaperSize;
Result := DeviceName;
end;
end;
procedure SetUpPage;
begin
PntDrvName := PageSetup(False);
if PntDrvName = '' then
GotSetup := False;
end;
function PrintMe: Boolean;
var
MemoStr: String;
DocInfo: TDocInfo;
PrintDC: HDC;
TextM: TTextMetric;
PntName: PChar;
PntRect: TRect;
PntDlg1: TPrintDlg;
DrawTxRec: TDRAWTEXTPARAMS;
PageHeight, PageWidth, PixInch, RemainText: Integer;
begin
Result := False;
StopPrint := False;
with DocInfo do
begin
cbSize := SizeOF(DocInfo);
if CurrentFile = '?' then
lpszDocName := 'New1.txt'
else lpszDocName := PChar(GetFileName(CurrentFile));
lpszOutput := nil;
lpszDatatype := nil;
fwType := 0;
end;
MemoStr := GetWindowStr(hMemo1);
if GotSetup then
PntName := PntDrvName else
PntName := PageSetup(True);
if PntName = '' then
begin
with PntDlg1 do
begin
lStructSize := sizeof(PntDlg1);
hDevMode := 0;
hDevNames := 0;
Flags := PD_RETURNDC;
hwndOwner := hForm1;
hDC := 0;
nFromPage := 1;
nToPage := 1;
nMinPage := 0;
nMaxPage := 0;
nCopies := 1;
hInstance := 0;
lCustData := 0;
lpfnPrintHook := nil;
lpfnSetupHook := nil;
lpPrintTemplateName := nil;
lpSetupTemplateName := nil;
hPrintTemplate := 0;
hSetupTemplate := 0;
end;
SetRect(MinMarRect,250,250,250,500);
if PrintDlg(PntDlg1) then
PrintDC := PntDlg1.HDC else
Exit;
end else
PrintDC := CreateDC(nil,PntName, nil,nil);
if PrintDC = 0 then
begin
MessageBox(hForm1, 'No Printer is available, can not print this page',
'No Printer', MB_OK or MB_ICONERROR);
Exit;
end;
SelectObject(PrintDC,Font1);
GetTextMetrics(PrintDC, TextM);
PixInch := GetDeviceCaps(PrintDC,LOGPIXELSX);
PageHeight := GetDeviceCaps(PrintDC,VERTRES);
PageWidth := GetDeviceCaps(PrintDC,HORZRES);
if GotSetup then
SetRect(PntRect,((SetupRect.Left-MinMarRect.Left) * PixInch) div 1000,
((SetupRect.Top-MinMarRect.Top) * PixInch) div 1000,
PageWidth-(((SetupRect.Right-MinMarRect.Right) * PixInch) div 1000),
PageHeight- (((SetupRect.Bottom-MinMarRect.Bottom) * PixInch) div 1000))
else
SetRect(PntRect,abs((PixInch div 2)- ((MinMarRect.Left* PixInch) div 10000)),
abs((PixInch div 2)- ((MinMarRect.Top* PixInch) div 1000)),
PageWidth- abs((PixInch div 2)- ((MinMarRect.Right* PixInch) div 10000)),
PageHeight- abs((PixInch div 2)- ((MinMarRect.Bottom* PixInch) div 1000)));
DrawTxRec.cbSize := SizeOf(DrawTxRec);
DrawTxRec.iTabLength := 6;
DrawTxRec.iLeftMargin := 0;
DrawTxRec.iRightMargin := 0;
StopPrint := False;
hDlgCancel := CreateDialog(hInstance, 'PrintDlg', hForm1, @CancelProc);
SetAbortProc(PrintDC, @AbortProc);
if StartDoc(PrintDC, DocInfo) < 1 then
begin
DeleteDC(PrintDC);
EnableWindow(hForm1, True);
DestroyWindow(hDlgCancel);
hDlgCancel := 0;
MessageBox(hForm1, 'Printer is not available, I can not print this page',
'No Printer', MB_OK or MB_ICONERROR);
Exit;
end;
RemainText := Length(MemoStr);
while RemainText > 0 do
begin
if StartPage(PrintDC) < 1 then Break;
DrawTextEx(PrintDC,PChar(MemoStr),Length(MemoStr),PntRect,
DT_LEFT or DT_WORDBREAK or DT_EXPANDTABS or DT_EDITCONTROL,@DrawTxRec);
if DrawTxRec.uiLengthDrawn <1 then Break;
Delete(MemoStr,1,DrawTxRec.uiLengthDrawn);
RemainText := Length(MemoStr);
If StopPrint then Break;
EndPage(PrintDC);
end;
EndDoc(PrintDC);
Result := True;
DeleteDC(PrintDC);
EnableWindow(hForm1, True);
DestroyWindow(hDlgCancel);
hDlgCancel := 0;
end;
procedure SaveIt(NewName: Boolean);
var
Sfile1: HWND;
TextBuf, FileName: String;
WriteAmount: Cardinal;
Sizes: TdriveSize;
begin
if NewName then
begin
FileName := DlgOpenSave(False);
if FileName = '' then
Exit;
end else
FileName := CurrentFile;
while PeekMessage(MainMsg, 0, 0, 0, PM_REMOVE) do
begin
TranslateMessage(MainMsg);
DispatchMessage(MainMsg);
end;
Sizes := DiskSpace(FileName);
while PeekMessage(MainMsg, 0, 0, 0, PM_REMOVE) do
begin
TranslateMessage(MainMsg);
DispatchMessage(MainMsg);
end;
while Sizes.FreeS < 0 do
begin
if MessageBox(hForm1, PChar('Could not write to text file - '#10+
FileName+#10'Is there a Disk in this drive ? To try again, '+
'place a disk in the drive and click "Retry"'),
'Disk in Drive ?', MB_RETRYCANCEL or MB_ICONERROR) = IDCANCEL then
Exit else
Sizes := DiskSpace(FileName);
while PeekMessage(MainMsg, 0, 0, 0, PM_REMOVE) do
begin
TranslateMessage(MainMsg);
DispatchMessage(MainMsg);
end;
end;
TextBuf := GetWindowStr(hMemo1);
if Sizes.FreeS < Length(TextBuf) then
begin
MessageBox(hForm1, PChar('Not enough Free disk space to save file - '#10+
FileName+#10'Delete files to increase free space or save to another disk'),
'Disk in Drive ?', MB_OK or MB_ICONERROR);
Exit;
end;
Sfile1 := CreateFile(PChar(FileName),GENERIC_WRITE,FILE_SHARE_READ,nil,CREATE_ALWAYS,
FILE_ATTRIBUTE_NORMAL or FILE_FLAG_SEQUENTIAL_SCAN,0);
if Sfile1 = INVALID_HANDLE_VALUE then
begin
MessageBox(hForm1, PChar('System Error, Could not create text file - - - '+
SysErrorMessage(GetLastError)),
'System could not write to file', MB_OK or MB_ICONERROR);
SetWindowText(hStatus, 'ERROR, system file write error');
Exit;
end;
if Length(TextBuf) > 0 then
if not WriteFile(Sfile1,TextBuf[1],Length(TextBuf),WriteAmount,nil) then
begin
MessageBox(hForm1, PChar('System Error, Could not write to text file - - - '+
SysErrorMessage(GetLastError)),
'System could not write to file', MB_OK or MB_ICONERROR);
CloseHandle(Sfile1);
SetWindowText(hStatus, 'ERROR, system file write error');
Exit;
end;
CloseHandle(Sfile1);
SendMessage(hMemo1,EM_SETMODIFY,0,0);
SetWindowText(hStatus, PChar(' '+FileName));
SetWindowText(hForm1, PChar(' '+GetFileName(FileName)+' -Test Text'));
end;
procedure File2Memo(FileName: String);
var
ChBuf: Array of Char;
hFile1: Integer;
Amount, BytesRead: Cardinal;
TempStr: String;
begin
Amount := FileSize(FileName);
if Amount = 0 then
begin
SendMessage(hMemo1, EM_SETSEL, 0, -1);
SendMessage(hMemo1, WM_CLEAR, 0, 0);
SetWindowText(hLineNum, '1: 1');
SetWindowText(hStatus, PChar(' '+FileName));
SetWindowText(hForm1, PChar(' '+GetFileName(FileName)+' -Test Text'));
CurrentFile := FileName;
Exit;
end;
if Amount > 32765 then
begin
MessageBox(hForm1, PChar(FileName+#10+
' file is more than 32 Kb, and CAN NOT be opened by this program'),
'ERROR, File is TOO LARGE', MB_OK or MB_ICONERROR);
SetWindowText(hStatus, 'ERROR, file is more than 32 Kb');
Exit;
end;
SetLength(ChBuf,Amount+1);
hFile1 := CreateFile(PChar(FileName),GENERIC_READ,FILE_SHARE_READ,nil,
OPEN_EXISTING,FILE_ATTRIBUTE_NORMAL or FILE_FLAG_SEQUENTIAL_SCAN,0);
if not ReadFile(hFile1,ChBuf[0],Amount,BytesRead,nil) then
begin
CloseHandle(hFile1);
MessageBox(hForm1, PChar('System Error, Could not read text file - - - '+
SysErrorMessage(GetLastError)),
'System could not read file', MB_OK or MB_ICONERROR);
SetWindowText(hStatus, 'ERROR, system file read error');
Exit;
end;
CloseHandle(hFile1);
if BytesRead<=0 then
begin
MessageBox(hForm1, 'file Read Error, Could not read text file',
' could not read file', MB_OK or MB_ICONERROR);
SetWindowText(hStatus, 'ERROR, system file read error');
Exit;
end;
ChBuf[BytesRead] := #0;
TempStr := String(ChBuf);
TempStr := AdjustLineBreaks(TempStr);
SetWindowText(hMemo1,@TempStr[1]);
SetWindowText(hLineNum, '1: 1');
SetWindowText(hStatus, PChar(' '+FileName));
SetWindowText(hForm1, PChar(' '+GetFileName(FileName)+' -Test Text'));
CurrentFile := FileName;
SendMessage(hMemo1,EM_SETMODIFY,0,0);
TempStr := '';
end;
procedure OpenTextFile;
var
FileName: String;
begin
FileName := DlgOpenSave(True);
if Filename = '' then Exit;
File2Memo(FileName);
end;
procedure DropedOn(const hDropS:Cardinal);
var
BufferSize : Integer;
File1: String;
begin
BufferSize := 256;
BufferSize := DragQueryFile(hDropS,0,NIL,BufferSize);
SetLength(File1,BufferSize);
DragQueryFile(hDropS,0,@File1[1],BufferSize+1);
DragFinish(hDropS);
if not DirectoryExists(File1) then
File2Memo(File1);
File1 := '';
end;
procedure SetLineNum;
var
MesRe, ChPos, Line: Integer;
begin
MesRe := SendMessage(hMemo1,EM_GETSEL, 0, 0);
ChPos := HIWORD(MesRe);
Line := SendMessage(hMemo1,EM_LINEFROMCHAR, ChPos, 0);
MesRe := SendMessage(hMemo1,EM_LINEINDEX, Line, 0);
if MesRe < 0 then
begin
SetWindowText(hLineNum, 'X: Y');
Exit
end;
SetWindowText(hLineNum, PChar(Int2Str(Line+1)+': '+Int2Str(1+ChPos - MesRe)));
end;
procedure SearchFor(This: String; Down, MatchCase, Whole: Boolean);
var
i, ThisLgn, CurPos: Integer;
MemoStr: String;
begin
MemoStr := GetWindowStr(hMemo1);
if Length(MemoStr) < 16 then Exit;
i := SendMessage(hMemo1,EM_GETSEL, 0, 0);
CurPos := HIWORD(i);
if CurPos > 1 then
Delete(MemoStr, 1, CurPos);
if Whole then
This := ' '+This+' ';
ThisLgn := Length(This);
if ThisLgn < 1 then Exit;
if MatchCase then
i := Pos(This,MemoStr)
else i := Pos(UpperCase(This),UpperCase(MemoStr));
if i = 0 then
begin
MessageBox(hForm1, 'Searched from the Cursor to the end of document and Could NOT find text',
'NOT There', MB_OK or MB_ICONINFORMATION);
Exit;
end;
SendMessage(hMemo1, EM_SETSEL, CurPos+i-1, CurPos+ i+ThisLgn-1);
SendMessage(hMemo1, EM_SCROLLCARET, 0, 0);
SetFocus(hMemo1);
SetLineNum;
end;
procedure FindIt(New: Boolean);
var
CurPos: Integer;
MemoStr: String;
begin
{sets up the FindReplace record for the
FindText function}
MemoStr := GetWindowStr(hMemo1);
if Length(MemoStr) < 16 then Exit;
if New then
begin
CurPos := SendMessage(hMemo1,EM_GETSEL, 0, 0);
if Loword(CurPos) <> HIWORD(CurPos) then
begin
MemoStr := Copy(MemoStr,Loword(CurPos)+1,HIWORD(CurPos)-Loword(CurPos));
StrLCopy(FindTextA, PChar(MemoStr), SizeOf(FindTextA)-1);
end else FindTextA := ' '#0;
{At this program's "begin" the
FindRel.lpstrFindWhat := FindTextA;
was set. Making the Charater values of lpstrFindWhat those of FindTextA.
Now any changes to FindTextA will be in FindRelp.lpstrFindWhat}
FindRelp.lStructSize := SizeOf(FindRelp);
FindRelp.hWndOwner := hForm1;
FindRelp.hInstance := 0;
FindRelp.Flags := FR_DOWN{ or FR_NOMATCHCASE};
{FindRel.lpstrReplaceWith := RelCh;}
{FindRel.lpfnHook := FindReplaceDialogHook;}
{FindRel.wReplaceWithLen := 1;}
hFindWnd := FindText(FindRelp);
end else
SearchFor(FindTextA,(FindRelp.Flags and (not FR_DOWN)) <> FindRelp.Flags,
FindRelp.Flags and (not FR_MATCHCASE) <> FindRelp.Flags,
FindRelp.Flags and (not FR_WHOLEWORD) <> FindRelp.Flags);
{you can use FindRelp.lpstrFindWhat or FindTextA in SearchFor( )
since they are the same Block of memory}
MemoStr := '';
end;
procedure InsertDate;
var
TimeRec: TSystemTime;
Time, DoStr, DoStr2: String;
begin
GetLocalTime(TimeRec);
if (TimeRec.wHour = 24) then
begin
Time := Int2Str(TimeRec.wHour-12);
DoStr := ' AM ';
end else
if (TimeRec.wHour > 11) then
begin
if TimeRec.wHour = 12 then
Time := Int2Str(TimeRec.wHour) else
Time := Int2Str(TimeRec.wHour-12);
DoStr := ' PM ';
end else
begin
Time := Int2Str(TimeRec.wHour);
DoStr := ' AM ';
end;
if TimeRec.wMinute <10 then
DoStr := Time+':'+ '0'+Int2Str(TimeRec.wMinute)+DoStr
else
DoStr := Time+':'+ Int2Str(TimeRec.wMinute)+DoStr;
Time := Int2Str(TimeRec.wYear);
Delete(Time,1,2);
Time := DoStr+Int2Str(TimeRec.wMonth)+'/'+Int2Str(TimeRec.wDay)+ '/'+Time;
SendMessage(hMemo1,EM_REPLACESEL, 1, Integer(@Time[1]));
Time := '';
DoStr := '';
DoStr2 := '';
end;
function Memo1Proc(hWnd, Msg, WParam, LParam: Integer): Integer; stdcall;
begin
case Msg of
WM_LBUTTONUP: SetLineNum;
WM_DROPFILES: begin
CallWindowProc(PMemo1Proc, hWnd, Msg, wParam, lParam);
DropedOn(WParam);
Result := 0;
Exit;
end;
WM_KEYDOWN: if wParam = VK_F3 then
begin
if Length(FindRelp.lpstrFindWhat) = 0 then
FindIt(True) else FindIt(False);
end else
if wParam = VK_F5 then InsertDate;
end;
Result := CallWindowProc(PMemo1Proc, hWnd, Msg, wParam, lParam);
end;
procedure FontReg(LogFont: TLogFont);
var
RegKey: HKey;
Name, FaceName: PChar;
RegValue: Integer;
begin
RegKey := OpenRegKey;
if RegKey <> 0 then
begin
FaceName := LogFont.lfFaceName;
Name := 'FontFace';
Write2Reg(RegKey, Name, FaceName, StrLen(FaceName)+1, REG_SZ);
Name := 'FontSize';
RegValue := LogFont.lfHeight;
Write2Reg(RegKey, Name, @RegValue, SizeOf(Integer),REG_DWORD );
Name := 'FontWeight';
RegValue := LogFont.lfWeight;
Write2Reg(RegKey, Name, @RegValue, SizeOf(Integer),REG_DWORD );
Name := 'FontVar';
Arry4Byte[0] := FontLog.lfPitchAndFamily;
Arry4Byte[1] := FontLog.lfCharSet;
Arry4Byte[2] := FontLog.lfClipPrecision;
Arry4Byte[3] := FontLog.lfItalic;
RegValue := Integer(Arry4Byte);
Write2Reg(RegKey, Name, @RegValue, SizeOf(Integer),REG_DWORD );
RegCloseKey(RegKey);
end;
end;
procedure GetFont;
var
ChooseFont1: TChooseFont;
TempFont: Cardinal;
begin
with ChooseFont1 do
begin
lStructSize := SizeOf(ChooseFont1);
hWndOwner := hForm1;
hDC := 0;
lpLogFont := @FontLog;
iPointSize := 0;
nSizeMax := 24;
nSizeMin := 6;
Flags := CF_INITTOLOGFONTSTRUCT or CF_FORCEFONTEXIST or CF_LIMITSIZE or CF_SCREENFONTS;
lpfnHook := nil;
end;
if ChooseFont(ChooseFont1) then
begin
FontLog.lfOutPrecision := OUT_TT_PRECIS;
FontLog.lfQuality := ANTIALIASED_QUALITY;
FontLog.lfUnderline := 0;
FontLog.lfStrikeOut := 0;
TempFont := CreateFontIndirect(FontLog);
SendMessage(hMemo1,WM_SETFONT,TempFont,0);
SendMessage(hMemo1, EM_SETMARGINS, EC_LEFTMARGIN or EC_RIGHTMARGIN, MAKELONG(4, 4));
DeleteObject(Font1);
Font1 := TempFont;
FontReg(FontLog);
InvalidateRect(hMemo1,nil,True);
end;
end;
procedure WordWrap;
var
MemoText: String;
SelPos: Cardinal;
Modi: Boolean;
begin
MemoText := GetWindowStr(hMemo1);
if SendMessage(hMemo1,EM_GETMODIFY,0,0) = 1 then
Modi := True else Modi := False;
SetWindowLong(hMemo1, GWL_WNDPROC, Longint(PMemo1Proc));
SelPos := SendMessage(hMemo1,EM_GETSEL, 0, 0);
GetClientRect(hForm1,Rect1);
DestroyWindow(hMemo1);
if Wrap then
begin
hMemo1 := CreateWindowEx(WS_EX_CLIENTEDGE, 'Edit', nil,
WS_VISIBLE or WS_CHILD or WS_VSCROLL or ES_LEFT or ES_MULTILINE or
ES_AUTOVSCROLL or ES_AUTOHSCROLL or WS_HSCROLL,
0,0,Rect1.Right,Rect1.Bottom-22,hForm1,0,hInstance,nil);
CheckMenuItem(menuEdit,mID_Wrap, MF_UNCHECKED);
Wrap := False;
end else
begin
hMemo1:=CreateWindowEx(WS_EX_CLIENTEDGE, 'Edit', nil, WS_VISIBLE or WS_CHILD or
WS_VSCROLL or ES_LEFT or ES_MULTILINE or ES_AUTOVSCROLL,
0,0,Rect1.Right,Rect1.Bottom-22,hForm1,0,hInstance,nil);
CheckMenuItem(menuEdit,mID_Wrap, MF_CHECKED);
Wrap := True;
end;
PMemo1Proc := Pointer(SetWindowLong(hMemo1, GWL_WNDPROC, Longint(@Memo1Proc)));
SendMessage(hMemo1,WM_SETFONT,Font1,0);
SendMessage(hMemo1, EM_SETMARGINS, EC_LEFTMARGIN or EC_RIGHTMARGIN, MAKELONG(4, 4));
SetWindowText(hMemo1, @MemoText[1]);
SendMessage(hMemo1,EM_SETSEL, LOWORD(SelPos), HIWORD(SelPos));
if Modi then
SendMessage(hMemo1,EM_SETMODIFY,1,0);
UpdateWindow(hMemo1);
SetFocus(hMemo1);
end;
procedure SetMenu;
{WM_INITMENUPOPUP message is sent before any menu popups are displayed.
This gets Info about Memo1 and Enables and disables
menu items}
var
More: Integer;
begin
if SendMessage(hMemo1,EM_CANUNDO, 0, 0) = 1 then
{EM_CANUNDO will see if Undo Info is there}
EnableMenuItem(menuEdit, mID_Undo, MF_ENABLED)
else EnableMenuItem(menuEdit, mID_Undo, MF_GRAYED);
if IsClipboardFormatAvailable(CF_TEXT) then
More := MF_ENABLED else More := MF_GRAYED;
EnableMenuItem(menuEdit, mID_Paste, More);
More := SendMessage(hMemo1,EM_GETSEL, 0, 0);
{Result of EM_GETSEL has the Start Select in the Loword
and End Select in the Hiword}
if Loword(More) = HIWORD(More) then
More := MF_GRAYED
else More := MF_ENABLED;
EnableMenuItem(menuEdit, mID_Copy, More);
EnableMenuItem(menuEdit, mID_Cut, More);
EnableMenuItem(menuEdit, mID_Del, More);
if GetWindowTextLength(hMemo1) = 0 then
More := MF_GRAYED
else More := MF_ENABLED;
EnableMenuItem(menuEdit, mID_SelAll, More);
EnableMenuItem(menuFile, mID_PageSetup, More);
end;
function Ask2Save: Boolean;
var
Re: Integer;
begin
Result := False;
if SendMessage(hMemo1,EM_GETMODIFY,0,0) = 1 then
begin
Re := MessageBox(hForm1,'The text in this document has been changed,'#10+
'Do you want to save this document to file? ?',
'Save this document ? ?', MB_YESNOCANCEL or MB_ICONQUESTION);
if Re = IDCANCEL then
Result := True
else
if Re = IDYES then
if CurrentFile = '?' then
SaveIt(True) else
SaveIt(False);
end;
end;
function MessageProc(hWnd, Msg, WParam, LParam: Integer): Integer; stdcall;
begin
Result := 0;
if Msg = FindMess then
begin
if (FindRelp.Flags and (not FR_DIALOGTERM)) <> FindRelp.Flags then
hFindWnd := 0;
if (FindRelp.Flags and (not FR_FINDNEXT)) <> FindRelp.Flags then
SearchFor(FindRelp.lpstrFindWhat,(FindRelp.Flags and (not FR_DOWN)) <> FindRelp.Flags,
FindRelp.Flags and (not FR_MATCHCASE) <> FindRelp.Flags,
FindRelp.Flags and (not FR_WHOLEWORD) <> FindRelp.Flags);
end;
case Msg of
WM_DESTROY: ShutDown;
WM_COMMAND: if lParam = 0 then
begin
case LOWORD(wParam) of
{the menu ID number is in the LOWORD position of wParam}
mID_New: begin
if Ask2Save then Exit;
CurrentFile := '?';
SetWindowText(hMemo1,'');
SetWindowText(hForm1,'New1 -Test Text');
end;
mID_Open: begin
if Ask2Save then Exit;
OpenTextFile;
end;
mID_Save: begin
if CurrentFile = '?' then
SaveIt(True) else
SaveIt(False);
end;
mID_SaveAs: SaveIt(True);
mID_Print: PrintMe;
mID_PageSetup: SetUpPage;
mID_Exit: PostMessage(hForm1,WM_CLOSE,0,0);
mID_Undo: SendMessage(hMemo1, EM_UNDO, 0, 0);
mID_Copy: SendMessage(hMemo1, WM_COPY, 0, 0);
mID_Cut: SendMessage(hMemo1, WM_CUT, 0, 0);
mID_Paste: SendMessage(hMemo1, WM_PASTE, 0, 0);
mID_Del: SendMessage(hMemo1, WM_CLEAR, 0, 0);
mID_SelAll: SendMessage(hMemo1, EM_SETSEL, 0, -1);
mID_Date: InsertDate;
mID_Wrap: WordWrap;
mID_Font: GetFont;
mID_Find: FindIt(True);
mID_FindNext: FindIt(False);
end;
end else
if (lParam = hMemo1) and (HIWORD(wParam) = EN_CHANGE) then SetLineNum;
WM_CLOSE: if Ask2Save then Exit;
WM_DROPFILES:
begin
DropedOn(wParam);
Exit;
end;
WM_INITMENUPOPUP: SetMenu;
WM_SETFOCUS:
begin
SetFocus(hMemo1);
Exit;
end;
WM_SIZE:
begin
MoveWindow(hMemo1,0,0,LOWORD(lParam),HIWORD(lParam)-22,True);
MoveWindow(hLineNum,1,HIWORD(lParam)-20,66,20,True);
MoveWindow(hStatus,68,HIWORD(lParam)-20,LOWORD(lParam)-68,20,True);
end;
end; // case
Result:=DefWindowProc(hWnd,Msg,wParam,lParam);
end;
procedure MyExit;
begin
ExitProc := PExitSave; // restore old proc first
CurrentFile := '';
DestroyWindow(hMemo1);
DestroyWindow(hLineNum);
DestroyWindow(hStatus);
DestroyWindow(hForm1);
end;
function GetRegVSize(const CKey: HKey; const Name: PChar; Check: Integer): Integer;
begin
if (RegQueryValueEx(CKey, Name, nil, @DataType, nil,
@Result) <> ERROR_SUCCESS) or (Check <> DataType) then
Result := 0;
end;
function ReadReg(CKey: HKey; const Name: PChar; Buffer: Pointer;
BufSize: Integer; Check: Integer): Boolean;
begin
Result := False;
if (RegQueryValueEx(CKey, Name, nil, @DataType, PByte(Buffer),
@BufSize) = ERROR_SUCCESS) and (Check = DataType) then
Result := True;
end;
begin // * * * * * * * Main Program begin
Wrap := False;
GotSetup := False;
ShowMax := False;
FindRelp.lpstrFindWhat := FindTextA;
{the FindRelp.lpstrFindWhat will be shown as a PChar variable,
but there is no Memory assigned to lpstrFindWhat in that variable,
it's just a Pointer. So you have to have an array of Char and set
lpstrFindWhat := ArrayOfChar
this sets the Pointer to ArrayOfChar - - Unlike A
PChar1 := PChar2
where the Charaters in PChar1 are set to the Charaters in PChar2
Now FindRelp.lpstrFindWhat and FindTextA use the same block of memory}
FindRelp.wFindWhatLen := SizeOf(FindTextA);
FindTextA[0] := #0;
CurrentFile := '?';
PntDrvName := '?';
SetRect(MinMarRect,250,250,250,500);
Top := (GetSystemMetrics(SM_CYSCREEN) div 2)-220;
Left := (GetSystemMetrics(SM_CXSCREEN) div 2)-310;
sHeight := 420;
sWidth := 620;
PExitSave := ExitProc;
ExitProc := @MyExit;
FontLog.lfHeight := -14;
FontLog.lfWidth := 0;
FontLog.lfWeight := FW_NORMAL;
FontLog.lfCharSet := ANSI_CHARSET;
FontLog.lfOutPrecision := OUT_TT_PRECIS;
FontLog.lfClipPrecision := CLIP_DEFAULT_PRECIS;
FontLog.lfQuality := ANTIALIASED_QUALITY;
FontLog.lfPitchAndFamily := FIXED_PITCH or FF_ROMAN;
FontLog.lfUnderline := 0;
FontLog.lfStrikeOut := 0;
FontLog.lfFaceName := 'Courier New';
PntDrvName := 'Mrial';
if RegOpenKeyEx(HKEY_CURRENT_USER, 'Software\TestText88', 0,
KEY_READ, TT88Key) = ERROR_SUCCESS then
begin
RegTemp := 8;
if ReadReg(TT88Key, 'Position', @RegTemp, SizeOf(Integer), REG_DWORD) then
begin
Left := LOWORD(RegTemp);
Top := HIWORD(RegTemp);
end;
if ReadReg(TT88Key, 'WindowSize', @RegTemp, SizeOf(Integer), REG_DWORD) then
begin
sHeight := LOWORD(RegTemp);
sWidth := HIWORD(RegTemp);
end;
if ReadReg(TT88Key, 'IsMax', @RegTemp, SizeOf(Integer), REG_DWORD) then
if RegTemp or SW_SHOWMAXIMIZED = RegTemp then ShowMax := True;
RegTemp := GetRegVSize(TT88Key, 'FontFace', REG_SZ);
if RegTemp >0 then
begin
if ReadReg(TT88Key, 'FontFace', @FaceNmA, RegTemp, REG_SZ) then
StrCopy(FontLog.lfFaceName,FaceNmA);
end;
if ReadReg(TT88Key, 'FontSize', @RegTemp, SizeOf(Integer), REG_DWORD) then
FontLog.lfHeight := RegTemp;
if ReadReg(TT88Key, 'FontWeight', @RegTemp, SizeOf(Integer), REG_DWORD) then
FontLog.lfWeight := RegTemp;
if ReadReg(TT88Key, 'FontVar', @RegTemp, SizeOf(Integer), REG_DWORD) then
begin
Integer(Arry4Byte) := RegTemp;
FontLog.lfPitchAndFamily := Arry4Byte[0];
FontLog.lfCharSet := Arry4Byte[1];
FontLog.lfClipPrecision := Arry4Byte[2];
FontLog.lfItalic := Arry4Byte[3];
{another way to Read separate Bytes is with LOBYTE and HYBYTE
FontLog.lfPitchAndFamily := LOBYTE(LOWORD(RegTemp));
FontLog.lfCharSet := HIBYTE(LOWORD(RegTemp));
FontLog.lfClipPrecision := LOBYTE(HIWORD(RegTemp));
FontLog.lfItalic := HIBYTE(HIWORD(RegTemp));}
end;
RegCloseKey(TT88Key);
end; {else Top := 444;}
Font1 := CreateFontIndirect(FontLog);
Font2 := CreateFont(-12,0,0,0,FW_NORMAL,0,0,0,ANSI_CHARSET,OUT_DEFAULT_PRECIS,
CLIP_DEFAULT_PRECIS,DEFAULT_QUALITY,VARIABLE_PITCH or FF_SWISS,'MS Sans Serif');
with wClass do
begin
hInstance := SysInit.hInstance;
hIcon:= LoadIcon(hInstance,'MAINICON');
lpfnWndProc:= @MessageProc;
hbrBackground:= COLOR_BTNFACE+1;
lpszClassName:= 'Text Class';
hCursor:= LoadCursor(0,IDC_ARROW);
end;
RegisterClass(wClass);
menuFile := CreateMenu();
InsertMenu(menuFile,0,MF_BYPOSITION or MF_STRING,mID_New,'&New');
InsertMenu(menuFile,1,MF_BYPOSITION or MF_STRING,mID_Open,'&Open');
InsertMenu(menuFile,2,MF_BYPOSITION or MF_STRING,mID_Save,'&Save');
InsertMenu(menuFile,3,MF_BYPOSITION or MF_STRING,mID_SaveAs,'Save &As');
InsertMenu(menuFile,4,MF_BYPOSITION or MF_SEPARATOR,1,nil);
InsertMenu(menuFile,6,MF_BYPOSITION or MF_STRING,mID_Print,'&Print');
InsertMenu(menuFile,5,MF_BYPOSITION or MF_STRING,mID_PageSetup,'Page Se&tup');
InsertMenu(menuFile,7,MF_BYPOSITION or MF_SEPARATOR,1,nil);
InsertMenu(menuFile,8,MF_BYPOSITION or MF_STRING,mID_Exit,'E&xit');
menuEdit := CreateMenu();
InsertMenu(menuEdit,0,MF_BYPOSITION or MF_STRING,mID_Undo,'&Undo Ctrl+Z');
InsertMenu(menuEdit,1,MF_BYPOSITION or MF_SEPARATOR,1,nil);
InsertMenu(menuEdit,2,MF_BYPOSITION or MF_STRING,mID_Copy,'&Copy Ctrl+C');
InsertMenu(menuEdit,3,MF_BYPOSITION or MF_STRING,mID_Cut,'Cu&t Ctrl+X');
InsertMenu(menuEdit,4,MF_BYPOSITION or MF_STRING,mID_Paste,'&Paste Ctrl+V');
InsertMenu(menuEdit,5,MF_BYPOSITION or MF_STRING,mID_Del,'Delete Del');
InsertMenu(menuEdit,6,MF_BYPOSITION or MF_SEPARATOR,1,nil);
InsertMenu(menuEdit,7,MF_BYPOSITION or MF_STRING,mID_SelAll,'Select &All');
InsertMenu(menuEdit,8,MF_BYPOSITION or MF_STRING,mID_Date,'Time/&Date F5');
InsertMenu(menuEdit,9,MF_BYPOSITION or MF_SEPARATOR,1,nil);
InsertMenu(menuEdit,10,MF_BYPOSITION or MF_STRING,mID_Wrap,'&Word Wrap');
InsertMenu(menuEdit,11,MF_BYPOSITION or MF_STRING,mID_Font,'Set &Font');
menuSearch := CreateMenu();
InsertMenu(menuSearch,0,MF_BYPOSITION or MF_STRING,mID_Find,'&Find');
InsertMenu(menuSearch,1,MF_BYPOSITION or MF_STRING,mID_FindNext,'Find &Next F3');
MenuInfo.cbSize := SizeOf(MenuInfo);
MenuInfo.fMask := MIIM_ID or MIIM_SUBMENU or MIIM_TYPE;
MenuInfo.fType := MFT_STRING;
MenuInfo.fState := 0;
MenuInfo.dwTypeData := '&File';
MenuInfo.cch := 5;
MenuInfo.hSubMenu := menuFile;
MenuInfo.wID := 10;
MenuInfo.hbmpChecked := 0;
MenuInfo.hbmpUnchecked := 0;
menuMain := CreateMenu();
InsertMenuItem(menuMain,0,True,MenuInfo);
MenuInfo.dwTypeData := '&Edit';
MenuInfo.hSubMenu := menuEdit;
MenuInfo.wID := 11;
InsertMenuItem(menuMain,1,True,MenuInfo);
MenuInfo.dwTypeData := '&Search';
MenuInfo.hSubMenu := menuSearch;
MenuInfo.cch := 7;
MenuInfo.wID := 12;
InsertMenuItem(menuMain,2,True,MenuInfo);
hForm1 := CreateWindow(wClass.lpszClassName,'New1 -Test Text',WS_OVERLAPPEDWINDOW,
Left, Top,sWidth,sHeight,0,menuMain,hInstance,nil);
if hForm1 = 0 then
begin
Exit;
end;
GetClientRect(hForm1,Rect1);
hMemo1:=CreateWindowEx(WS_EX_CLIENTEDGE, 'Edit', nil,
WS_VISIBLE or WS_CHILD or WS_VSCROLL or ES_LEFT or ES_MULTILINE
or ES_AUTOVSCROLL or ES_AUTOHSCROLL or WS_HSCROLL {or ES_WANTRETURN},
0,0,Rect1.Right,Rect1.Bottom-40,hForm1,0,hInstance,nil);
SendMessage(hMemo1,WM_SETFONT,Font1,0);
SendMessage(hMemo1, EM_SETMARGINS, EC_LEFTMARGIN or EC_RIGHTMARGIN, MAKELONG(4, 4));
hLineNum := CreateWindowEx(WS_EX_CLIENTEDGE, 'Static', ' 1: 1',
WS_VISIBLE or WS_CHILD or SS_NOPREFIX or SS_CENTER,
0, Rect1.Bottom-20, 49,20, hForm1, 0, hInstance,nil);
SendMessage(hLineNum,WM_SETFONT,Font2,0);
hStatus := CreateWindowEx(WS_EX_CLIENTEDGE, 'Static', ' New1',
WS_VISIBLE or WS_CHILD or SS_LEFTNOWORDWRAP or SS_NOPREFIX,
51, Rect1.Bottom-20, Rect1.Right,20, hForm1, 0, hInstance,nil);
SendMessage(hStatus,WM_SETFONT,Font2,0);
PMemo1Proc := Pointer(SetWindowLong(hMemo1, GWL_WNDPROC, Longint(@Memo1Proc)));
DragAcceptFiles(hForm1,True);
DragAcceptFiles(hMemo1,True);
FindMess := RegisterWindowMessage(FINDMSGSTRING);
hFindWnd := 0;
if ParamStr(1)<> '' then
if FileExists(ParamStr(1)) then
File2Memo(ParamStr(1));
{ParamStr(1) tests for command line file name and loads the
file if it exists}
if ShowMax then
ShowWindow(hForm1, SW_SHOWMAXIMIZED)
else ShowWindow(hForm1, SW_SHOWDEFAULT);
while GetMessage(mainMsg,0,0,0) do
begin
TranslateMessage(mainMsg);
DispatchMessage(mainMsg);
end;
end.
|
Next
The next program uses a listbox and textdraw functions with the WM_PAINT message for a Post some Notes program.
PostNote

H O M E 