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