function IsEMail(EMail: String): Boolean;
var s: String; ETpos: Integer;
begin
ETpos:= pos('@', EMail);
if ETpos > 1 then begin
s:= copy(EMail,ETpos+1,Length(EMail));
if (pos('.', s) > 1) and (pos('.', s) < length(s)) then
Result:= true else Result:= false;
end else Result:= false;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if isemail(Edit1.Text) then begin
ShowMessage('eMail-Adresse!');
end; end ;
Na formatce założyc objekty: ListBox1, Edit1, Edit2, Edit3, Button1.
Program generuje 6 liczb z przedziału 1-49; liczby dublowane są automatycznie usuwane.
W OnCreate wpisać ... Randomize dla inicjacji generatora liczb a dalej:
procedure TForm1.Button1Click(Sender: TObject);
var MyList: TStringList; Times, I, Number: Integer; cInt, cLen: string;
begin
// make the button disabled to prevent multiple clicks
Self.enabled := False; // convert the highest number
Number := StrToInt(Edit2.Text); // this creates the correct format-argument for every
// max-numbers (e.g. 49 , 120, 9999 ....)
cLen := IntToStr(length(trim(Edit2.text)) + 1); MyList := TStringList.Create;
try // first clear the Listbox
Listbox1.clear; // here we start a new serie
for Times := 1 to StrToInt(Edit3.Text) do begin
// we go thru this while-loop until the max-numbers
// are created. Not every loop creates an entry
// to the list because double numbers are ignored.
while MyList.Count < StrToInt(Edit1.Text) do begin // get a new random number
I := Random(Number); if (I > 0) then begin
// cLen has the number of chars from max-number plus one
// e.g. if max-number is 49 cLen is 3 if max-number is 111 cLen is 4
// if max-number is 9999 cLen is 5 this formatting is needed for the correct
// sorting of all List-Entries
cInt := Format('%' + cLen + '.1d', [I]); // here we look at double entries and ignore it
if (MyList.IndexOf(cInt) < > -1) then continue;
// now we add a new randomnumber
MyList.Add(cInt);
end; end; cInt := ''; // max-numbers are created now we sort it
MyList.Sort; // and put it all into Listbox
for I := 0 to MyList.Count - 1 do cInt := cInt + MyList.Strings[I];
ListBox1.Items.Add(cInt); // clear MyList for the next serie
MyList.clear;
end; finally MyList.Free; end; // make the button enable for the next click
Self.enabled := True;
end;
W komputerze musi byc zainstalowany Adobe Acrobat (można go pobrać ze strony: www.adobe.com).
Następnie należy zainstalować w Delphi blbliotekę z Acrobat (Project -> Import Type Library) wybierz "Acrobat Control for ActiveX (version x)". Gdzie x jest aktualną wersją biblioteki. Klik na klawiszu kończy operację.
Po restarcie Delphi na palecie komponentów jest widoczny ten komponent jako TPDF. A niżej przykład jego użycia:
procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then pdf1.src := OpenDialog1.FileName;
end;
W bibliotece (plik PdfLib_TLB) kod tej klasy wygląda jak niżej:
TPdf = class(TOleControl)
private
FIntf: _DPdf;
function GetControlInterface: _DPdf;
protected
procedure CreateControl;
procedure InitControlData; override;
public
function LoadFile(const fileName: WideString): WordBool;
procedure setShowToolbar(On_: WordBool);
procedure gotoFirstPage;
procedure gotoLastPage;
procedure gotoNextPage;
procedure gotoPreviousPage;
procedure setCurrentPage(n: Integer);
procedure goForwardStack;
procedure goBackwardStack;
procedure setPageMode(const pageMode: WideString);
procedure setLayoutMode(const layoutMode: WideString);
procedure setNamedDest(const namedDest: WideString);
procedure Print;
procedure printWithDialog;
procedure setZoom(percent: Single);
procedure setZoomScroll(percent: Single; left: Single; top: Single);
procedure setView(const viewMode: WideString);
procedure setViewScroll(const viewMode: WideString; offset: Single);
procedure setViewRect(left: Single; top: Single; width: Single; height: Single);
procedure printPages(from: Integer; to_: Integer);
procedure printPagesFit(from: Integer; to_: Integer; shrinkToFit: WordBool);
procedure printAll;
procedure printAllFit(shrinkToFit: WordBool);
procedure setShowScrollbars(On_: WordBool);
procedure AboutBox;
property ControlInterface: _DPdf read GetControlInterface;
property DefaultInterface: _DPdf read GetControlInterface;
published
property TabStop;
property Align;
property DragCursor;
property DragMode;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property TabOrder;
property Visible;
property OnDragDrop;
property OnDragOver;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnStartDrag;
property src: WideString index 1 read GetWideStringProp write SetWideStringProp stored False;
end;
Aby aplikacja ta funkcjonowała u użytkowników muszą oni posiadać u siebie zainstalowany Acrobat Reader.
Z reguły to robi się przy pomocy tablicy ale można prościej:
Function RemoveHTMLTags( FromWhere : String ) : String;
Var IdX : Integer; IdY : Integer; ForceExit : Boolean;
Begin
Result := FromWhere; ForceExit := False;
Repeat
IdX := Pos( '<', Result ); IdY := Pos( '>', Result );
If ( ( IdX > 0 ) And ( IdY > IdX ) ) Then Begin
Result := Copy( Result, 1, ( IdX - 1 ) ) + Copy( Result, ( IdY + 1 ), MaxInt );
End Else Begin ForceExit := True;
End; Until ( ( IdX = 0 ) Or ( IdY = 0 ) Or ( ForceExit ) );
End;
function TfrmPWGenerate.btnGenerateClick(Sender: TObject): string;
{max length of generated password}
const intMAX_PW_LEN = 10;
var i: Byte; s: string;
begin
{if you want to use the 'A..Z' characters}
if cbAZ.Checked then s := 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
else s := ''; {if you want to use the 'a..z' characters}
if cbAZSmall.Checked then s := s + 'abcdefghijklmnopqrstuvwxyz';
{if you want to use the '0..9' characters}
if cb09.Checked then s := s + '0123456789';
if s = '' then exit;
Result := '';
for i := 0 to intMAX_PW_LEN-1 do Result := Result + s[Random(Length(s)-1)+1];
end;
initialization Randomize;
A takie będą wyniki: IBbfA1mVK2 tmuXIuQJV5 oNEY1cF6xB flIUhfdIui mxaK71dJaq B0YTqxdaLh
// Pozycja łańcucha począwszy od końca
function LastPos(SearchStr, Str: string): Integer;
var i: Integer; TempStr: string;
begin
Result := Pos(SearchStr, Str); if Result = 0 then Exit;
if (Length(Str) > 0) and (Length(SearchStr) > 0) then
begin
for i := Length(Str) + Length(SearchStr) - 1 downto Result do
begin
TempStr := Copy(Str, i, Length(Str)); if Pos(SearchStr, TempStr) > 0 then
begin
Result := i; break; end; end; end;
end;
// Szukanie następnego ciągu znaków z określonej pozycji.
function NextPos(SearchStr, Str: string; Position: Integer): Integer;
begin
Delete(Str, 1, Position - 1); Result := Pos(SearchStr, upperCase(Str));
if Result = 0 then Exit;
if (Length(Str) > 0) and (Length(SearchStr) > 0) then
Result := Result + Position + 1;
end;
// pobiera liczbę znaków z pewnej pozycji jako ciąg do szukania.
function NextPosRel(SearchStr, Str: string; Position: Integer): Integer;
begin
Delete(Str, 1, Position - 1); Result := Pos(SearchStr, UpperCase(Str)) - 1;
end;
// prosta zamiana w stringach.
function ReplaceStr(Str, SearchStr, ReplaceStr: string): string;
begin
while Pos(SearchStr, Str) < > 0 do
begin
Insert(ReplaceStr, Str, Pos(SearchStr, Str));
Delete(Str, Pos(SearchStr, Str), Length(SearchStr));
end; Result := Str;
end;
Wersja 1:
function ReverseString(s: string): string;
var i: integer;
begin
Result := ''; if Trim(s) < > '' then
for i := Length(s) downto 1 do Result := Result + s[i];
end;
Wersja 2:
function ReverseString(s: string): string;
var i: integer; c: char;
begin
if s < > '' then for i := 1 to Length(s) div 2 do
begin
c := s[i]; s[i] := s[Length(s) + 1 - i]; s[Length(s) + 1 - i] := c; end;
Result := s;
end;
Wersja 3:
function ReverseString1(const s: string): string;
var i, len: Integer;
begin
len := Length(s); SetLength(Result, len);
for i := len downto 1 do
begin
Result[len - i + 1] := s[i]; end;
end;
Wersja 4 autor Ido Kanner :
function ReverseString2(const Str: string): string;
var ch: Char; i, Size: Integer;
begin
Result := Str; Size := Length(Result); if (Size >= 2) then // 2 lub więcej znaków
begin
for i := 1 to (Size div 2) do
begin
ch := Result[i]; Result[i] := Result[Size - (i - 1)]; Result[Size - (i - 1)] := ch;
end end; end;
Wersja 5 autor Rudy Velthuis :
function ReverseString3(S: string): string;
var P, Q: PChar; C: Char;
begin
Result := S; if Length(Result) = 0 then Exit; P := PChar(Result);
Q := P + Length(Result) - 1; while P < Q do
begin
C := P^; P^ := Q^; Q^ := C; Inc(P); Dec(Q); end;
end;
Wersja 6 autor Rudy Velthuis:
procedure ReverseString4(var S: string);
var P, Q: PChar; C: Char;
begin
if Length(S) = 0 then Exit; P := PChar(S); Q := P + Length(S) - 1;
while P < Q do
begin
C := P^; P^ := Q^; Q^ := C; Inc(P); Dec(Q); end;
end;
type T2DBooleanArray = array of array of Boolean;
procedure Save2DBooleanArray(const A: T2DBooleanArray; S: TStream);
var writer: TWriter; i: Integer;
begin
Assert(Assigned(S)); writer := TWriter.Create(S, 8096);
try
writer.WriteInteger(Length(A)); for i := 0 to Length(A) - 1 do
begin
writer.WriteInteger(Length(A[i])); writer.Write(A[i, 0], Length(A[i]) * sizeof(A[i, 0]));
end; { For }
finally writer.Free; end; { Finally }
end;
procedure Load2DBooleanArray(var A: T2DBooleanArray; S: TStream);
var reader: TReader; i, numrows, numcols: Integer;
begin
Assert(Assigned(S)); reader := TReader.Create(S, 8096);
try numrows := reader.ReadInteger; SetLength(A, numrows);
for i := 0 to numrows - 1 do
begin
numcols := reader.ReadInteger; SetLength(A[i], numcols);
reader.Read(A[i, 0], numcols * sizeof(A[i, 0]));
end; { For }
finally reader.Free; end; { Finally }
end;
uses ZLib;
{ kompresja streamu}
procedure CompressStream(inpStream, outStream: TStream);
var InpBuf, OutBuf: Pointer; InpBytes, OutBytes: Integer;
begin
InpBuf := nil; OutBuf := nil;
try
GetMem(InpBuf, inpStream.Size); inpStream.Position := 0;
InpBytes := inpStream.Read(InpBuf^, inpStream.Size);
CompressBuf(InpBuf, InpBytes, OutBuf, OutBytes);
outStream.Write(OutBuf^, OutBytes);
finally
if InpBuf < > nil then FreeMem(InpBuf); if OutBuf < > nil then FreeMem(OutBuf);
end; end;
{ Dekompresja streamu }
procedure DecompressStream(inpStream, outStream: TStream);
var InpBuf, OutBuf: Pointer; OutBytes, sz: Integer;
begin
InpBuf := nil; OutBuf := nil;
sz := inpStream.Size - inpStream.Position; if sz > 0 then
try
GetMem(InpBuf, sz); inpStream.Read(InpBuf^, sz);
DecompressBuf(InpBuf, sz, 0, OutBuf, OutBytes);
outStream.Write(OutBuf^, OutBytes);
finally
if InpBuf < > nil then FreeMem(InpBuf); if OutBuf < > nil then FreeMem(OutBuf);
end; outStream.Position := 0;
end;
{ przykład kompresji tekstu RichEdit1 i zapis do pliku ms2.dat }
procedure TForm1.Button1Click(Sender: TObject);
var ms1, ms2: TMemoryStream;
begin
ms1 := TMemoryStream.Create; try ms2 := TMemoryStream.Create;
try
RichEdit1.Lines.SaveToStream(ms1); CompressStream(ms1, ms2);
ShowMessage(Format('Stream Compression Rate: %d %%',
[round(100 / ms1.Size * ms2.Size)]));
ms2.SaveToFile('C:ms2.dat');
finally ms1.Free; end; finally ms2.Free; end;
end;
{ i odczyt streamu z pliku ms2.dat do RichEdit1. }
procedure TForm1.Button2Click(Sender: TObject);
var ms1, ms2: TMemoryStream;
begin
ms1 := TMemoryStream.Create; try ms2 := TMemoryStream.Create;
try
ms1.LoadFromFile('C:ms2.dat'); DecompressStream(ms1, ms2);
RichEdit1.Lines.LoadFromStream(ms2);
finally ms1.Free; end; finally ms2.Free; end;
end;
procedure ScanDir(StartDir: string; Mask:string; List:TStrings);
var SearchRec : TSearchRec;
begin
if Mask = '' then Mask := '*.*';
if StartDir[Length(StartDir)] < > '\' then StartDir := StartDir + '\';
if FindFirst(StartDir+Mask, faAnyFile, SearchRec) = 0 then
begin repeat
Application.ProcessMessages;
if (SearchRec.Attr and faDirectory) < > faDirectory then
List.Add(StartDir + SearchRec.Name)
else if (SearchRec.Name < > '..') and (SearchRec.Name < > '.') then
begin
List.Add(StartDir + SearchRec.Name + '\');
ScanDir(StartDir + SearchRec.Name + '\',Mask,List);
end;
until FindNext(SearchRec) < > 0; FindClose(SearchRec); end;
end;
Przykład wywołania z połączeniem parametrów:
1. nazwa folderu
2. maska - domyślnie *.*
3. miejsce przechowywania rezultatów - wszelkie pochodne TString, takich jak TStringList
procedure TForm1.Button1Click(Sender: TObject);
begin
ListBox1.Items.Clear; ScanDir('c:','',ListBox1.Items);
Label1.Caption := IntToStr(ListBox1.Items.Count);
end;
Wariant1:
program Project1;
uses Forms, Windows, // koniecznie dopisać
Unit1 in 'Unit1.pas' {Form1};
{$R *.RES}
var HM: THandle;
function Check: boolean;
begin
HM := OpenMutex(MUTEX_ALL_ACCESS, false, 'MyOwnMutex');
Result := (HM < > 0);
if HM = 0 then
HM := CreateMutex(nil, false, 'MyOwnMutex');
end;
begin
if Check then Exit;
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
Wariant 2:
program Previns;
uses WinTypes, WinProcs, SysUtils, Forms, Uprevins in 'UPREVINS.PAS' {Form1};
{$R *.RES}
type PHWND = ^HWND;
function EnumFunc(Wnd: HWND; TargetWindow: PHWND): bool; export;
var ClassName: array[0..30] of char;
begin
Result := true; if GetWindowWord(Wnd, GWW_HINSTANCE) = hPrevInst then
begin
GetClassName(Wnd, ClassName, 30); if StrIComp(ClassName, 'TApplication') = 0 then
begin
TargetWindow^ := Wnd; Result := false; end; end;
end;
procedure GotoPreviousInstance;
var PrevInstWnd: HWND;
begin
PrevInstWnd := 0; EnumWindows(@EnumFunc, Longint(@PrevInstWnd));
if PrevInstWnd < > 0 then if IsIconic(PrevInstWnd) then
ShowWindow(PrevInstWnd, SW_RESTORE)
else BringWindowToTop(PrevInstWnd); end;
begin
if hPrevInst < > 0 then GotoPreviousInstance
else begin
Application.CreateForm(TForm1, Form1);
Application.Run;
end;
end.
Wariant 3:
...
uses syncobjs;
...
var CheckEvent: TEvent;
...
procedure TForm1.FormCreate(Sender: TObject);
begin
CheckEvent := TEvent.Create(nil, false, true, 'MYPROGRAM_CHECKEXIST');
if CheckEvent.WaitFor(10) < > wrSignaled then
begin
// tutaj możemy dać komunikat jeżeli kopia jest uruchomiona.
Self.Close; // i zakończyć program albo zrobić coś innego.
end; end;
Wariant 4:
program Project1;
uses Forms, Windows, Unit1 in 'Unit1.pas' {Form1};
{$R *.RES}
var hwnd: THandle;
begin
hwnd := FindWindow('TForm1', 'Form1'); if hwnd = 0 then
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end else SetForegroundWindow(hwnd)
end.
Wariant5:
program pds;
uses Windows, Forms, Main in 'MAIN.PAS' {MainForm};
const MemFileSize = 127; MemFileName = 'one_example';
var MemHnd: HWND;
{$R *.RES}
begin
MemHnd := CreateFileMapping(HWND($FFFFFFFF), nil,
PAGE_READWRITE, 0, MemFileSize, MemFileName);
if GetLastError < > ERROR_ALREADY_EXISTS then
begin
Application.Initialize;
with TForm1.Create(nil) do
try Show; Update;
Application.CreateForm(TMainForm, MainForm);
finally Free; end; Application.Run;
end else
Application.MessageBox('Aplikacja jest już uruchomiona. Kliknij OK aby kontynuować', MB_OK);
CloseHandle(MemHnd);
end.
//widoczny/ ukryty kursor na formie
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowCursor(False); // ukryty kursor
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
ShowCursor(True); // widoczny kursor
end;
Pokaz tekstu formy z użyciem procedury ObjectBinaryToText, która przekształca dwójkową reprezentację obiektu w tekst.
procedure TForm1.Button1Click(Sender: TObject);
var Source: TResourceStream; Dest: TMemoryStream;
begin
Source:=TResourceStream.Create(hInstance, 'TFORM1', RT_RCDATA);
Dest:=TMemoryStream.Create; Source.Position := 0;
ObjectBinaryToText(Source, Dest); Dest.Position := 0;
Memo1.Lines.LoadFromStream(Dest);
end;
Pokaz logo programu podczas startu - Logo jest zwykłą formą. Umieść Image1 i Timer1 na Form1 -- to będzie logo. W pliku .DPR projektu usuń linie: Application.CreateForm (TForm2, Form2);
(* to dla Form1 *)
procedure TForm1.FormActivate(Sender: TObject);
begin
Image1.Picture.LoadFromFile(' c:\...\factory.bmp');
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
Form1.Hide; Form2:=TForm2.Create(nil);
with TForm2.Create(nil) do Show;
end;
(*to dla Form2 *)
procedure TForm2.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Form1.Close;
end;
Dynamiczne tworzenie formy z ustawieniem jej na (ClientOrigin to współrzędne ekranu w pikselach) określonej pozycji.
procedure TForm1.Button1Click(Sender: TObject);
var NewForm: TForm2;
begin
NewForm:=TForm2.Create(nil);
try NewForm.Left:=ActiveControl.Width+ ActiveControl.Left+ ClientOrigin.X;
NewForm.Top:=ActiveControl.Top+ClientOrigin.Y;
NewForm.ShowModal;
finally NewForm.Release;
end; end;
Przywracanie okna do jego ostatniego stanu - poprzez zapis jego parametrów w Rejestrze po zamknięciu formy. Przywołany ponownie program odtworzy te parametry na ekranie.
uses Registry;
procedure TForm1.FormDestroy(Sender: TObject);
begin
with TRegistry.Create do
begin
RootKey:=HKEY_LOCAL_MACHINE;
if OpenKey('Greatis Software\Example\Form', True) then
begin
WriteInteger('Left', Form1.Left); WriteInteger('Top', Form1.Top);
WriteInteger('Width', Form1.Width); WriteInteger('Height', Form1.Height);
case WindowState of
wsMaximized: WriteInteger('State', 1); wsMinimized: WriteInteger('State', 2);
wsNormal : WriteInteger('State', 3);
end; end else
MessageDlg('Błąd odczytu rejestru', mtError, [mbOk], 0);
CloseKey;
end; end;
procedure TForm1.FormCreate(Sender: TObject);
begin
with TRegistry.Create do
begin
RootKey:=HKEY_LOCAL_MACHINE;
if OpenKey('Greatis Software\Example\Form', False) then
try
Form1.Left:=ReadInteger('Left'); Form1.Top:=ReadInteger('Top');
Form1.Width:=ReadInteger('Width'); Form1.Height:=ReadInteger('Height');
case ReadInteger('State') of
1: Form1.WindowState:=wsMaximized; 2: Form1.WindowState:=wsMinimized;
3: Form1.WindowState:=wsNormal;
end; except
MessageDlg('Nie można go odczytać', mtError, [mbOk], 0);
end else
MessageDlg('Błąd odczytu rejestru', mtError, [mbOk], 0);
CloseKey;
end; end;
Forma nieruchoma - niemożliwe jej przenoszenie poprzez zdarzenie - WM_NCHITTEST.
type TForm1 = class(TForm)
private { Private declarations }
procedure WMNCHITTEST(var Msg: TWMNCHitTest);
message WM_NCHITTEST;
public { Public declarations }
end;
...
procedure TForm1.WMNCHitTest(var Msg: TWMNCHitTest);
begin
DefaultHandler(Msg); if Msg.Result=HTCAPTION then Msg.Result:=0;
end;
Ukrycie tekstu na pasku formy
procedure TForm1.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params do Style:=(Style or WS_POPUP) and (not WS_DLGFRAME);
end;
Ukrycie tekstu na pasku opisu formularza MDIChild (forma potomna).
type TForm2 = class(TForm)
private { Private declarations }
procedure CreateParams(var Params: TCreateParams); override;
public { Public declarations }
end;
...
procedure TForm2.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params) ;
Params.Style:=Params.Style and (not WS_CAPTION) ;
end;
Ukrycie formularza potomnego MDIChild. w pliku projektu nie zapomnij usunąć linię Application.CreateForm (TForm2, Form2) .
var ChildForm: TForm;
...
procedure TForm1.New1Click(Sender: TObject);
begin
if not Assigned(ChildForm) then
begin
ChildForm:=TForm2.Create(Application);
ChildForm.Caption:='ChildForm';
end; end;
procedure TForm1.Hide1Click(Sender: TObject);
begin
if Assigned(ChildForm) then
ShowWindow(ChildForm.Handle, SW_HIDE);
end;
procedure TForm1.Show1Click(Sender: TObject);
begin
if Assigned(ChildForm) then
SetWindowPos(ChildForm.Handle, HWND_TOP, 0, 0, 0, 0,
SWP_NOSIZE or SWP_NOMOVE or SWP_SHOWWINDOW);
end;
Tworzenie formy przeźroczystej (z przezroczystym tłem), to należy zmienić metodę Create i Resize tej formy i wykorzystać funkcję CombineRgn.
constructor TForm1.Create(AOwner: TComponent);
begin
inherited;
HorzScrollBar.Visible:=False; VertScrollBar.Visible:=False;
NewWindowRgn;
end;
procedure TForm1.NewWindowRgn;
var i, CoordX, CoordY: Integer; FormRgn, NewRgn: THandle;
begin
CoordX:=(Width-ClientWidth) div 2; CoordY:=Height-ClientHeight-4;
FormRgn:=CreateRectRgn(0, 0, Width, Height);
NewRgn:= CreateRectRgn( CoordX, CoordY, CoordX+ClientWidth, CoordY+ClientHeight);
CombineRgn(FormRgn, FormRgn, NewRgn, RGN_DIFF);
for i:= 0 to ControlCount -1 do
with Controls[i] do
begin
NewRgn:= CreateRectRgn(CoordX + Left, CoordY + Top, CoordX + Left + Width,
CoordY + Top + Height);
CombineRgn(FormRgn, FormRgn, NewRgn, RGN_OR);
end;
SetWindowRgn(Handle, FormRgn, True);
end;
procedure TForm1.Resize;
begin
inherited; NewWindowRgn;
end;
Pokaz okna MessageDlg w wyznaczonym rejonie formy - tu centralnie na formie.
procedure TForm1.Button1Click(Sender: TObject);
var MyForm: TForm;
begin
MyForm:=CreateMessageDialog('This is example', mtInformation, [mbOk]);
with MyForm do
begin
Height:=130; Width:=150;
Left:=Trunc((Form1.Width-Width)/2)+Form1.Left;
Top:=Trunc((Form1.Height-Height)/2)+Form1.Top;
ShowModal;
end; end;
Utworzenie dziury w aplikacji uruchomionej
var
Wnd: HWnd; Region1, Region2: HRgn; Rect: TRect;
begin
Wnd:=Application.MainForm.Handle; GetWindowRect(Wnd,Rect);
Region1:=CreateRectRgn(0,0,Rect.Right-Rect.Left,Rect.Bottom-Rect.Top);
Region2:=CreateEllipticRgn(10,30,150,120);
CombineRgn(Region1,Region1,Region2,RGN_DIFF);
SetWindowRgn(Wnd,Region1,True);
end;
procedure tform1.cut1click(sender: tobject);
begin
sendmessage (activecontrol.handle, wm_cut, 0, 0);
end;
procedure tform1.copy1click(sender: tobject);
begin
sendmessage (activecontrol.handle, wm_copy, 0, 0);
end;
procedure tform1.paste1click(sender: tobject);
begin
sendmessage (activecontrol.handle, wm_paste, 0, 0);
end;
Dla aplikacji MDI należy wysłać wiadomość do aktywnego okna dziecka (MDI Child) stosując:
activemdichild.activecontrol.handle
Aby do schoka wpakować strumień TMemorystream stworzyć własny format danych za pomocą funkcji:
registerclipboardformat():
cf_myformat: = registerclipboardformat ("mój opis formatu ');
Następnie wykonaj następujące czynności:
1. Tworzenie strumienia (stream) i zapisać danych.
2. Stworzenia globalnego bufora pamięci i skopiować strumień (stream).
3. Przy pomocy Clipboard.setashandle() wcisnąć globalny bufor do schowka.
// przykład:
var hbuf : thandle; bufptr : pointer; mstream : tmemorystream;
begin
mstream := tmemorystream.create;
try
{zapis danych do mstream. }
hbuf := globalalloc(gmem_moveable, mstream.size);
try bufptr := globallock(hbuf);
try move(mstream.memory^, bufptr^, mstream.size);
clipboard.setashandle(cf_myformat, hbuf);
finally globalunlock(hbuf); end;
except
globalfree(hbuf); raise; end;
finally mstream.free; end;
end;
WAŻNE: Nie usuwaj buforu po GlobalAlloc (). Jak tylko włożysz go do schowka to tego schoka już można używać.
Aby pobrać dane ze strumienia, można użyć następującego kodu:
var hbuf : thandle; bufptr : pointer; mstream : tmemorystream;
begin
hbuf := clipboard.getashandle(cf_myformat);
if hbuf < > 0 then begin
bufptr := globallock(hbuf); if bufptr < > nil then begin
try mstream := tmemorystream.create;
try mstream.writebuffer(bufptr^, globalsize(hbuf));
mstream.position := 0; { odczyt danych z mstream.}
finally mstream.free; end;
finally globalunlock(hbuf); end; end;
end; end;
procedure strtofont(str: string; font: tfont);
function fonttostr(font: tfont): string;
procedure strtobrush(str : string; brush : tbrush);
function brushtostr(brush: tbrush): string;
implementation
uses sysutils;
function firstwordseperator(sep : string;var workstr : string; cut : boolean) : string;
var counter : word;
begin // "abcxdef" -> counter=4
counter:=pos(sep,workstr); if counter >0
then result:=copy(workstr,1,counter-1)
else result:=workstr; if cut then
begin
if counter >0 then delete(workstr,1,counter+length(sep)-1)
else workstr:=''; end;
end;
function tok(sep: string; var s: string): string;
// gives back part of string before the given seperator
// and throws away this part and the seperator
begin
result:=firstwordseperator(sep,s,true);
end;
procedure yesno(yes : boolean;var str:string);
begin
if yes then str:=str+'y'
else str:=str+'n';
end;
function fonttostr(font: tfont): string;
begin
{koduje wszystkie atrybuty TFont na ciąg znaków}
result := '';
result := result + inttostr(font.color) + ' ';
result := result + inttostr(font.height) + ' ';
result := result + font.name + ' ';
result := result + inttostr(ord(font.pitch)) + ' ';
result := result + inttostr(font.pixelsperinch) + ' ';
result := result + inttostr(font.size) + ' ';
yesno(fsbold in font.style,result);
yesno(fsitalic in font.style,result);
yesno(fsunderline in font.style,result);
yesno(fsstrikeout in font.style,result);
end;
procedure strtofont(str: string; font: tfont);
begin
if str = '' then exit;
font.color := strtoint(tok(' ', str)); font.height := strtoint(tok(' ', str));
font.name := tok(' ', str); font.pitch := tfontpitch(strtoint(tok(' ', str)));
font.pixelsperinch := strtoint(tok(' ', str)); font.size := strtoint(tok(' ', str));
font.style := [];
if str[1] = 'y' then font.style := font.style + [fsbold];
if str[2] = 'y' then font.style := font.style + [fsitalic];
if str[3] = 'y' then font.style := font.style + [fsunderline];
if str[4] = 'y' then font.style := font.style + [fsstrikeout];
end;
function brushtostr(brush: tbrush): string;
begin
result := ''; result := result + inttostr(brush.color) + ' ';
case brush.style of
bssolid : result:=result+'1'; bsclear : result:=result+'2';
bsbdiagonal : result:=result+'3'; bsfdiagonal : result:=result+'4';
bscross : result:=result+'5'; bsdiagcross : result:=result+'6';
bshorizontal : result:=result+'7'; bsvertical : result:=result+'8';
end; end;
procedure strtobrush(str : string; brush : tbrush);
begin
if str = '' then exit; brush.color := strtoint(tok(' ', str));
brush.style := bssolid;
case upcase(str[1]) of // enumerated like in helppage
'1' : brush.style := bssolid; '2' : brush.style := bsclear;
'3' : brush.style := bsbdiagonal; '4' : brush.style := bsfdiagonal;
'5' : brush.style := bscross; '6' : brush.style := bsdiagcross;
'7' : brush.style := bshorizontal; '8' : brush.style := bsvertical;
end; end;
uses classes;
type tinistringlist = class( tstringlist )
public
procedure loadfromini(const filename, section: string);
procedure savetoini(const filename, section: string);
end;
implementation
uses inifiles, sysutils;
procedure tinistringlist.loadfromini(const filename, section: string);
var index: integer; line: string;
begin
with tinifile.create( filename ) do
try readsectionvalues( section, self);
for index:= 0 to count - 1 do
begin
{ Usuń nazwę identyfikatora ..}
line:= values[ inttostr( index ) ]; { Usuń tyldy. }
system.delete( line, 1, 1); strings[ index ]:= line; end;
finally free; end;
end;
procedure tinistringlist.savetoini( const filename, section: string);
var index: integer; line: string;
begin
with tinifile.create( filename ) do
try erasesection( section ); for index:= 0 to count - 1 do
begin
{ Zapisz spacji, pustych linii..}
line:= '~' + strings[ index ]; writestring( section, inttostr( index ), line);
end; finally free; end;
end;
end.
Zastosowanie:
var l: tinistringlist;
begin
l := tinistringlist.create; l.loadfromini('myfile.ini', 'alati'); {pobierz..}
l.free;
end.
procedure TForm1.FormCreate(Sender: TObject);
begin
StringGrid1.RowHeights[0] := 15; StringGrid1.RowHeights[1] := 20;
StringGrid1.RowHeights[2] := 50; StringGrid1.RowHeights[3] := 35;
end;
// Uważać, aby nie podać nieistniejący rząd
library kbdhook;
uses sysutils, windows, messages;
const swm_kbdhook = 'swm_kbdhook';
var wm_kbdhook : integer = 0;
var hookhandle : thandle = 0;
function keyboardproc(code: integer; // kod uchwytu
wparam: wparam; //kod wirtualnego klawisza virtual-key
lparam: lparam): // informacja po naciśnięciu
lresult stdcall;
begin
if code < 0 then result := callnexthookex( hookhandle, code, wparam, lparam )
else begin
postmessage( hwnd_broadcast, wm_kbdhook, wparam, lparam ); result := 0
end; end;
function hookkeyboard( hook : boolean ) : boolean; stdcall;
begin
result := false; if hook then begin
if hookhandle = 0 then
hookhandle := setwindowshookex( wh_keyboard, keyboardproc, hinstance, 0 );
result := ( hookhandle < > 0 );
end else begin
if hookhandle < > 0 then begin unhookwindowshookex( hookhandle );
hookhandle := 0; result := true;
end; end; end;
exports keyboardproc index 1, hookkeyboard index 2;
begin
wm_kbdhook := registerwindowmessage( swm_kbdhook );
end. //***** koniec library
unit unit1;
interface
uses windows, messages, sysutils, classes, graphics, controls, forms, dialogs, stdctrls;
const swm_kbdhook = 'swm_kbdhook';
var wm_kbdhook : integer = 0;
type tform1 = class(tform)
checkbox1: tcheckbox;
memo1: tmemo;
procedure checkbox1click(sender: tobject);
procedure formdestroy(sender: tobject);
procedure formcreate(sender: tobject);
private { private declarations }
procedure apponmessage( var msg: tmsg; var handled: boolean);
public { public declarations }
end;
var form1: tform1;
implementation
{$r *.dfm}
function keyboardproc(code: integer; // kod uchwytu
wparam: wparam; //kod wirtualnego klawisza virtual-key
lparam: lparam): // informacja po naciśnieciu
lresult stdcall; external 'kbdhook.dll' index 1;
function hookkeyboard(hook : boolean ) : boolean; stdcall;
external 'kbdhook.dll' index 2;
procedure tform1.apponmessage( var msg: tmsg; var handled: boolean);
begin
if msg.message = wm_kbdhook then
begin
memo1.lines.add( format( 'keycode=%d flags=%d', [msg.wparam, msg.lparam] ) );
handled := true; end;
end;
procedure tform1.checkbox1click(sender: tobject);
begin
if not hookkeyboard( ( sender as tcheckbox ).checked ) then caption := 'Błąd!';
end;
procedure tform1.formdestroy(sender: tobject);
begin
hookkeyboard( false );
end;
procedure tform1.formcreate(sender: tobject);
begin
wm_kbdhook := registerwindowmessage( swm_kbdhook );
application.onmessage := apponmessage;
end;
end.
program Previns;
uses WinTypes, WinProcs, SysUtils, Forms, Uprevins in 'UPREVINS.PAS' {Form1};
{$R *.RES}
type PHWND = ^HWND;
function EnumFunc(Wnd:HWND; TargetWindow:PHWND) : bool; export;
var ClassName : array[0..30] of char;
begin
Result := true; if GetWindowWord(Wnd,GWW_HINSTANCE) = hPrevInst then
begin
GetClassName( Wnd, ClassName, 30 );
if StrIComp( ClassName, 'TApplication' ) = 0 then
begin
TargetWindow^ := Wnd; Result := false; end; end;
end;
procedure GotoPreviousInstance;
var PrevInstWnd : HWND;
begin
PrevInstWnd := 0; EnumWindows( @EnumFunc, Longint( @PrevInstWnd ) );
if PrevInstWnd < > 0 then if IsIconic( PrevInstWnd ) then
ShowWindow( PrevInstWnd, SW_RESTORE )
else
BringWindowToTop( PrevInstWnd );
end;
begin
if hPrevInst < > 0 then GotoPreviousInstance
else begin
Application.CreateForm(TForm1, Form1); Application.Run; end;
end.
Główny program sam wypełnia funkcję instalatora. Początkowo plik programu nazywa się Setup.exe. Po uruchomieniu aplikacji pod tą nazwą instaluje siebie, przyjmuje właściwą nazwę i przestaje być instalatorem.
Application.Initialize;
if UpperCase(ExtractFileName(Application.ExeName))='SETUP.EXE' then
Application.CreateForm(TSetupForm, SetupForm) // forma instalatora
else Application.CreateForm(TMainForm, MainForm); // forma programu właściwego
Application.Run;
var bs: tadoblobstream; //piszemy tekst w pole BLOB tablicy
...
with form1.adoquery1 do
begin
if not (state in [dsedit, dsinsert]) then edit;
bs := tadoblobstream.create(fieldbyname('rtext') as tblobfield, bmreadwrite);
try
rxrichedit.lines.savetostream(bs as tstream); //tekst rtf zapisany w TStream
finally bs.free; end;
post; //akceptacja wprowadzonych danych
end;
textout(getwindowdc(getdesktopwindow),100,100,'Ala ma kota', 4);
Na górze okien można narysować napis za pomocą następującej procedury:
procedure writedc(s: string);
var c: tcanvas;
begin
c := tcanvas.create; c.brush.color := clblue;
c.font.color := clyellow; c.font.name := 'fixedsys';
c.handle := getdc(getwindow(getdesktopwindow, gw_owner));
c.textout(screen.width - c.textwidth(s) - 2, screen.height - 43, s);
c.free;
end;
function readini(asection, astring: string): string;
var sinifile: tinifile; spath: string[60];
const s = 'xyz'; { standardowa linia do wydania błędu odczytu }
begin
getdir(0, spath); sinifile := tinifile.create(spath + 'name.ini');
result := sinifile.readstring(asection, astring, s); { [section] string=value}
sinifile.free;
end;
procedure writeini(asection, astring, avalue: string);
var sinifile: tinifile; spath: string[60];
begin
getdir(0, spath); sinifile := tinifile.create(spath + 'name.ini');
sinifile.writestring(asection, astring, avalue); { [section] string=value }
sinifile.free;
end;
{readsection - czyta wszystkie elementy tej sekcji.
taki znak wstawia przed kluczem "="
readsectionvalues - czyta wszystkie linie tej sekcji, tj. punkt=xyz }
procedure tform1.formcreate(sender: tobject);
var bmp : tbitmap;
begin
bmp:=tbitmap.create; bmp.loadfromfile('mypicture.bmp');
image1.picture.assign(bmp); image1.canvas.brush.color:=clblue;
image1.canvas.font.name:='arial'; image1.canvas.font.size:=10;
image1.canvas.textout(10, 10, 'Tutaj jest ten tekst !!!');
end;
//przykład:
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private {Private declarations}
public {Public declarations}
procedure MyShowHint(var HintStr: string; var CanShow: Boolean;var HintInfo: THintInfo);
end;
var Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.MyShowHint(var HintStr: string; var CanShow: Boolean; var HintInfo: THintInfo);
var i : integer;
begin
for i := 0 to Application.ComponentCount - 1 do
if Application.Components[i] is THintWindow then
with THintWindow(Application.Components[i]).Canvas do
begin
Font.Name:= 'Arial'; Font.Size:= 18; Font.Style:= [fsBold]; HintInfo.HintColor:= clWhite;
end; end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Application.OnShowHint := MyShowHint;
end;
Do tego służy funkcja winapi shgetspecialfolderlocation.
Przykład użycia:
uses shlobj;
procedure tform1.formcreate(sender: tobject);
const folders: array [0..15] of integer = (csidl_bitbucket,csidl_controls,csidl_desktop,
csidl_desktopdirectory,csidl_drives,csidl_fonts, csidl_nethood,csidl_network,
csidl_personal,csidl_printers,csidl_programs,csidl_recent,csidl_sendto,csidl_startmenu,
csidl_startup,csidl_templates);
vars: pchar;p: pitemidlist;i: integer;
begin
s := stralloc(128);
for i := low(folders) to high(folders) do begin
p := nil;
shgetspecialfolderlocation(form1.handle, folders[i], p);
shgetpathfromidlist(p, s); listbox1.items.add(s);
end; end;
procedure ReplaceText(Edit: TCustomEdit; strOLD, strNEW: string);
var x, Position: integer; tmpstr, tmpstr2: string;
begin
tmpstr := Edit.Text; for x := 0 to Length(Edit.Text) do
begin
if Copy(Edit.Text, x, Length(strold)) = strold then
begin
tmpstr := Copy(Edit.Text, 0, x - 1) + strnew; Position := x; end;
end;
tmpstr2 := Edit.Text; if Position < > 0 then
Edit.Text := tmpstr + Copy(tmpstr2, Position + Length(strOLD), Length(tmpstr2))
else Edit.Text := tmpstr;
end;
// wykorzystanie powyższej procedury:
procedure TForm1.Button1Click(Sender: TObject);
begin
ReplaceText(Edit1, 'OldWord', 'NewWord');
end;
// przykład ze standardową funkcją StringReplace:
procedure ReplaceText(Edit: TCustomEdit; strOLD, strNEW: string);
begin
Edit.Text := StringReplace(Edit1.Text, strOLD, strNEW, [rfReplaceAll]);
end;
Wariant 1:
procedure TForm1.Button1Click(Sender: TObject);
var i: Integer;
begin
i := GetWindowLong(Button1.Handle, GWL_STYLE);
SetWindowLong(Button1.Handle, GWL_STYLE, i or BS_MULTILINE);
Button1.Caption := 'Delphi XE2 ' + #13#10 + 'to bardzo fajna rzecz!';
end;
Wariant 2 - oto sposób na przycisk z trzema (lub więcej) liniiami tekstu. Umieścić komponent TBitBtn na formularzu i daj mu wystarczająco długi tytuł. Poniższy kod wstaw do procedury OnCreate formy:
var R: TRect; N: Integer; Buff: array[0..255] of Char;
...WITH BitBtn1 do
begin
Glyph.Canvas.Font := Self.Font; Glyph.Width := Width - 6; Glyph.Height := Height - 6;
R := Bounds(0, 0, Glyph.Width, 0); StrPCopy(Buff, Caption);
Caption := '';
DrawText(Glyph.Canvas.Handle, Buff, StrLen(Buff), R,
DT_CENTER or DT_WORDBREAK or DT_CALCRECT);
OffsetRect(R, (Glyph.Width - R.Right) div 2, (Glyph.Height - R.Bottom) div 2);
DrawText(Glyph.Canvas.Handle, Buff, StrLen(Buff), R, DT_CENTER or DT_WORDBREAK);
end;
Dla dla uproszczenia użyto TMemoryStream. Kluczowymi wywołaniami są tu Read / WriteListBegin i Read / WriteListEnd. Bez nich, pojawi się wyjątek.
procedure TForm1.Button1Click(Sender: TObject);
var sWrite, sRead: string[25]; MyStream: TMemoryStream;
MyWriter: TWriter; MyReader: TReader;
begin
MyStream := TMemoryStream.Create; MyStream.SetSize(4096);
MyWriter := TWriter.Create(MyStream, 4096); sWrite := 'sWriteContents';
MyWriter.WriteListBegin; MyWriter.WriteString(sWrite); MyWriter.WriteListEnd;
MyWriter.free; MyStream.Seek(0, 0);
MyReader := TReader.Create(MyStream, 4096); MyReader.ReadListBegin;
sRead := MyReader.ReadString; MyReader.ReadListEnd;
MyReader.free; Label1.Caption := sRead; MyStream.free;
end;
procedura SGridToHtml () przekształca Stringgrid do kodu HTML.
Parametry: SG: TStringGrid do konwersji, Dest: TMemo aby pokazać kod HTML, BorderSize:=0 (bez ramki).
procedure SGridToHtml(SG: TStringgrid; Dest: TMemo; BorderSize: Integer);
var i, p: integer; SStyle1, SStyle2, Text: string;
begin
Dest.Clear; Dest.Lines.Add(''); Dest.Lines.Add(''); Dest.Lines.Add(' ');
for i := 0 to SG.RowCount - 1 do begin Dest.Lines.Add(' ');
for p := 0 to SG.ColCount - 1 do
begin
SStyle1 := ''; SStyle2 := ''; if fsbold in SG.Font.Style then
begin
SStyle1 := SStyle1 + ''; SStyle2 := SStyle2 + ''; end;
if fsitalic in SG.Font.Style then
begin
SStyle1 := SStyle1 + ''; SStyle2 := SStyle2 + ''; end;
if fsunderline in SG.Font.Style then
begin
SStyle1 := SStyle1 + ''; SStyle2 := SStyle2 + ''; end;
Text := sg.Cells[p, i]; if Text = '' then Text := ' '; Dest.Lines.Add(' ');
end;
Dest.Lines.Add( ' '); end;
Dest.Lines.Add(' ' + SStyle1 + Text + SStyle2 + '');
Dest.Lines.Add(''); Dest.Lines.Add('');
end;
// wywołanie na pole Memo1 i zapis do pliku
procedure TFormCSVInport.Button6Click(Sender: TObject);
begin
SGridToHtml(StringGrid1, Memo1, 1); Memo1.Lines.SaveToFile('c:\gridek.html');
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
//lub tak ustaw w object inspector
ListBox1.Style := lbOwnerDrawFixed;
end;
procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
begin
with Control as TListBox do
begin
Canvas.FillRect(Rect);
Canvas.Font.Color := TColor(Items.Objects[Index]);
Canvas.TextOut(Rect.Left + 2, Rect.Top, Items[Index]);
end; end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ListBox1.Items.AddObject('Red Item', Pointer(clRed));
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
ListBox1.Items.AddObject('Green Item', Pointer(clGreen));
end;
{Ta procedura jest w Popup menu.}
procedure TForm1.Change1Click(Sender: TObject);
var I9: Integer; ColInt: Integer; LRect: TRect;
begin
LRect := ListBox1.ItemRect(ListBox1.ItemIndex); {ustawia rozmiar TEdit}
Edit1.Top := LRect.Top + 1; Edit1.Left := LRect.Left + 1;
Edit1.Width := ListBox1.Canvas.TextWidth(ListBox1.Items.Strings[ListBox1.ItemIndex]) + 6;
Edit1.Height := (LRect.Bottom - LRect.Top) + 1;
Edit1.Text := ListBox1.Items.Strings[ListBox1.ItemIndex];
ListBox1.Selected[ListBox1.ItemIndex] := False;
Edit1.Visible := True; Edit1.SelectAll; Edit1.SetFocus;
end;
procedure TForm1.ListBox1Click(Sender: TObject);
begin
Edit1.Visible := False;
end;
procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
var I8: Integer;
begin
if Key = #13 then
begin
I8 := ListBox1.ItemIndex; ListBox1.Items.Delete(ListBox1.ItemIndex);
ListBox1.Items.Insert(I8, Edit1.Text); Edit1.Visible := False;
Key := #0; end;
end;
procedure TForm1.Button1Click(Sender: TObject);
const PIXEL_WIDTH = 200;
begin
ComboBox1.Perform(CB_SETDROPPEDWIDTH, PIXEL_WIDTH, 0);
end;
{rozwijana lista przyjmie rozmiary najdłuższego łańcucha.}
procedure TForm1.Button2Click(Sender: TObject);
var i, ItemWidth: Integer;
begin
ItemWidth := 0; with Combobox1 do
begin
for i := 0 to Items.Count - 1 do
if (Form1.Canvas.TextWidth(Items[i]) < > ItemWidth) then
ItemWidth := Form1.Canvas.TextWidth((Items[i])) + 20;
Perform(CB_SETDROPPEDWIDTH, ItemWidth, 0);
end; end;
Za pomocą - StringList1.AddObject ("Nazwa listy", TStringList.Create) - można utworzyć TStringList, który zawiera nazwę obiektu i sam obiekt TStringList. Ponieważ Delphi nie usuwa tych obiektów. Musisz zadbać o to sam. Dostęp do powiązanych stringlist odbywa się poprzez zmienną:
TempStringList: = TStringList (StringList1.Objects [index]);
unit Unit1;
interface
uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, Grids, StdCtrls;
type TForm1 = class(TForm)
Label1: TLabel;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private { Private declarations }
public { Public declarations }
StringList1, TempStringList: TStringList;
end;
var Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
StringList1 := TStringList.Create; StringList1.AddObject('Imię', TSTringList.Create);
TempStringList := TStringList(StringList1.Objects[0]);
TempStringList.Add('Witojcie kumie'); Label1.Caption := TempStringList[0];
end;
procedure TForm1.FormDestroy(Sender: TObject);//usuwamy objekt
var i: Longint;
begin
for i := 0 to StringList1.Count - 1 do
begin
TempStringList := TStringList(StringList1.Objects[i]); TempStringList.Free; end;
end;
end.
Wariant 1:
procedure TForm1.ListBox1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
const oldidx : Longint = -1;
var idx : Longint;
begin
with Sender as TListBox do
begin
idx := ItemAtPos(Point(x,y),True); if (idx < 0) or (idx = oldidx) then Exit;
Application.ProcessMessages; Application.CancelHint;
oldidx := idx; Hint := '';
if Canvas.TextWidth(Items[idx]) > Width - 4 then Hint:=Items[idx]; end;
end;
Wariant 2:
procedure TfmDWMain.lbSearchMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
var ItemNum: Integer;
begin
ItemNum := lbSearch.ItemAtPos(Point(X, Y), True); if (ItemNum < > HintRow) then
begin
HintRow := ItemNum; Application.CancelHint; if HintRow > -1 then
begin
HintString := lbSearch.Items[ItemNum];
if (lbSearch.Canvas.TextWidth(HintString) <= lbSearch.ClientWidth - 25) then
HintString := '';
end else HintString := ''; end;
end;
procedure TfmDWMain.OnShowHint(var HintStr: string; var CanShow: Boolean; var HintInfo: THintInfo);
begin
if not (HintInfo.HintControl is TListBox) then Exit;
with HintInfo.HintControl as TListBox do
begin
HintInfo.HintPos := lbSearch.ClientToScreen(Point(21, lbSearch.ItemRect(HintRow).Top + 1));
HintStr := HintString; end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
// wpisz tak lub ustaw to w object inspectorze
ListBox1.Style := lbOwnerDrawFixed;
end;
procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
var l: Integer; t: String;
begin
with ListBox1 do
begin
Canvas.FillRect(Rect); t := Items[Index]; l := Rect.Right - Canvas.TextWidth(t) - 1;
Canvas.TextOut(l, Rect.Top, t); end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ListBox1.Items.Add(Edit1.Text);
end;
type TArrayString = array of string;
procedure DeleteArrayIndex(var X: TArrayString; Index: Integer);
begin
if Index > High(X) then Exit;
if Index < Low(X) then Exit;
if Index = High(X) then
begin
SetLength(X, Length(X) - 1); Exit; end;
Finalize(X[Index]); System.Move(X[Index + 1], X[Index],
(Length(X) - Index - 1) * SizeOf(string) + 1); SetLength(X, Length(X) - 1);
end;
// przykład usuwania z tablicy drugiej pozycji
procedure TForm1.Button2Click(Sender: TObject);
var a: TArrayString;
begin
DeleteArrayIndex(a, 2);
end;
type MyType = record //dla przykładu - opis własnego typu
zap1: longword;
zap2: char;
zap3: string[10];
end;
var m: array of MyType;//opis nielimitowanej tablicy MyType
....
procedure TForm1.Button1Click(Sender: TObject);
var i: byte;
begin
for i := 0 to 9 do // numeracja zaczyna się od zera!
begin
SetLength(m, Length(m) + 1); // zwiekszanie tablicy o 1
m[i].zap1 := i; // przypisanie
m[i].zap2 := chr(i); // pola
m[i].zap3 := inttostr(i); // wartości
end; end;
....
SetLength(m, 0); // zwolnienie pamięci
end.
TestArray : array[0..127, 0..127] of Byte;
//obrazek bedzie mieć rozmiary 128 x 128 pikseli:
Image1.Picture.Bitmap.Width := 128; Image1.Picture.Bitmap.Height := 128;
//wywołujemy funkcję Windows API dla formatowania BitMap:
SetBitmapBits(Image1.Picture.Bitmap.Handle, sizeof(TestArray), @TestArray);
Image1.Refresh; {odśwież - zmiana wyświetlania}
Przykładowa struktura danych to:
type TMyRec = record
SomeField: Integer;
SomeOtherField: Double;
TheRest: array[0..99] of Single;
end;
//niżej MyBlobField to TBlobField a TRec tu nazwany MyRec. Aby skopiować zawartość MyRec do MyBlobField wykonaj następujące czynności:
var Stream: TBlobStream;
begin
Stream := TBlobStream.Create(MyBlobField, bmWrite);
Stream.Write(MyRec, SizeOf(MyRec));
Stream.Free;
end;
//a dla odczytu ...
var Stream: TBlobStream;
begin
Stream := TBlobStream.Create(MyBlobField, bmRead);
Stream.Read(MyRec, SizeOf(MyRec));
Stream.Free;
end;
//Wynikiem jest wartość true, jeśli ciąg wejściowy znaków jest właściwy.
Oznaczenia:
Rej - tryb flagi
jeśli Rej: = true, to Conf - ciąg zawiera niedozwolone znaki
jeśli Rej: = false, to Conf - ciąg poprawnych znaków
Input - ciąg wejściowy
function ConformStr(Input, Conf: string; Rej: boolean): boolean;
var i: integer;
begin
result := true; if Rej then begin
for i := 1 to length(Conf) do begin
if pos(Conf[i], Input) < > 0 then
begin
result := false; break; end end;
end else begin
for i := 1 to length(Input) do begin
if pos(Input[i], Conf) = 0 then begin
result := false; break; end; end; end;
end;
//przykład użycia:
s :='Witaj';
if not ConformStr(s, '0123456789') then s := Strtst(s, '0123456789');
//jak wpisze poprawnie ciąg znakow 0 do 9 to zobaczy napis 'Witaj' albo (zmień sobie) ruszy program
function DeleteLineBreaks(const S: string): string;
var Source, SourceEnd: PChar;
begin
Source := Pointer(S); SourceEnd := Source + Length(S);
while Source < SourceEnd do
begin
case Source^ of //znaki konca linii i zmiany wiersza zastępujemy spacjami
#10: Source^ := #32;
#13: Source^ := #32;
end; Inc(Source); end; Result := S;
end;
const R: array[1..13] of string[2] =
('I', 'IV', 'V', 'IX', 'X', 'XL', 'L', 'XC', 'C', 'CD', 'D', 'CM', 'M');
A: array[1..13] of Integer =
(1, 4, 5, 9, 10, 40, 50, 90, 100, 400, 500, 900, 1000);
..............
function ArabicToRoman(N: Integer): string; //arabskie na rzymskie
var i: Integer;
begin
Result := ''; i := 13; while N > 0 do
begin
while A[i] > N do Dec(i); Result := Result + R[i]; Dec(N, A[i]); end;
end;
function RomanToArabic(S: string): Integer; //rzymskie na arabskie
var i, p: Integer;
begin
Result := 0; i := 13; p := 1; while p <= Length(S) do
begin
while Copy(S, p, Length(R[i])) < > R[i] do
begin
Dec(i); if i = 0 then Exit; end;
Result := Result + A[i]; p := p + Length(R[i]); end;
end;