//przesuw w górę....
procedure LbMoveItemUp(AListBox: TListBox);
var CurrIndex: Integer;
begin
with AListBox do if ItemIndex > 0 then begin
CurrIndex := ItemIndex; Items.Move(ItemIndex, (CurrIndex - 1));
ItemIndex := CurrIndex - 1;
end; end;
//a tak to wywołać....
procedure TForm1.Button1Click(Sender: TObject);
begin
LbMoveItemUp(ListBox1);
end;
// przesuw w dół...
procedure LbMoveItemDown(AListBox: TListBox);
var CurrIndex, LastIndex: Integer;
begin
with AListBox do begin CurrIndex := ItemIndex; LastIndex := Items.Count;
if ItemIndex < > -1 then begin
if CurrIndex + 1 < LastIndex then begin
Items.Move(ItemIndex, (CurrIndex + 1)); ItemIndex := CurrIndex + 1;
end; end; end;
end;
//i wywolanie.....
procedure TForm1.Button2Click(Sender: TObject);
begin
LbMoveItemDown(ListBox1);
end;
procedure TForm1.Button1Click(Sender: TObject);
var sl: TStringList;
begin
sl := TStringList.Create;
try with sl do begin // Duplicates does nothing
Sorted := True; // if the list is not sorted.
// Ignore attempts to add
// duplicate strings to the list.
Duplicates := dupIgnore; Add(Edit1.Text); end;
Listbox1.Items.Assign(sl);
finally sl.Free; end;
end;
uses ComObj;
function ConvertDoc2Rtf(var FileName: string) : Boolean;
var oWord: OleVariant; oDoc: OleVariant;
begin
Result := False; try oWord := GetActiveOleObject('Word.Application');
except oWord := CreateOleObject('Word.Application');
end;
oWord.Documents.Open(FileName); oDoc := oWord.ActiveDocument;
FileName := ChangeFileExt(FileName, '.rtf');
oDoc.SaveAs(FileName);
oWord.ActiveDocument.Close(wdDoNotSaveChanges, EmptyParam, EmptyParam);
oWord.Quit(EmptyParam, EmptyParam, EmptyParam);
oDoc := VarNull; oWord := VarNull; Result := True;
end;
procedure TForm1.Button1Click(Sender: TObject);
const FileName = 'c:\Document.doc';
begin
if ConvertDoc2Rtf(FileName) then begin
ShowMessage('Word document has been converted to .rtf');
RichEdit1.Lines.LoadFromFile(FileName);
end; end;
Jeżeli potrzeba pokazać fragment RichEdita w TImage to transformację do bitmapy zapewni poniższa funkcja...
uses RichEdit;
function RTFtoBitmap(myRTF: TRichEdit; GiveSpaceForBorder: Integer): TBitmap;
// TRichEdit tu jako RichEdit1, kształt prostokąta z ramką
var myRect: TRect; temp: TBitmap;
begin
temp := TBitmap.Create; myRect := myRTF.ClientRect;
// if you are using PRF_NONCLIENT parameter in myRTF.perform command
// using this statement
// myRect := Rect(0,0,MyRTF.Width,MyRTF.Height);
temp.Width := myRect.Right; temp.Height := myRect.Bottom;
with temp.Canvas do begin Lock;
try myRTF.Perform(WM_PRINT, Handle, PRF_CLIENT);
//you can trying to change PRF_CLIENT with
//PRF_CHILDREN or PRF_CLIENT or PRF_NONCLIENT or PRF_ERASEBKGND
//or combine them. See what happen...
finally Unlock
end; end;
Result := TBitmap.Create; Result := CreateEmptyBmp(clWhite,
temp.Width + GiveSpaceForBorder * 2, temp.Height + GiveSpaceForBorder * 2);
Result.Canvas.Lock;
Result.Canvas.Draw(GiveSpaceForBorder, GiveSpaceForBorder, temp);
Result.Canvas.Unlock; temp.Free;
end;
// teraz ramka..
procedure MakeBorder(const bdr: TBitmap; BorderWidth: Integer; BorderColor: TColor);
begin
with bdr.Canvas do begin
Brush.Style := bsClear; pen.Width := BorderWidth; pen.Color := BorderColor;
rectangle(BorderWidth - 1, BorderWidth - 1, bdr.Width, bdr.Height);
end; end;
// przykład użycia.....
// var bmp : TBitmap;
// begin
// bmp := RTFtoBitmap(RichEdit1,2);
// MakeBorder(bmp,2,clBlue); Image1.Canvas.Draw(5,5,bmp); bmp.free;
// end;
procedure TreeToIni(Tree: TTreeView; INI: TIniFile; Section: string);
var n: Integer; MS: TMemoryStream; tTv: TStringList; Msg: string;
begin
tTv := TStringList.Create; MS := TMemoryStream.Create;
try Tree.SaveToStream(MS); MS.Position := 0; tTv.LoadFromStream(MS);
INI.EraseSection(Section);
for n := 0 to tTv.Count - 1 do
INI.WriteString(Section, 'Node' + IntToStr(n), StringReplace(tTv[n], #9, '#', [rfReplaceAll]));
finally tTv.Free; MS.Free; end;
end;
procedure TreeFromIni(Tree: TTreeView; INI: TIniFile; Section: string; Expand: Boolean);
var n: Integer; MS: TMemoryStream; tTv: TStringList; Msg: string;
begin
tTv := TStringList.Create; MS := TMemoryStream.Create;
try INI.ReadSection(Section, tTv);
for n := 0 to tTv.Count - 1 do
tTv[n] := StringReplace(INI.ReadString(Section, tTv[n], ''), '#', #9, [rfReplaceAll]);
tTv.SaveToStream(MS); MS.Position := 0; Tree.LoadFromStream(MS);
if (Expand = True) and (Tree.Items.Count > 0) then Tree.Items[0].Expand(True);
finally tTv.Free; MS.Free; end;
end;
{....}
protected
procedure WndProc(var Message: TMessage); override;
{....}
uses Richedit, ShellApi;
procedure TForm1.FormCreate(Sender: TObject);
var mask: Word;
begin
mask := SendMessage(RichEdit1.Handle, EM_GETEVENTMASK, 0, 0);
SendMessage(RichEdit1.Handle, EM_SETEVENTMASK, 0, mask or ENM_LINK);
SendMessage(RichEdit1.Handle, EM_AUTOURLDETECT, Integer(True), 0);
//Some text in RichEdit
RichEdit1.Text := 'Scalabium Software'#13#10 +
' Site is located at www.scalabium.com. Welcome to our site.';
end;
procedure TForm1.WndProc(var Message: TMessage);
var p: TENLink; strURL: string;
begin
if (Message.Msg = WM_NOTIFY) then begin
if (PNMHDR(Message.lParam).code = EN_LINK) then begin
p := TENLink(Pointer(TWMNotify(Message).NMHdr)^);
if (p.Msg = WM_LBUTTONDOWN) then begin
SendMessage(RichEdit1.Handle, EM_EXSETSEL, 0, Longint(@(p.chrg)));
strURL := RichEdit1.SelText;
ShellExecute(Handle, 'open', PChar(strURL), 0, 0, SW_SHOWNORMAL);
end end end;
inherited;
end;
uses RichEdit;
// Używając właściwości Paragraph
procedure RE_AlignText1(ARichEdit: TRichEdit; alignment: TAlignment);
begin
ARichEdit.Paragraph.Alignment := alignment;
end;
// Używając PARAFORMAT2; poza VCL
procedure RE_AlignText2(ARichEdit: TRichEdit; alignment: TAlignment);
var pf2: PARAFORMAT2;
begin
FillChar(pf2, SizeOf(pf2), 0); pf2.cbSize := SizeOf(PARAFORMAT2);
SendMessage(ARichEdit.Handle, EM_GETPARAFORMAT, 0, Longint(@pf2));
pf2.dwMask := PFM_ALIGNMENT;
case alignment of
taLeftJustify: pf2.wAlignment := PFA_LEFT;
taCenter: pf2.wAlignment := PFA_CENTER;
taRightJustify: pf2.wAlignment := PFA_RIGHT;
end;
SendMessage(ARichEdit.Handle, EM_SETPARAFORMAT, 0, Longint(@pf2));
end;
// przykład -tekst dostawiaj do prawej...
procedure TForm1.Button1Click(Sender: TObject);
begin
RE_AlignText2(RichEdit1, taRightJustify);
end;
function ListViewConfHTML(Listview:TListview; output:string; center: Boolean) : Boolean;
var i,f: Integer; tfile: TextFile;
begin
try ForceDirectories(ExtractFilePath(output)); AssignFile(tfile,output);
ReWrite(tfile); WriteLn(tfile, '< html > '); WriteLn(tfile,' < head > ');
WriteLn(tfile,' < title > HTML-Ansicht: '+listview.Name+' < /title > ');
WriteLn(tfile,' < /head > ');
WriteLn(tfile,'< table border="1" bordercolor="#000000"> ');
WriteLn(tfile,'< tr > ');
for i := 0 to listview.Columns.Count - 1 do begin
if center then
WriteLn(tfile,'< td> < b > < center > '+listview.columns[i].caption+'< /center > < /b > < /td > ') else
WriteLn(tfile,'< td > < b > '+listview.columns[i].caption+'< /b > < /td > ');
end;
WriteLn(tfile,'< /tr > '); WriteLn(tfile,'< tr > ');
for i := 0 to listview.Items.Count-1 do begin
WriteLn(tfile,'< td > '+listview.items.item[i].caption+'< /td > ');
for f := 0 to listview.Columns.Count-2 do begin
if listview.items.item[i].subitems[f]='' then Write(tfile,'< td > - < /td > ') else
Write(tfile,'< td > '+listview.items.item[i].subitems[f]+'< /td > ');
end; Write(tfile,'< /tr > '); end;
WriteLn(tfile,'< /table > '); WriteLn(tfile,'< /html > ');
CloseFile(tfile); Result := True; except Result := False;
end; end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if ListViewConfHTML(form1.ListView1,'C:\text.html', true) then
ShowMessage('OK/ Hat geklappt') else ShowMessage('Error occured/ Hat nicht geklappt');
end;
domyślnie wielkość pola edycji RichEdita = 64 KB; można jednak w prosty spodób zwiększyć ją do 2 GB.
procedure TForm1.Button1Click(Sender: TObject);
begin
RichEdit11.MaxLength := $7FFFFFF0;
end;
//lub...........
procedure TForm1.Button1Click(Sender: TObject);
begin
SendMessage(RichEdit1.Handle, EM_EXLIMITTEXT, 0, $7FFFFFF0);
end;
uses RichEdit;
procedure RE_SetSelBgColor(RichEdit: TRichEdit; AColor: TColor);
var Format: CHARFORMAT2;
begin
FillChar(Format, SizeOf(Format), 0);
with Format do begin
cbSize := SizeOf(Format); dwMask := CFM_BACKCOLOR; crBackColor := AColor;
Richedit.Perform(EM_SETCHARFORMAT, SCF_SELECTION, Longint(@Format));
end; end;
//przykład pod znakiem jest tło zółte....
procedure TForm1.Button1Click(Sender: TObject);
begin
RE_SetSelBgColor(RichEdit1, clYellow);
end;
procedure TForm1.Button1Click(Sender: TObject);
var D: PChar;
begin
D := 'C:\*.*';
SendMessage(ListBox1.Handle, LB_DIR, DDL_ARCHIVE + DDL_DIRECTORY + DDL_DRIVES +
DDL_EXCLUSIVE + DDL_HIDDEN + DDL_READONLY + DDL_READWRITE + DDL_SYSTEM, Integer(D));
end;
//lub.....
procedure TForm1.Button2Click(Sender: TObject);
var D: PChar;
begin
D := 'C:\*.*';
ListBox2.Perform(LB_DIR, DDL_ARCHIVE + DDL_DIRECTORY + DDL_DRIVES +
DDL_EXCLUSIVE + DDL_HIDDEN + DDL_READONLY +
DDL_READWRITE + DDL_SYSTEM, Integer(d));
end;
//Kolor tekstu w TRichEdit robimy w 2 krokach:
1. Zaznaczamy tekst za pomocą właściwości SelStart, SelLength
2. Ustalamy atrybuty tekstu dla SelAttributes
//1 przykład... dodajemy kolorową linię
procedure AddColoredLine(ARichEdit: TRichEdit; AText: string; AColor: TColor);
begin
with ARichEdit do begin
SelStart := Length(Text); SelAttributes.Color := AColor; SelAttributes.Size := 8;
SelAttributes.Name := 'MS Sans Serif'; Lines.Add(AText);
end; end;
procedure TForm1.Button1Click(Sender: TObject);
begin
AddColoredLine(RichEdit1, 'Hallo', clRed); AddColoredLine(RichEdit1, 'Hallo', clGreen);
end;
2. przykład....kolor dla 5 znaków....
procedure TForm1.Button1Click(Sender: TObject);
begin
RichEdit1.SelStart := 0; RichEdit1.SelLength := 5; RichEdit1.SelAttributes.Color := clBlue;
end;
3. przykład kolor w określonej linii
procedure RE_ColorLine(ARichEdit: TRichEdit; ARow: Integer; AColor: TColor);
begin
with ARichEdit do begin
SelStart := SendMessage(Handle, EM_LINEINDEX, ARow - 1, 0);
SelLength := Length(Lines[ARow - 1]); SelAttributes.Color := AColor; SelLength := 0;
end; end;
procedure TForm1.Button1Click(Sender: TObject);
begin
RE_ColorLine(RichEdit1, 4, clGreen);
end;
uses RichEdit;
procedure TForm1.RichEdit1MouseMove(Sender: TObject; Shift: TShiftState;
X, Y: Integer);
var iCharIndex, iLineIndex, iCharOffset, i, j: Integer; Pt: TPoint; s: string;
begin
with TRichEdit(Sender) do begin
Pt := Point(X, Y); // Get Character Index from word under the cursor
iCharIndex := Perform(Messages.EM_CHARFROMPOS, 0, Integer(@Pt));
if iCharIndex < then Exit; // Get line Index
iLineIndex := Perform(EM_EXLINEFROMCHAR, 0, iCharIndex);
iCharOffset := iCharIndex - Perform(EM_LINEINDEX, iLineIndex, 0);
if Lines.Count - 1 < iLineIndex then Exit; // store the current line in a variable
s := Lines[iLineIndex]; // Search the beginning of the word
i := iCharOffset + 1;
while (i > 0) and (s[i] < > ' ') do Dec(i); // Search the end of the word
j := iCharOffset + 1;
while (j < = Length(s)) and (s[j] < > ' ') do Inc(j); // Display Text under Cursor
Caption := Copy(s, i, j - i);
end; end;
procedure TForm1.FormCreate(Sender: TObject);
begin // tu lub ustawienie tego w Objektinspektorze
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;
//i dodaje wartości z Edit1 na ListBox1 a tam do prawego.....
procedure TForm1.Button1Click(Sender: TObject);
begin
ListBox1.Items.Add(Edit1.Text);
end;
function RECharIndexByPos(RichEdit: TRichEdit; X, Y: Integer): Integer;
var P: TPoint;
begin
P := Point(X, Y);
Result := SendMessage(RichEdit.Handle, EM_CHARFROMPOS, 0, Longint(@P));
end;
procedure TForm1.RichEdit1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
var P: TPoint;
begin // Check, if Source is ListBox1
Accept := Source = ListBox1; if GetCursorPos(P) then
with RichEdit1 do begin // Get the Index from Mouse Position
P := ScreenToClient(P); SelStart := RECharIndexByPos(RichEdit1, P.X, P.Y);
SetFocus;
end; end;
procedure TForm1.RichEdit1DragDrop(Sender, Source: TObject; X, Y: Integer);
begin // finally insert text at mouse position
RichEdit1.SelText := ListBox1.Items[ListBox1.ItemIndex];
end;
function IsTreeviewFullyExpanded(tv: TTreeview): Boolean; //rozwijanie
var Node: TTreeNode;
begin
Assert(Assigned(tv)); if tv.Items.Count > 0 then begin
Node := tv.Items[0]; Result := True;
while Result and Assigned(Node) do begin
Result := Node.Expanded or not Node.HasChildren; Node := Node.GetNext;
end; end else Result := False
end;
function IsTreeviewFullyCollapsed(tv: TTreeview): Boolean; //zwijanie
var Node: TTreeNode;
begin
Assert(Assigned(tv)); if tv.Items.Count > 0 then begin
Node := tv.Items[0]; Result := True;
while Result and Assigned(Node) do begin
Result := not (Node.Expanded and Node.HasChildren); Node := Node.GetNext;
end; end else Result := False
end;
function SearchForText_AndSelect(RichEdit: TRichEdit; SearchText: string): Boolean;
var StartPos, Position, Endpos: Integer;
begin
StartPos := 0; with RichEdit do begin
Endpos := Length(RichEdit.Text); Lines.BeginUpdate;
while FindText(SearchText, StartPos, Endpos, [stMatchCase]) < > -1 do begin
Endpos := Length(RichEdit.Text) - startpos;
Position := FindText(SearchText, StartPos, Endpos, [stMatchCase]);
Inc(StartPos, Length(SearchText)); SetFocus;
SelStart := Position; SelLength := Length(SearchText);
end; Lines.EndUpdate;
end; end;
procedure TForm1.Button1Click(Sender: TObject);
begin
SearchForText_AndSelect(RichEdit1, 'Adelajda');
end;
procedure TForm1.Button1Click(Sender: TObject);
var i: integer;
begin
for i := ListBox1.Items.Count - 1 downto 0 do
if ListBox1.Selected[i] then ListBox1.Items.Delete(i);
end;
// przykład z wykorzystaniem TReplaceDialog
function Search_And_Replace(RichEdit: TRichEdit;
SearchText, ReplaceText: string): Boolean;
var startpos, Position, endpos: integer;
begin
startpos := 0; with RichEdit do begin
endpos := Length(RichEdit.Text); Lines.BeginUpdate;
while FindText(SearchText, startpos, endpos, [stMatchCase]) < > -1 do begin
endpos := Length(RichEdit.Text) - startpos;
Position := FindText(SearchText, startpos, endpos, [stMatchCase]);
Inc(startpos, Length(SearchText)); SetFocus;
SelStart := Position; SelLength := Length(SearchText);
richedit.clearselection; SelText := ReplaceText;
end; Lines.EndUpdate;
end; end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Search_And_Replace(Richedit1, 'stary tekst', 'taki wstaw');
end;
procedure TForm1.Button1Click(Sender: TObject);
var search: string;
begin
search := 'swissdelphicenter';
if SendMessage(ListBox1.Handle, lb_selectstring, - 1, Longint(PChar(search))) < > LB_ERR then
ShowMessage('Item selected: ' + IntToStr(ListBox1.ItemIndex));
end;
// zapis..... bez zapisu obrazów
procedure TForm1.Button1Click(Sender: TObject);
var F: TFileStream;
begin
F := TFileStream.Create('c:\TreeView.txt', fmCreate or fmShareCompat);
try F.WriteComponent(TreeView1);
finally F.Free;
end; end;
// Odczyt....
procedure TForm1.Button2Click(Sender: TObject);
var F: TFileStream;
begin
F := TFileStream.Create('c:\TreeView.txt', fmOpenRead or fmShareDenyWrite);
try F.ReadComponent(TreeView1);
finally F.Free;
end; end;
function RichRow(m: TCustomMemo): Longint;
begin
Result := SendMessage(m.Handle, EM_LINEFROMCHAR, m.SelStart, 0);
end;
function RichCol(m: TCustomMemo): Longint;
begin
Result := m.SelStart - SendMessage(m.Handle, EM_LINEINDEX, SendMessage(m.Handle,
EM_LINEFROMCHAR, m.SelStart, 0), 0);
end;
procedure TForm1.Memo1KeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
caption := Format('%d : %d', [RichCol(Form1.Memo1), RichRow(Form1.Memo1)]);
end;
procedure TForm1.RichEdit1KeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
Caption := Format('%d : %d', [RichCol(Form1.richedit1), RichRow(Form1.richedit1)]);
end;
// lub z użyciem CaretPos do określenia koordynatów kursora:
procedure TForm1.Button1Click(Sender: TObject);
begin
with RichEdit1.CaretPos do
Label1.Caption := Format('(%d, %d)',[X+1,Y+1])
end;
procedure TForm1.FormCreate(Sender: TObject);
const bgcolor = $00FFDDEE; linecolor = $00554366;
var img: array of TImage; reg: hrgn; i: Integer;
begin
for i := 0 to ComponentCount - 1 do begin
if Components[i].ClassName = 'TPanel' then begin
setlength(img, Length(img) + 1);
img[i] := TImage.Create(Self);
img[i].Width := (Components[i] as TPanel).Width;
img[i].Height := (Components[i] as TPanel).Height;
img[i].Parent := (Components[i] as TPanel);
img[i].Canvas.Brush.Color := bgcolor;
img[i].Canvas.pen.Color := bgcolor;
img[i].Canvas.Rectangle(0,0,img[i].Width, img[i].Height);
img[i].Canvas.pen.Color := linecolor;
img[i].Canvas.RoundRect(0,0,img[i].Width - 1,img[i].Height - 1,20,20);
reg := CreateRoundRectRgn(0,0,(Components[i] as TPanel).Width,
(Components[i] as TPanel).Height, 20,20);
setwindowrgn((Components[i] as TPanel).Handle, reg, True);
deleteobject(reg);
end; end;
end;
Aby komponent wstawic na TStatusBarPanel należy użyć SetParent bo TStatusPanel nie jest
typowym panelem. W OnCreate umieszczamy na formie TProgressBar i TStatusBar i piszemy
poniższy kod.
Dla procedury SetParent tworzymy THackControl. 2 ostatnie linie zabezpieczają korektę
ProgressBara na wypadek zmiany rozmiaru formy.
type THackControl = class(TControl);
procedure TfrmWebsite.FormCreate(Sender: TObject);
var PanelRect: TRect;
begin
// Place progressbar on the statusbar
THackControl(ProgressBar1).SetParent(StatusBar1);
// Retreive the rectancle of the statuspanel (in my case the second)
SendMessage(StatusBar1.Handle, SB_GETRECT, 1, Integer(@PanelRect));
// Position the progressbar over the panel on the statusbar
with PanelRect do
ProgressBar1.SetBounds(Left, Top, Right - Left, Bottom - Top);
end;
uses CommCtrl;
{ .... }
procedure SetTreeViewItemHeight(aTreeView: TTreeView; aItemHeight: Word);
begin
aTreeView.Perform(TVM_SETITEMHEIGHT, aItemHeight, 0);
end;
// przykład uzycia...
procedure TForm1.Button1Click(Sender: TObject);
begin
SetTreeViewItemHeight(TreeView1, 30);
end;
procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
var drawRect: TRect;
begin
with ListBox1.Canvas do begin FillRect(rect);
drawRect.Left := rect.Left + 1; drawRect.Right := Rect.Left + 13;
drawRect.Bottom := Rect.Bottom; drawRect.Top := Rect.Top;
if odSelected in State then
DrawFrameControl(Handle, drawRect, DFC_BUTTON, DFCS_BUTTONRADIO or DFCS_CHECKED)
else DrawFrameControl(Handle, drawRect, DFC_BUTTON, DFCS_BUTTONRADIO);
TextOut(15, rect.Top + 3, ListBox1.Items[Index]);
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
ListBox1.Style := lbOwnerDrawVariable;
ListBox1.ItemHeight := 20;
//radiobuttony są przy 3 pozycjach
ListBox1.Items.Add('Pozycja 1');
ListBox1.Items.Add('Pozycja 2');
ListBox1.Items.Add('Pozycja 3');
end;
private { Private declarations }
FSelPos: integer;
{.....}
procedure TForm1.FindDialog1Find(Sender : TObject);
var S : string; startpos : integer;
begin
with TFindDialog(Sender) do begin
{If the stored position is 0 this cannot be a find next. }
if FSelPos = 0 then Options := Options - [frFindNext];
{ Figure out where to start the search and get the corresponding
text from the memo. }
if frfindNext in Options then begin
{ This is a find next, start after the end of the last found word. }
StartPos := FSelPos + Length(Findtext);
S := Copy(Memo1.Lines.Text, StartPos, MaxInt);
end else begin { This is a find first, start at the, well, start. }
S := Memo1.Lines.Text;
StartPos := 1;
end;
{ Perform a global case-sensitive search for FindText in S }
FSelPos := Pos(FindText, S);
if FSelPos > 0 then begin
{ Found something, correct position for the location of the start
of search. }
FSelPos := FSelPos + StartPos - 1;
Memo1.SelStart := FSelPos - 1;
Memo1.SelLength := Length(FindText);
Memo1.SetFocus;
end else begin { No joy, show a message. }
if frfindNext in Options then
S := Concat('Nie znalazłem więcej takiej frazy "', FindText, '" w Memo1.')
else S := Concat('Nie ma frazy "', FindText, '" w Memo1.');
MessageDlg(S, mtError, [mbOK], 0);
end; end; end;
// Wywołanie FindDialog
procedure TForm1.Button1Click(Sender : TObject);
begin
FSelPos := 0; FindDialog1.Execute;
end;
procedury przenoszą tak nody i subnody
Procedure TForm1.MoveNode(TargetNode, SourceNode : TTreeNode);
var nodeTmp : TTreeNode; i : Integer;
begin
with TreeView1 do begin
nodeTmp := Items.AddChild(TargetNode,SourceNode.Text);
for i := 0 to SourceNode.Count -1 do begin
MoveNode(nodeTmp,SourceNode.Item[i]);
end; end; end;
procedure TForm1.TreeView1DragDrop(Sender, Source: TObject; X, Y: Integer);
var TargetNode, SourceNode : TTreeNode;
begin
with TreeView1 do begin
TargetNode := GetNodeAt(X,Y); // Get target node
SourceNode := Selected;
if (TargetNode = nil) then begin
EndDrag(False); Exit;
end;
MoveNode(TargetNode,SourceNode); SourceNode.Free;
end; end;
procedure TForm1.TreeView1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
begin
if (Sender = TreeView1) then begin // If TRUE than accept the draged item
Accept := True;
end;
end;
procedure TForm1.MonthCalendar1GetMonthInfo(Sender: TObject;
Month: Cardinal; var MonthBoldInfo: Cardinal);
begin
if Month = 4 then { w kwietniu grubym drukiem pokaż dni: 3,21,28}
MonthCalendar1.BoldDays([3,21,28],MonthBoldInfo);
end;
procedure TForm1.Edit1Change(Sender: TObject);
var OldChange: TNotifyEvent; OldStart: Integer;
begin
with (Sender as TEdit) do begin
OldChange := OnChange; OnChange := nil; OldStart := SelStart;
if ((SelStart > 0) and (Text[SelStart - 1] = ' ')) or (SelStart = 1) then begin
SelStart := SelStart - 1; SelLength := 1;
SelText := AnsiUpperCase(SelText);
end; OnChange := OldChange; SelStart := OldStart;
end;
end;
procedure TForm1.ListView1CustomDrawItem(Sender: TCustomListView;
Item: TListItem; State: TCustomDrawState; var DefaultDraw: Boolean);
begin
with ListView1.Canvas.Brush do begin
case Item.Index of
0: Color := clYellow; //pierwszy wiersz żółty
1: Color := clGreen; // drugi zielony
2: Color := clRed; //3ci czerwony
end; end;
end;
uses CommCtrl;
procedure SetNodeBoldState(Node: TTreeNode; Value: Boolean);
var TVItem: TTVItem;
begin
if not Assigned(Node) then Exit;
with TVItem do begin
mask := TVIF_STATE or TVIF_HANDLE; hItem := Node.ItemId;
stateMask := TVIS_BOLD;
if Value then state := TVIS_BOLD
else state := 0; TreeView_SetItem(Node.Handle, TVItem);
end; end;
// przykład - zrobienie "na grubo" pierwszej nody
procedure TForm1.Button1Click(Sender: TObject);
begin
SetNodeBoldState(TreeView1.Items[0], True);
end;
procedure TForm1.Button1Click(Sender: TObject);
var ms: TMemoryStream; newform: TForm1;
begin
ms := TMemoryStream.Create;
try ms.WriteComponent(Form1);
newform := TForm1.CreateNew(Application);
ms.Position := 0; ms.ReadComponent(newform);
{ pokazuje nową formę identyczną jak oryginał dając jej inne parametry Left, Top można mieć ich
duzo... }
newform.Show;
finally ms.Free
end; end;
//poniżej kod klonuje TPanel chociaż mozna tak klonować dowolny komponent.
procedure TForm1.Button1Click(Sender: TObject);
var ms: TMemoryStream; s: string; p, temp: TPanel; x,y: Integer;
begin
ms := TMemoryStream.Create;
try temp := panel1; s := panel1.Name; panel1.Name := '';
try ms.WriteComponent(temp);
ms.Position := 0; p := TPanel.Create(Self); ms.ReadComponent(p);
with p do begin
x := panel1.Left; y := panel1.Top; Inc(x, 5); Inc(y, 5);
SetBounds(x, y, Width, Height); Parent := Self;
Name := Format('Panel%d_%d', [x, y]); end;
finally temp.Name := s; panel1 := temp; end
finally ms.Free; end; { finally }
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
//lub taką właściwość ustaw od razu w ObjectInspectorze dla ListBoxa
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('Pozycja na czerwono', Pointer(clRed));
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
ListBox1.Items.AddObject('Pozycja na zielono', Pointer(clGreen));
end;
Unit1; {...}
private
procedure SaveListViewToFile(AListView: TListView; sFileName: string);
procedure LoadListViewToFile(AListView: TListView; sFileName: string);
const Msg1 = 'File "%s" does not exist!'; Msg2 = '"%s" is not a ListView file!';
implementation
procedure TForm1.SaveListViewToFile(AListView: TListView; sFileName: string);
var idxItem, idxSub, IdxImage: Integer; F: TFileStream;
pText: PChar; sText: string; W, ItemCount, SubCount: Word;
MySignature: array [0..2] of Char;
begin //Initialization
with AListView do begin
ItemCount := 0; SubCount := 0; MySignature := 'LVF';
F := TFileStream.Create(sFileName, fmCreate or fmOpenWrite);
F.Write(MySignature, SizeOf(MySignature));
if Items.Count = 0 then ItemCount := 0 // List is empty
else ItemCount := Items.Count; F.Write(ItemCount, SizeOf(ItemCount));
if Items.Count > 0 then begin
for idxItem := 1 to ItemCount do begin
with Items[idxItem - 1] do begin //Save subitems count
if SubItems.Count = 0 then SubCount := 0
else SubCount := Subitems.Count;
F.Write(SubCount, SizeOf(SubCount)); //Save ImageIndex
IdxImage := ImageIndex;
F.Write(IdxImage, SizeOf(IdxImage)); //Save Caption
sText := Caption; w := Length(sText); pText := StrAlloc(Length(sText) + 1);
StrPLCopy(pText, sText, Length(sText)); F.Write(w, SizeOf(w)); F.Write(pText^, w);
StrDispose(pText);
if SubCount > 0 then begin
for idxSub := 0 to SubItems.Count - 1 do begin //Save Item's subitems
sText := SubItems[idxSub]; w := Length(sText); pText := StrAlloc(Length(sText) + 1);
StrPLCopy(pText, sText, Length(sText)); F.Write(w, SizeOf(w)); F.Write(pText^, w);
StrDispose(pText);
end; end; end; end; end; F.Free;
end; end;
procedure TForm1.LoadListViewToFile(AListView: TListView; sFileName: string);
var F: TFileStream; IdxItem, IdxSubItem, IdxImage: Integer;
W, ItemCount, SubCount: Word; pText: PChar; PTemp: PChar;
MySignature: array [0..2] of Char; sExeName: string;
begin
with AListView do begin
ItemCount := 0; SubCount := 0;
sExeName := ExtractFileName(sFileName);
if not FileExists(sFileName) then begin
MessageBox(Handle, PChar(Format(Msg1, [sExeName])), 'I/O Error', MB_ICONERROR);
Exit; end;
F := TFileStream.Create(sFileName, fmOpenRead);
F.Read(MySignature, SizeOf(MySignature));
if MySignature < > 'LVF' then begin
MessageBox(Handle, PChar(Format(Msg2, [sExeName])), 'I/O Error', MB_ICONERROR);
Exit; end;
F.Read(ItemCount, SizeOf(ItemCount)); Items.Clear;
for idxItem := 1 to ItemCount do begin
with Items.Add do begin //Read imageindex
F.Read(SubCount, SizeOf(SubCount)); //Read imageindex
F.Read(IdxImage, SizeOf(IdxImage)); ImageIndex := IdxImage; //Read the Caption
F.Read(w, SizeOf(w)); pText := StrAlloc(w + 1); pTemp := StrAlloc(w + 1);
F.Read(pTemp^, W); StrLCopy(pText, pTemp, W); Caption := StrPas(pText);
StrDispose(pTemp); StrDispose(pText);
if SubCount > 0 then begin
for idxSubItem := 1 to SubCount do begin
F.Read(w, SizeOf(w)); pText := StrAlloc(w + 1); pTemp := StrAlloc(w + 1);
F.Read(pTemp^, W); StrLCopy(pText, pTemp, W);
Items[idxItem - 1].SubItems.Add(StrPas(pText)); StrDispose(pTemp); StrDispose(pText);
end; end; end; end; F.Free;
end; end;
// przykład użycia
procedure TForm1.Button1Click(Sender: TObject);
begin
// zapisuje pozycje do pliku i czyści ListView
SaveListViewToFile(ListView1, 'MyListView.sav');
ListView1.Items.Clear;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
LoadListViewToFile(ListView1, 'MyListView.sav'); // odczyt pozycji
end;
procedure TForm1.Button1Click(Sender: TObject);
var search: string;
begin
search := 'swissdelphicenter';
if SendMessage(ListBox1.Handle, lb_selectstring, - 1, Longint(PChar(search))) < > LB_ERR then
ShowMessage('Znaleziony tekst jest na pozycji: ' + IntToStr(ListBox1.ItemIndex));
end;
//w przykładzie tworzony jest Button
{...}
private
MyButton: TButton;
procedure ButtonClickHandler(Sender: TObject); // OnClick handler
{...}
procedure TForm1.ButtonClickHandler(Sender: TObject);
begin
ShowMessage(TButton(Sender).Name);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
MyButton := TButton.Create(Self);
MyButton.Parent := Self; // ustaw jako parent (Form1)
MyButton.Name := 'Button1'; MyButton.Caption := 'My Button';
MyButton.SetBounds(20, 20, 80, 40);
MyButton.OnClick := ButtonClickHandler; // assign onclick handler
end;
function tform1.treeitemsearch(tv: ttreeview; sucheitem: string): ttreenode;
varnoddy: ttreenode; searching:boolean;
begin
result:=nil; noddy := tv.items[0]; searching := true; result:=nil;
while (searching) and (noddy < > nil) do
begin
noddy.expand(true); if noddy.text = sucheitem then
begin
searching := false; tv.selected := noddy; tv.setfocus; result:= noddy;
end else begin
noddy := noddy.getnext; end; end;
end;
//szukanie przez nazwę
function findbydata(treenodes : ttreenodes; dataf : string) : ttreenode ; vari : integer;
begin
for i := 0 to treenodes.count-1 do begin
if ansicomparestr(string(treenodes.item[i].text), dataf) = 0 then begin
result := treenodes.item[i]; exit; end; end; result := nil;
end;
//dodawanie - tu losowo przez random
procedure tform1.naddclick(sender: tobject);
var treenode : ttreenode;
begin
treenode := treeview1.items.addchild(treeview1.selected, inttostr(random(1000)));
end;
//usuwanie zaznaczonych gałęzi
procedure tform1.ndeleteclick(sender: tobject);
begin
treeview1.selected.delete;
end;
procedure tform1.nfindclick(sender: tobject);
var treenode : ttreenode;
begin
try
treenode := findbydata(treeview1.items ,inputbox('Szukana fraza','','0'));
if treenode < > nil then treeview1.selected := treenode;
except
showmessage('Błąd, prawdopodobnie wprowadzone przez nieprawidłowy numer');
end; end;
To tworzy plik tymczasowy, który dokona niezbędnych transferów (Uwaga: właściwość "MultiSelect"
TListBox należy zmienić na "true").
To musi być zadeklarowana w sesion prywate.
procedure TForm1.ApagarVarios(ListBox:TListBox);
var i:integer; lista1, lista2:TStringList;
begin
for i:=0 to ListBox.Items.Count-1 do if ListBox.Selected[i] then
begin
ListBox.Items.Strings[i]:='';
ListBox.Items.SaveToFile(extractfilepath(application.ExeName)+'itens.txt');
end;
Lista1:=TStringList.Create; Lista2:=TStringList.Create;
lista1.LoadFromFile(extractfilepath(application.ExeName)+'itens.txt');
for i:=0 to lista1.Count-1 do begin
if lista1.Strings[i] < > '' then begin
lista2.Add(lista1.Strings[i]);
lista2.SaveToFile(extractfilepath(application.ExeName)+'itens.txt');
end else
lista2.SaveToFile(extractfilepath(application.ExeName)+'itens.txt');
end;
ListBox.Items.LoadFromFile(extractfilepath(application.ExeName)+'itens.txt');
deletefile(extractfilepath(application.ExeName)+'itens.txt');
end;
// Dodaj niektóre elementy w TListBox
procedure TForm1.btnAdicionaClick(Sender: TObject);
var S : String;
begin
S := InputBox('Adicionar ítens', 'Digite algo' , '');
ListBox1.Items.Add(S);
ListBox1.Items.SaveToFile(extractfilepath(application.ExeName)+'itens.txt');
end;
// Teraz wywołanie procedury.
procedure TForm1.btnApagaClick(Sender: TObject);
begin
if not (ListBox1.Items.Count=0) and (ListBox1.Selected[ListBox1.ItemIndex]) then
ApagarVarios(ListBox1);
end;
Pola typu TBlobField ma metod, które pozwalają dane mają być przechowywane w plikach zawarte lub w Stream ... W pierwszym przypadku (pliki), kod będzie coś takiego:
TBlobField(SuaTabela.FieldByName('SeuCampo')).LoadFromFile('NomedoArquivo');
W drugim przypadku może być przykład z TRichEdit:
var Stream : TMemoryStream;
begin
Stream := TMemoryStream.Create;
try RichEdit1.Lines.SaveToStream(Stream); Stream.Seek(0,soFromBeginning);
TBlobField(SuaTabela.FieldByName('SeuCampo')).LoadFromStream(Stream);
finally Stream.Free; end;
end;
Oba przykłady zakładają, że tabela już będzie w trybie edycji lub wstawiania.
Ustaw właściwość Styl ComboBox do csOwnerDrawVariable.
var Form1: TForm1; Bmp1, Bmp2, Bmp3: TBitmap;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
Bmp1:=TBitmap.Create; Bmp.Loadfromfile('c:chip16.bmp');
Bmp1:=TBitmap.Create; Bmp.Loadfromfile('c:zoom.bmp');
Bmp1:=TBitmap.Create; Bmp.Loadfromfile('c:disk.bmp');
ComboBox1.Items.AddObject('Chip',Bmp1);
ComboBox1.Items.AddObject('Zoom',Bmp2);
ComboBox1.Items.AddObject('Disk',Bmp3);
end;
procedure TForm1.ComboBox1DrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOWnerDrawState);
var Bitmap: TBitmap; Offset: Integer;
begin
with (Control as TComboBox).Canvas do begin
FillRect(Rect); Bitmap:= TBitmap(ComboBox1.Items.Objects[index]);
if Bitmap nil then begin
BrushCopy(Bounds(Rect.Left + 2, Rect.Top + 2, Bitmap.Width,
Bitmap.Height), Bitmap, Bounds(0, 0, Bitmap.Width, Bitmap.Height), clRed);
Offset: Bitmap.width + 8;
end; TextOut(Rect.Left + Offset, Rect.Top, ComboBox1.Items[index]);
end; end;
procedure TForm1.ComboBox1MeasureItem(Control: TWinControl; Index: Integer; var Height: Integer);
begin
Height:=20;
end;
//Dołączyć do formularza składnik ComboBox i StringGrid komponentu.
type TForm1 = class(TForm)
StringGrid1: TStringGrid;
ComboBox1: TComboBox;
procedure FormCreate(Sender: TObject);
procedure ComboBox1Change(Sender: TObject);
procedure ComboBox1Exit(Sender: TObject);
procedure StringGrid1SelectCell
(Sender: TObject; Col, Row: Integer;
var CanSelect: Boolean);
private { Private declarations }
public { Public declarations }
end;
var Form1: TForm1; implementation {$R *.DFM}
//zdarzenie OnCreate w Form
procedure TForm1.FormCreate(Sender: TObject);
begin
{Regulacja wysokości ComboBox do wysokości wiersza StringGrid}
StringGrid1.DefaultRowHeight := ComboBox1.Height; { Ukrywa ComboBox}
ComboBox1.Visible := False;
end;
// zdarzenie OnChange ComboBox
procedure TForm1.ComboBox1Change (Sender: TObject);
begin
StringGrid1.Cells[StringGrid1.Col,StringGrid1.Row] := ComboBox1.Items[ComboBox1.ItemIndex];
ComboBox1.Visible := False; StringGrid1.SetFocus;
end;
// to zdarzenie w OnExit ComboBox
procedure TForm1.ComboBox1Exit (Sender: TObject);
begin
StringGrid1.Cells[StringGrid1.Col,StringGrid1.Row] := ComboBox1.Items[ComboBox1.ItemIndex];
ComboBox1.Visible := False; StringGrid1.SetFocus;
end;
// zdarzenie OnSelectCell stringgrida
procedure TForm1.StringGrid1SelectCell(Sender: TObject; Col, Row: Integer; var CanSelect: Boolean);
var R: TRect;
begin
if ((Col = 3) AND (Row < > 0)) then begin
R := StringGrid1.CellRect(Col, Row);
R.Left := R.Left + StringGrid1.Left; R.Right := R.Right + StringGrid1.Left;
R.Top := R.Top + StringGrid1.Top; R.Bottom := R.Bottom + StringGrid1.Top;
ComboBox1.Left := R.Left + 1; ComboBox1.Top := R.Top + 1;
ComboBox1.Width := (R.Right + 1) - R.Left; ComboBox1.Height := (R.Bottom + 1) - R.Top;
ComboBox1.Visible := True; ComboBox1.SetFocus;
end; CanSelect := True;
end;
OnSelectCell użyj tego zdarzenia i upewnij się, że jest to linia, którą chcesz ...
if ARow=Linha //do linii
then Grid.Options := Grid.Options + [goEditing]
else Grid.Options := Grid.Options - [goEditing];
procedure teditform.printed;
var line: integer; printtext: system.text;
begin
assignprn(printtext); rewrite(printtext); printer.canvas.font := memo1.font;
for line := 0 to memo2.lines.count - 1 do
writeln(printtext, memo2.lines[line]); system.close(printtext);
end;
W ramach innej opcji można taki tekst zapisać do pliku tekstowego i wysłać go do np, portu LPT1.
type tform1 = class(tform)
button1: tbutton;
procedure button1mousedown(sender: tobject; button: tmousebutton; shift: tshiftstate; x, y: integer);
procedure button1mousemove(sender: tobject; shift: tshiftstate; x, y: integer);
procedure button1mouseup(sender: tobject; button: tmousebutton; shift: tshiftstate; x, y: integer);
private {private declarations}
public {public declarations}
mousedownpoint : tpoint;
moving : bool;
end;
var form1: tform1;
implementation
{$r *.dfm}
procedure tform1.button1mousedown(sender: tobject; button: tmousebutton; shift: tshiftstate; x, y: integer);
begin
if ssctrl in shift then
begin
setcapture(button1.handle); moving := true;
mousedownpoint.x := x; mousedownpoint.y := y;
end; end;
procedure tform1.button1mousemove(sender: tobject; shift: tshiftstate; x, y: integer);
begin
if moving then begin
button1.left := button1.left - (mousedownpoint.x - x);
button1.top := button1.top - (mousedownpoint.y - y);
end; end;
procedure tform1.button1mouseup(sender: tobject; button: tmousebutton; shift: tshiftstate; x, y: integer);
begin
if moving then begin
releasecapture; moving := false;
button1.left := button1.left - (mousedownpoint.x - x);
button1.top := button1.top - (mousedownpoint.y - y); end;
end;
W przykładzie wykaz wprowadzany jest na listbox:
procedure tform1.button1click(sender: tobject);
var n: integer; p: integer;
begin
listbox1.clear; with notebook1 do
begin
for n := 0 to controlcount - 1 do
begin
with tpage(controls[n]) do
begin
listbox1.items.add('notebook page: ' + tpage(notebook1.controls[n]).caption);
for p := 0 to controlcount - 1 do listbox1.items.add(controls[p].name);
listbox1.items.add(emptystr); end; end; end;
end;
procedure tform1.button1click(sender: tobject);
begin //otwarty komponent
combobox1.droppeddown:=true;
end;
procedure tform1.button2click(sender: tobject);
begin //zamknięty...
combobox1.droppeddown:=false;
end;
procedure tform1.bla-bla-bla(sender: tobject);
begin
if combobox1.droppeddown = true then showmessage('Teraz ComboBox jest otwarty')
else showmessage('A teraz zamknięty')
end;
Tak przeciągać pliki z Windows Explorer do TListBox na formie:
type TForm1 = class(TForm)
ListBox1: TListBox;
procedure FormCreate(Sender: TObject);
protected
procedure WMDROPFILES (var Msg: TMessage); message WM_DROPFILES;
private
public
end;
var Form1: TForm1;
implementation
uses shellapi;
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
DragAcceptFiles(Form1.Handle, true);
end;
procedure TForm1.WMDROPFILES (var Msg: TMessage);
var i, amount, size: integer; Filename: PChar;
begin
inherited; Amount := DragQueryFile(Msg.WParam, $FFFFFFFF, Filename, 255);
for i := 0 to (Amount - 1) do
begin
size := DragQueryFile(Msg.WParam, i , nil, 0) + 1; Filename:= StrAlloc(size);
DragQueryFile(Msg.WParam,i , Filename, size); listbox1.items.add(StrPas(Filename));
StrDispose(Filename); end; DragFinish(Msg.WParam);
end;
Po otrzymaniu pliku wiadomości są wysyłane za pomocą WM_DROPFILES. Przy pomocy funkcji DragQueryFile można określić liczbę i nazwy plików. Przy pomocy funkcji DragQueryPoint określamy koordynaty myszy w momencie gdy użytkownik uwalnia (opuszcza) plik. Jeżeli plik zostanie przeciągnięty na PageControl1 toPageControl1 tych plików zostanie otwarty.
public
procedure WMDropFiles(var Msg: TWMDropFiles);
message WM_DROPFILES;
end;
var Form1: TForm1;
implementation
{$R *.DFM}
uses ShellAPI, stdctrls;
procedure TForm1.WMDropFiles(var Msg: TWMDropFiles);
var HF: THandle; s: array [0..1023] of char; i, FileCount: integer;
p: TPoint; ts: TTabSheet; memo: TMemo;
begin
HF := Msg.Drop; FileCount := DragQueryFile(HF, $FFFFFFFF, nil, 0);
for i := 0 to FileCount - 1 do
begin
DragQueryFile(HF, i, s, sizeof(s)); ts := TTabSheet.Create(nil);
DragQueryPoint(HF, p); if PtInRect(PageControl1.BoundsRect, p) then
ts.PageControl := PageControl1 else ts.PageControl := PageControl2;
ts.Caption := ExtractFileName(s); memo := TMemo.Create(nil);
memo.Parent := ts; memo.Align := alClient; memo.Lines.LoadFromFile(s);
end; DragFinish(HF);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
PageControl1.Align := alLeft; PageControl2.Align := alClient;
DragAcceptFiles(Form1.Handle, true);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
DragAcceptFiles(Form1.Handle, false);
end;
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;
tmemorystream jest najprostszym narzędziem interakcji między wszystkimi vcl:
procedure tform1.button1click(sender: tobject);
var memorystream:tmemorystream;
begin
memorystream:=tmemorystream.create;
try richedit1.lines.savetostream(memorystream);
memorystream.seek(0,sofrombeginning);
richedit2.lines.loadfromstream(memorystream);
finally memorystream.free; end;
end;
uses richedit;
procedure tform1.richedit1mousemove(sender: tobject; shift: tshiftstate; x, y: integer);
var icharindex, ilineindex, icharoffset, i, j: integer; pt: tpoint; s: string;
begin
with trichedit(sender) do
begin
pt := point(x, y); // get character index from word under the cursor
icharindex := perform(messages.em_charfrompos, 0, integer(@pt));
if icharindex < 0 then exit; // get line index
ilineindex := perform(em_exlinefromchar, 0, icharindex);
icharoffset := icharindex - perform(em_lineindex, ilineindex, 0);
if lines.count - 1 < ilineindex then exit; // store the current line in a variable
s := lines[ilineindex]; // search the beginning of the word
i := icharoffset + 1; while (i > 0) and (s[i] < > ' ') do
dec(i); // search the end of the word
j := icharoffset + 1; while (j <= length(s)) and (s[j] < > ' ') do
inc(j); // display text under cursor
caption := copy(s, i, j - i); end;
end;
procedure tform1.searchfortextexecute(sender: tobject); label notfound;
var i, j, k,snum,found :integer; f1, f2 :char;
begin
found :=0; snum :=-1;
for i:=0 to richedit1.lines.count-1 do //do końca linii tekstu
begin
for j:=0 to length(richedit1.lines.strings[i])-1 do //znaki w napisach (łańcuchach)
begin
inc(snum); for k:=1 to length(edit1.text) do
begin
f1 := edit1.text[k]; f2 := richedit1.lines.strings[i][j+k]; if f1 = f2 then
begin end else begin
goto notfound; end; end; inc(found);
richedit1.selstart := snum+i*2; richedit1.sellength := length(edit1.text);
richedit1.selattributes.name := labelededit2.text;
richedit1.selattributes.color := labelededit1.color;
richedit1.selattributes.size := spinedit1.value;
statusbar1.simpletext := 'Znaleziono '+inttostr(found)+' szukanych fraz';
form1.repaint;
notfound:
end; end; end;
procedure TForm1.Button1Click(Sender: TObject);
var Bm1 : TBitmap; Bm2 : TBitmap;
begin
Bm1 := TBitmap.Create; Bm2 := TBitmap.Create;
Bm1.LoadFromFile('c:\download\test.bmp');
Bm2.Width := Bm1.Width; Bm2.Height := Bm1.Height;
bm2.Canvas.Brush.Color := CoolBar1.Color;
bm2.Canvas.BrushCopy(Rect(0, 0, bm2.Width, bm2.Height), Bm1,
Rect(0, 0, Bm1.width, Bm1.Height), ClWhite);
bm1.Free; CoolBar1.Bitmap.Assign(bm2); bm2.Free;
end;
Poniższy przykład przechwytuje wiadomości i TScrollBox przewijania okno synchronizując dwa paski przewijania. Wiadomości zostają przechwycone przez zmianę procedury (Winproc) ScrollBox'a.
type {$IFDEF WIN32} WParameter = LongInt; {$ELSE} WParameter = Word; {$ENDIF}
LParameter = LongInt;
{Declare a variable to hold the window procedure we are replacing}
var OldWindowProc : Pointer;
function NewWindowProc(WindowHandle : hWnd; TheMessage : WParameter;
ParamW : WParameter; ParamL : LParameter) : LongInt
{$IFDEF WIN32} stdcall; {$ELSE} ; export; {$ENDIF}
var TheRangeMin : integer; TheRangeMax : integer; TheRange : integer;
begin
if TheMessage = WM_VSCROLL then
begin
{Get the min and max range of the horizontal scroll box}
GetScrollRange(WindowHandle, SB_HORZ, TheRangeMin, TheRangeMax);
{Get the vertical scroll box position}
TheRange := GetScrollPos(WindowHandle, SB_VERT);
{Make sure we wont exceed the range}
if TheRange < TheRangeMin then TheRange := TheRangeMin else
if TheRange > TheRangeMax then TheRange := TheRangeMax;
{Set the horizontal scroll bar}
SetScrollPos(WindowHandle, SB_HORZ, TheRange, true);
end;
if TheMessage = WM_HSCROLL then
begin
{Get the min and max range of the horizontal scroll box}
GetScrollRange(WindowHandle, SB_VERT, heRangeMin, TheRangeMax);
{Get the horizontal scroll box position}
TheRange := GetScrollPos(WindowHandle, SB_HORZ);
{Make sure we wont exceed the range}
if TheRange < TheRangeMin then TheRange := TheRangeMin
else
if TheRange > TheRangeMax then TheRange := TheRangeMax;
{Set the vertical scroll bar}
SetScrollPos(WindowHandle, SB_VERT, TheRange, true);
end;
{Call the old Window procedure to allow processing of the message.}
NewWindowProc := CallWindowProc(OldWindowProc, WindowHandle, TheMessage,
ParamW, ParamL);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
{Set the new window procedure for the control and remember
the old window procedure.}
OldWindowProc := Pointer(SetWindowLong(ScrollBox1.Handle, GWL_WNDPROC,
LongInt(@NewWindowProc)));
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
{Set the window procedure back to the old window procedure.}
SetWindowLong(ScrollBox1.Handle, GWL_WNDPROC, LongInt(OldWindowProc));
end;
Przykład ilustruje dwa sposoby, aby ograniczyć długość tekstu w TEdit, tak aby nie przekraczać szerokości okna obszaru roboczego TEdit'a. Pierwsza metoda ustawia maxLength TEdit'a równa liczbie liter "W", które pasują do TEdit. "W", ponieważ jest to prawdopodobnie największa szerokość znaku w dowolnej czcionce. Drugi sposób przechwytuje zdarzenia KeyPress i mierzy szerokość tekstu już wprowadzonego i szerokość nowego symbolu. Jeśli szerokość jest większa niż obszar klienta TEdit'a nowy znak jest odrzucany i pojawia się komunikat MessageBeep.
procedure TForm1.FormCreate(Sender: TObject);
var cRect : TRect; bm : TBitmap; s : string;
begin
Windows.GetClientRect(Edit1.Handle, cRect);
bm := TBitmap.Create; bm.Width := cRect.Right;
bm.Height := cRect.Bottom; bm.Canvas.Font := Edit1.Font;
s := 'W';
while bm.Canvas.TextWidth(s) < CRect.Right do s := s + 'W';
if length(s) > 1 then
begin
Delete(s, 1, 1); Edit1.MaxLength := Length(s); end;
end;
{Wariant 2}
procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
var cRect : TRect; bm : TBitmap;
begin
if ((Ord(Key) < > VK_TAB) and (Ord(Key) < > VK_RETURN) and
(Ord(Key) < > VK_LEFT) and (Ord(Key) < > VK_BACK)) then
begin
Windows.GetClientRect(Edit1.Handle, cRect);
bm := TBitmap.Create; bm.Width := cRect.Right;
bm.Height := cRect.Bottom; bm.Canvas.Font := Edit1.Font;
if bm.Canvas.TextWidth(Edit1.Text + Key) > CRect.Right then
begin
Key := #0; MessageBeep(-1); end; bm.Free; end;
end;
Jeśli spróbujesz przypisać wartość Selected w ListBox to często pojawia się błąd - Index is out of bounds. Dlaczego tak jest i jak ustawić wartość wybranej właściwości? Właściwość Selected TListBoxa może być używana tylko, jeżeli MultiSelect ustawiona jest na True. Jeśli pracujesz z ListBoxem przy MultiSelect = false to zamiast Selected użyj ItemIndex., np:
procedure TForm1.Button1Click(Sender: TObject);
begin
ListBox1.Items.Add('1'); ListBox1.Items.Add('2');
{Tak nie należy wybierać pojedyńczego wyboru w ListBox}
// ListBox1.Selected[1] := true;
ListBox1.ItemIndex := 1; {Tak jest OK}
end;
W przykładzie, lista jest wyświetlana na Listbox:
procedure TForm1.Button1Click(Sender: TObject);
var n: integer; p: integer;
begin
ListBox1.Clear; with Notebook1 do
begin
for n := 0 to ControlCount - 1 do begin
with TPage(Controls[n]) do begin
ListBox1.Items.Add('Notebook Page: ' + TPage(Notebook1.Controls[n]).Caption);
for p := 0 to ControlCount - 1 do
ListBox1.Items.Add(Controls[p].Name); ListBox1.Items.Add(EmptyStr);
end; end; end;
end;
Zamiast białego paska z suwakiem będzie cienka linia - w n/w przykładzie tworzony jest komponent, który pochodzi z TTrackBara. Zastępuje on CreateParams na właściwość stylu TBS_ENABLESELRANGE . Stała TBS_ENABLESELRANGE z modułu CommCtrl.
przykład:
uses CommCtrl, ComCtrls;
type TMyTrackBar = class(TTrackBar)
procedure CreateParams(var Params: TCreateParams); override;
end;
procedure TMyTrackBar.CreateParams(var Params: TCreateParams);
begin
inherited; Params.Style := Params.Style and not TBS_ENABLESELRANGE;
end;
var MyTrackbar : TMyTrackbar;
procedure TForm1.Button1Click(Sender: TObject);
begin
MyTrackBar := TMyTrackbar.Create(Form1);
MyTrackbar.Parent := Form1; MyTrackbar.Left := 100;
MyTrackbar.Top := 100; MyTrackbar.Width := 150;
MyTrackbar.Height := 45; MyTrackBar.Visible := true;
end;
procedure TForm1.StatusBar1DrawPanel(StatusBar: TStatusBar;
Panel: TStatusPanel; const Rect: TRect);
begin
if Panel = StatusBar.Panels[0] then
begin
StatusBar.Canvas.Font.Color := clRed;
StatusBar.Canvas.TextOut(Rect.Left, Rect.Top, 'Panel - 0')
end else begin
StatusBar.Canvas.Font.Color := clGreen;
StatusBar.Canvas.TextOut(Rect.Left, Rect.Top, 'Panel - 1');
end;
end;
Poniższy przykład pokazuje dwie funkcje: GetGridColumnByName () i GetGridRowByName (), które zwracaja kolumny lub wiersze, według otrzymanego tytułu (caption).
przykład:
procedure TForm1.FormCreate(Sender: TObject);
begin
StringGrid1.Rows[1].Strings[0] := 'This Row';
StringGrid1.Cols[1].Strings[0] := 'This Column';
end;
function GetGridColumnByName(Grid : TStringGrid; ColName : string): integer;
var i : integer;
begin
for i := 0 to Grid.ColCount - 1 do
if Grid.Rows[0].Strings[i] = ColName then
begin
Result := i; exit; end; Result := -1;
end;
function GetGridRowByName(Grid : TStringGrid; RowName : string): integer;
var i : integer;
begin
for i := 0 to Grid.RowCount - 1 do
if Grid.Cols[0].Strings[i] = RowName then
begin
Result := i; exit; end; Result := -1;
end;
procedure TForm1.Button1Click(Sender: TObject);
var Column : integer; Row : integer;
begin
Column := GetGridColumnByName(StringGrid1, 'This Column');
if Column = -1 then ShowMessage('Kolumny nie znaleziono')
else
ShowMessage('Znaleziona kolumnato: ' + IntToStr(Column));
Row := GetGridRowByName(StringGrid1, 'This Row');
if Row = -1 then ShowMessage('Wiersza nie znaleziono')
else
ShowMessage('Znaleziony wiersz to: ' + IntToStr(Row));
end;
TStringGrid automatycznie zmienia szerokość kolumny aby pomieścić najdłuższą linię w kolumnie.
procedure AutoSizeGridColumn(Grid : TStringGrid; column : integer);
var i : integer; temp : integer; max : integer;
begin
max := 0; for i := 0 to (Grid.RowCount - 1) do
begin
temp := Grid.Canvas.TextWidth(grid.cells[column, i]);
if temp > max then max := temp; end;
Grid.ColWidths[column] := Max + Grid.GridLineWidth + 3;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
AutoSizeGridColumn(StringGrid1, 1);
end;
//Wariant 2 wg. right_wrist@mail.ru.
Autodopasowanie szerokości kolumn i wysokości wierszy:
procedure WriteToCell(Sender :TStringGrid; ACol, ARow :integer; Value :variant);
var Len: TSize;
begin
with Sender do begin
Cells[ACol, ARow] := value;
Win32Check(GetTextExtentPoint32(Canvas.Handle, Pchar(Cells[ACol, ARow]),
Length(Cells[ACol, ARow]), Len));
if Len.cx > ColWidths[ACol] then ColWidths[ACol] := Len.cx+6;
if Len.cy > RowHeights[ARow] then RowHeights[ARow] := Len.cy+2; end;
end;
Za pomocą funkcji Windows API SetMenuItemBitmaps(). Funkcja ta pobiera uchwyt menu, pozycję linii menu gdzie będzie umieszczony obrazek i dwa deskryptory (uchwyty) na dwa obrazy (jeden z nich - będzie wyświetlany, gdy pasek menu jest dostępny, drugi - gdy pasek menu niedostępny).
type TForm1 = class(TForm)
PopupMenu1: TPopupMenu;
Pop11: TMenuItem;
Pop21: TMenuItem;
Pop31: TMenuItem;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private {Private declarations}
bmUnChecked : TBitmap;
bmChecked : TBitmap;
public {Public declarations}
end;
var Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
bmUnChecked := TBitmap.Create;
bmUnChecked.LoadFromFile('C:\Program Files\Borland\BitBtns\ALARMRNG.BMP');
bmChecked := TBitmap.Create;
bmChecked.LoadFromFile('C:\Program Files\Borland\BitBtns\CHECK.BMP');
{Add the bitmaps to the item at index 1 in PopUpMenu}
SetMenuItemBitmaps(PopUpMenu1.Handle,1,MF_BYPOSITION,BmUnChecked.Handle,
BmChecked.Handle);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
bmUnChecked.Free; bmChecked.Free;
end;
procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var pt : TPoint;
begin
pt := ClientToScreen(Point(x, y)); PopUpMenu1.Popup(pt.x, pt.y);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
{dopasowanie wysokości wierszy StrinGrida do comboboxa !}
StringGrid1.DefaultRowHeight := ComboBox1.Height;
ComboBox1.Visible := False; {ukrywa combobox}
ComboBox1.Items.Add('www.awalum.com');
ComboBox1.Items.Add('www.oferta.ugu.pl');
end;
procedure TForm1.ComboBox1Change(Sender: TObject);
begin
{Przepisujemy wartość z ComboBox do stringgrida}
StringGrid1.Cells[StringGrid1.Col, StringGrid1.Row] :=ComboBox1.Items[ComboBox1.ItemIndex];
ComboBox1.Visible := False; StringGrid1.SetFocus;
end;
procedure TForm1.ComboBox1Exit(Sender: TObject);
begin
{Przepisujemy wartość z ComboBox do stringgrida}
StringGrid1.Cells[StringGrid1.Col, StringGrid1.Row] :=ComboBox1.Items[ComboBox1.ItemIndex];
ComboBox1.Visible := False; StringGrid1.SetFocus;
end;
procedure TForm1.StringGrid1SelectCell(Sender: TObject; ACol,
ARow: Integer; var CanSelect: Boolean);
var R: TRect;
begin
if ((ACol = 3) AND (ARow < > 0)) then
begin
{szerokość i połozenie ComboBox musi odpowiadać celi StringGrid}
R := StringGrid1.CellRect(ACol, ARow); R.Left := R.Left + StringGrid1.Left;
R.Right := R.Right + StringGrid1.Left; R.Top := R.Top + StringGrid1.Top;
R.Bottom := R.Bottom + StringGrid1.Top; ComboBox1.Left := R.Left + 1;
ComboBox1.Top := R.Top + 1; ComboBox1.Width := (R.Right + 1) - R.Left;
ComboBox1.Height := (R.Bottom + 1) - R.Top;
ComboBox1.Visible := True; {pokazujemy combobox}
ComboBox1.SetFocus; end; CanSelect := True;
end;
Możesz. Patrz przykład.
uses ShellApi;
procedure TForm1.FormShow(Sender: TObject);
var Icon: TIcon;
begin
Icon := TIcon.Create; Icon.Handle := ExtractIcon(0,'C:\WINDOWS\NOTEPAD.EXE',1);
SpeedButton1.Glyph.Width := Icon.Width; SpeedButton1.Glyph.Height := Icon.Height;
SpeedButton1.Glyph.Canvas.Draw(0, 0, Icon);
Icon.Free;
end;
Wyświetla etykiety tekstowe bezpośrednio na "glyph" TBitButona. przykład:
procedure TForm1.FormCreate(Sender: TObject);
var R : TRect; N : Integer; Buff : array[0..255] of Char;
begin
with BitBtn1 do
begin
Caption := 'Naprawdę bardzo długi napis';
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;
end;
procedure TForm1.Memo1KeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
Memo1Click(Self);
end;
procedure TForm1.Memo1Click(Sender: TObject);
VAR LineNum : LongInt; CharNum : LongInt;
begin
LineNum := Memo1.Perform(EM_LINEFROMCHAR, Memo1.SelStart, 0);
CharNum := Memo1.Perform(EM_LINEINDEX, LineNum, 0);
Label1.Caption := IntToStr(LineNum+1)+' : '+IntToStr((Memo1.SelStart-CharNum)+1);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Memo1Click(Self);
end;
function SearchString(const FindStr, SourceString: String;Num: Integer):Integer;
var FirstP: PChar;
function MyPos(const FindStr, SourceString: PChar;Num: Integer): PChar;
begin
Result := AnsiStrPos(SourceString,FindStr);
if (Result=nil) then Exit; Inc(Result);
if Num=1 then Exit; if num >1 then Result := MyPos(FindStr,Result,num-1); end;
begin Result := 0;
FirstP := PChar(SourceString);
Result := MyPos(PChar(FindStr),PChar(SourceString),Num) - FirstP;
if Result < 0 then Result := 0;
end;
function NextSubStr(Const SubStr,Str : String; PrevIdx : Integer):Integer;
begin
if (PrevIdx < =Length(Str)) and (PrevIdx > 0)
then Result := pos(SubStr,PChar(@Str[PrevIdx]))+PrevIdx-1
else Result := 0; end;
Var k : Integer;
begin
k :=NextSubStr('a','abcabcabc',1);
Label1.Caption:=IntToStr(k); // pokaz miejsce pierwszego wystąpienia ciągu 'a'
k :=NextSubStr('a','abcabcabc',k+1);
Label2.Caption:=IntToStr(k); // pokaż miejsce kolejnego wystąpienia ciągu 'a'
end;
function fStrPos(const Line, Sample: string; FromPos, ToPos: integer): integer;
var stLen, samLen: integer; StopIndex: integer; StopChar, ch: char;
SuffixStr, RevertSample: string; SuffixLen: integer; i, incr: integer;
begin
Result := 0; //kontrola
SamLen := length(Sample); if SamLen = 0 then exit;
if FromPos < = 0 then FromPos := 1; stLen := length(Line);
if (ToPos < stLen) and (toPos >= FromPos) then stLen := toPos;
SetLength(RevertSample, SamLen); //przechwyt Sample - pasujące do Pos
for i := 1 to SamLen do RevertSample[SamLen - i + 1] := Sample[i];
while FromPos < = (stLen - samLen + 1) do //dopóki nie dojdzie do konca...
begin
//wyrównujemy model szukania z prawej do lewego
StopIndex := 0; for i := samLen downTo 1 do
if Sample[i] < > Line[i + FromPos - 1] then
begin
StopIndex := i; //na tym zatrzymane
StopChar := Line[i + FromPos - 1]; SuffixStr := copy(Sample, i+1, samLen - i);
SuffixLen := length(SuffixStr); Break;
end;
if StopIndex = 0 then //sprawdzenie wyniku
begin
Result := FromPos; Exit; end;
for i := 1 to (SuffixLen div 2) do //zwracany przyrostek -suffix
begin
ch := suffixstr[SuffixLen - i + 1]; suffixstr[SuffixLen - i + 1] := suffixStr[i]; suffixstr[i] := ch;
end;
//kolejne wystąpienie przyrostka
incr := Pos(SuffixStr, copy(RevertSample,SuffixLen + 1,SamLen));
for i := StopIndex - 1 downTo 1 do //daj taki następny:
if Sample[i] = StopChar then
begin
if incr < (SamLen - i) then incr := SamLen - i; break; end;
if incr = 0 then incr := samLen; inc(FromPos, incr); end;
end;
Dodać można czcionki (. Fon,. Fot,. FNT,. Ttf) w sposób następujacy:
{$IFDEF WIN32}
AddFontResource( PChar( my_font_PathName { AnsiString } ) );
{$ELSE}
var ss : array [ 0..255 ] of Char;
AddFontResource ( StrPCopy ( ss, my_font_PathName ));
{$ENDIF}
SendMessage ( HWND_BROADCAST, WM_FONTCHANGE, 0, 0 );
Usuń go po pracy programu z systemu:
{$IFDEF WIN32}
RemoveFontResource ( PChar(my_font_PathName) );
{$ELSE}
RemoveFontResource ( StrPCopy ( ss, my_font_PathName ));
{$ENDIF}
SendMessage ( HWND_BROADCAST, WM_FONTCHANGE, 0, 0 );
gdzie: my_font_PathName - pełna ścieżka do pliku z fontami.
Zapisz plik w TMemoryStream, a następnie wykorzystaj metodę TMemo SetSelTextBuf(), aby wstawić tekst;
var TheMStream : TMemoryStream; Zero : char;
begin
TheMStream := TMemoryStream.Create;
TheMStream.LoadFromFile('C:\AUTOEXEC.BAT');
TheMStream.Seek(0, soFromEnd); //Null - zerowanie bufora!
Zero := #0;
TheMStream.Write(Zero, 1); TheMStream.Seek(0, soFromBeginning);
Memo1.SetSelTextBuf(TheMStream.Memory); TheMStream.Free;
end;
W przykładzie style czcionki są zmienione przez naciśnięcie Ctrl + znak:
Ctrl + B - włącz / wyłącz pogrubienie
Ctrl + I - włączenie / wyłączenie kursywy
Ctrl + S - włącz / wyłącz czcionki przekreślenie
Ctrl + U - włączenie / wyłączenie podkreślenia czcionki
const KEY_CTRL_B = 02; KEY_CTRL_I = 9; KEY_CTRL_S = 19; KEY_CTRL_U = 21;
procedure TForm1.RichEdit1KeyPress(Sender: TObject; var Key: Char);
begin
case Ord(Key) of
KEY_CTRL_B: begin
Key := #0;
if fsBold in (Sender as TRichEdit).SelAttributes.Style then
(Sender as TRichEdit).SelAttributes.Style :=
(Sender as TRichEdit).SelAttributes.Style - [fsBold]
else
(Sender as TRichEdit).SelAttributes.Style :=
(Sender as TRichEdit).SelAttributes.Style + [fsBold];
end;
KEY_CTRL_I: begin
Key := #0;
if fsItalic in (Sender as TRichEdit).SelAttributes.Style then
(Sender as TRichEdit).SelAttributes.Style :=
(Sender as TRichEdit).SelAttributes.Style - [fsItalic]
else
(Sender as TRichEdit).SelAttributes.Style :=
(Sender as TRichEdit).SelAttributes.Style + [fsItalic];
end;
KEY_CTRL_S: begin
Key := #0;
if fsStrikeout in (Sender as TRichEdit).SelAttributes.Style then
(Sender as TRichEdit).SelAttributes.Style :=
(Sender as TRichEdit).SelAttributes.Style-[fsStrikeout]
else
(Sender as TRichEdit).SelAttributes.Style :=
(Sender as TRichEdit).SelAttributes.Style+[fsStrikeout];
end;
KEY_CTRL_U: begin
Key := #0;
if fsUnderline in (Sender as TRichEdit).SelAttributes.Style then
(Sender as TRichEdit).SelAttributes.Style :=
(Sender as TRichEdit).SelAttributes.Style-[fsUnderline]
else
(Sender as TRichEdit).SelAttributes.Style :=
(Sender as TRichEdit).SelAttributes.Style+[fsUnderline];
end; end;
end;
Do Memo trzeba wysłac wiadomość EM_SETTABSTOPS i ustawić tabulator na 20 pikseli:
procedure TForm1.FormCreate(Sender: TObject);
var DialogUnitsX : LongInt; PixelsX : LongInt;
i : integer; TabArray : array[0..4] of integer;
begin
Memo1.WantTabs := true; DialogUnitsX := LoWord(GetDialogBaseUnits);
PixelsX := 20; for i := 1 to 5 do
begin
TabArray[i - 1] :=((PixelsX * i ) * 4) div DialogUnitsX; end;
SendMessage(Memo1.Handle, EM_SETTABSTOPS,5,LongInt(@TabArray));
Memo1.Refresh;
end;
procedure TForm1.Button1Click(Sender: TObject);
var OldBkMode : integer;
begin
with Form1.Canvas do begin
Brush.Color := clRed; FillRect(Rect(0, 0, 100, 100));
Brush.Color := clBlue; TextOut(10, 20, 'tekst nie jest przeźroczysty!');
OldBkMode := SetBkMode(Handle, TRANSPARENT);
TextOut(10, 50, 'OK - teraz przeźroczysty!'); SetBkMode(Handle, OldBkMode);
end; end;
procedure TForm1.FormCreate(Sender: TObject);
var Acb: TCheckBox;
begin
RichEdit1.Left := 20; Acb := TCheckBox.Create(RichEdit1);
Acb.Left := 30; Acb.Top := 30; Acb.Caption := 'Delphi jest COOL!';
Acb.Parent := RichEdit1;
end;
Można skopiować obiekt (komponent) zapisując go do streamu by potem zapisać go na dysku w następujący sposób:
var Stream: TFileStream ;
begin // zapis komponentu Button i Grid1
Stream := TFileStream.Create( 'AFile', fmCreate ) ;
try
Stream.WriteComponent( Button1 ) ;
Stream.WriteComponent( Grid1 ) ; itd.
finally Stream.Free ; end ;
end ;
//odczyt tych obiektów:
var Stream : TFileStream ; Button2 : TButton ; Grid2 : TStringGrid ;
begin
Stream := TFileStream.Create( 'AFile', fmOpenRead ) ;
try
Button2 := Stream.ReadComponent( nil ) as TButton ;
Grid2 := Stream.ReadComponent( nil ) as TStringGrid ; itd.
finally Stream.Free ; end ;
end ;
W pewnym momencie musisz zarejestrować klasy, które chcesz czytać i pisać. Na przykład, można utworzyć następujące formy obsługi zdarzeń OnCreate:
RegisterClass (TButton); RegisterClass (TStringGrid);
Jeśli klasy nie są zarejestrowane to podczas próby odczytu obiektu, otrzymasz błąd 'Class not found' (klasy nie znaleziono).
procedure LockControl(c: TWinControl; bLock: Boolean);
begin
if (c = nil) or (c.Handle = 0) then Exit;
if bLock then SendMessage(c.Handle, WM_SETREDRAW, 0, 0)
else begin
SendMessage(c.Handle, WM_SETREDRAW, 1, 0); RedrawWindow(c.Handle, nil, 0,
RDW_ERASE or RDW_FRAME or RDW_INVALIDATE or RDW_ALLCHILDREN);
end; end;
procedure TForm1.Button1Click(Sender: TObject);
begin
LockControl(DBGrid1, True); // blokujemy DBGrid1
try
finally LockControl(DBGrid1, False); end; //odblokowanie
end;
Niektóre komponenty mają wbudowane własciwości BeginUpdate i EndUpdate;
Wprowadzony na planszę programu jako komponent daje dostęp do jego metod i właściwości:
type TMyControl = class(TCustomControl)
private
FTimer: TTimer;
procedure TimerEvent(Sender: TObject);
public
constructor Create(AOwner: TComponent); override;
end;
constructor TMyControl.Create(AOwner: TComponent);
begin
inherited Create(AOwner); FTimer := TTimer.Create(Self);
FTimer.Interval := 100; { 100 milisekund } FTimer.OnTimer := TimerEvent;
end;
procedure TMyControl.TimerEvent(Sender: TObject);
begin
{To jest Twoja obsługa zdarzeń gdy wywołany jest Timer
możesz tu zrobic co chcesz}
end;
Daje najbardziej efektywne wykorzystanie zasobów systemu.
procedure Delay(ms: longint);
var TheTime: LongInt;
begin
TheTime := GetTickCount + ms;
while GetTickCount < TheTime do
Application.ProcessMessages;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage('Start mojego Testu');
Delay(2000);
ShowMessage('teraz koniec tego testu');
end;
Jeżeli przez pewien czas użytkownik nie aktywuje (wchodzi) w TEdit (mozna inny element) to program ostrzega go.
unit EditOnTime;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, StdCtrls;
type TEditOnTime = class(TEdit)
private
FInterval: integer;
FTimer: TTimer;
FOnTimer: TNotifyEvent;
procedure SetInterval(Interval: integer);
procedure Timer(Sender: TObject);
protected
procedure KeyPress(var Key: char); override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property Interval: integer read FInterval write SetInterval default 750;
property OnTimer: TNotifyEvent read FOnTimer write FOnTimer;
end;
procedure register;
implementation
//******************* RegisterComponent- rejestracja komponentu w IDE
procedure register;
begin
RegisterComponents('MPS' , [TEditOnTime]);
end;
//******************* TEditOnTime.SetInterval - ustanawiamy Interwał Timera
procedure TEditOnTime.SetInterval(Interval: integer);
begin
FInterval := Interval; if Assigned(FTimer) then FTimer.Interval := FInterval;
end;
//******************* TEditOnTime.Create
constructor TEditOnTime.Create(AOwner: TComponent);
begin
FInterval := 750; inherited Create(AOwner);
if not (csDesigning in ComponentState) then
try
FTimer := TTimer.Create(self); FTimer.Enabled := false;
FTimer.Interval := FInterval; FTimer.OnTimer := Timer;
except FreeAndNil(FTimer); end;
end;
//******************* TEditOnTime.Destroy
destructor TEditOnTime.Destroy;
begin
if Assigned(FTimer) then FreeAndNil(FTimer); inherited Destroy;
end;
//******************* TEditOnTime.OnTimer
procedure TEditOnTime.Timer(Sender: TObject);
begin
FTimer.Enabled := false; if Assigned(FOnTimer) then FOnTimer(self);
end;
//******************* TEditOnTime.KeyPress
procedure TEditOnTime.KeyPress(var Key: char);
begin
FTimer.Enabled := false; inherited KeyPress(Key);
FTimer.Enabled := (Text < > '') and Assigned(FTimer)
and Assigned(FOnTimer);
end;
end.
uses MPlayer, MMSystem;
const
MCI_SETAUDIO = $0873;
MCI_DGV_SETAUDIO_VOLUME = $4002;
MCI_DGV_SETAUDIO_ITEM = $00800000;
MCI_DGV_SETAUDIO_VALUE = $01000000;
MCI_DGV_STATUS_VOLUME = $4019;
type MCI_DGV_SETAUDIO_PARMS = record
dwCallback: DWORD;
dwItem: DWORD;
dwValue: DWORD;
dwOver: DWORD;
lpstrAlgorithm: PChar;
lpstrQuality: PChar;
end;
type MCI_STATUS_PARMS = record
dwCallback: DWORD;
dwReturn: DWORD;
dwItem: DWORD;
dwTrack: DWORD;
end;
procedure SetMPVolume(MP: TMediaPlayer; Volume: Integer); { Volume: 0 - 1000 }
var p: MCI_DGV_SETAUDIO_PARMS;
begin
{ Volume: 0 - 1000 } p.dwCallback := 0;
p.dwItem := MCI_DGV_SETAUDIO_VOLUME; p.dwValue := Volume;
p.dwOver := 0; p.lpstrAlgorithm := nil; p.lpstrQuality := nil;
mciSendCommand(MP.DeviceID, MCI_SETAUDIO,
MCI_DGV_SETAUDIO_VALUE or MCI_DGV_SETAUDIO_ITEM, Cardinal(@p));
end;
function GetMPVolume(MP: TMediaPlayer): Integer;
var p: MCI_STATUS_PARMS;
begin
p.dwCallback := 0; p.dwItem := MCI_DGV_STATUS_VOLUME;
mciSendCommand(MP.DeviceID, MCI_STATUS, MCI_STATUS_ITEM, Cardinal(@p));
Result := p.dwReturn; { Volume: 0 - 1000 }
end;
// przykład wykonania
procedure TForm1.Button1Click(Sender: TObject);
begin
SetMPVolume(MediaPlayer1, 500);
end;
procedure TForm1.Button1Click(Sender: TObject);
var sl: TStringList;
begin
sl := TStringList.Create;
try with sl do
begin // tu duplikaty mogą być bo lista nie jest posortowana.
Sorted := True;
//tu zaś dyplikaty są ignorowane przy dodawaniu do listy.
Duplicates := dupIgnore; Add(Edit1.Text); end;
Listbox1.Items.Assign(sl);
finally sl.Free; end;
end;
{ Na formularzu utwórz TImage i dołącz bitmapy; utwórz też TListbox }
type TForm1 = class(TForm)
ListBox1: TListBox;
Image1: TImage;
procedure FormCreate(Sender: TObject);
procedure ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
procedure ListBox1MeasureItem(Control: TWinControl; Index: Integer; var Height: Integer);
private {...}
public {...}
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
with ListBox1.Items do
begin
Clear; ListBox1.Style := lbOwnerDrawVariable;
AddObject('Bitmap1' , Image1.Picture.Bitmap);
AddObject('Bitmap2' , Image2.Picture.Bitmap);
AddObject('Bitmap3' , Image3.Picture.Bitmap);
end; end;
procedure CenterText(Cnv: TCanvas; Rect: TRect; S: string);
var X, Y: Integer;
begin
X := (Rect.Right + Rect.Left - Cnv.TextWidth(S)) div 2;
Y := (Rect.Bottom + Rect.Top - Cnv.TextHeight(S)) div 2;
Cnv.TextOut(X, Y, S);
end;
procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
var Bitmap: TBitmap;
begin
with ListBox1 do
begin
Canvas.FillRect(Rect); if Items.Objects[Index] < > nil then
begin
Bitmap := Items.Objects[Index] as TBitmap;
Canvas.BrushCopy(Bounds(Rect.Left + 2, Rect.Top + 2,
Bitmap.Width, Bitmap.Height), Bitmap, Bounds(0, 0, Bitmap.Width,
Bitmap.Height), Bitmap.Canvas.Pixels[0, Bitmap.Height - 1]);
end;
Rect.Left := Rect.Left + Bitmap.Width + 4;
Rect.Bottom := Rect.Top + Bitmap.Height + 4;
CenterText(Canvas, Rect, Items.Strings[Index]);
end; end;
procedure TForm1.ListBox1MeasureItem(Control: TWinControl; Index: Integer; var Height: Integer);
begin
if Index = 0 then Height := Image1.Height + 4;
end;
{uses ShellApi}
procedure TForm1.ListBox1DblClick(Sender: TObject);
var s: string;
begin
s := listbox1.Items[SendMessage(ListBox1.Handle, lb_GetCurSel, 0, 0)];
if edit1.Text[length(edit1.text)] < > '' then
edit1.text := concat(edit1.text + '');
if (not FileExists(edit1.text + s)) and (s[1] = '[') and (s[length(s)] = ']') then
DlgDirList(handle, PChar(edit1.text + copy(s, 2, length(s) - 2)),
ListBox1.Handle, Edit1.Handle, faAnyFile );
if edit1.Text[length(edit1.text)] < > '' then edit1.text := concat(edit1.text +'');
if FileExists(edit1.text + s) then
begin
caption := edit1.text + s; ShellExecute(handle, 'open', PChar(edit1.text + s), '', 'c:', sw_show);
end end;
procedure TForm1.FormShow(Sender: TObject);
begin
edit1.Width := 1024 * 8 - 1; edit1.Visible := false;
DlgDirList(handle, PChar('c:'), ListBox1.Handle, Edit1.Handle, faAnyFile );
listbox1.Sorted := false; listbox1.Sorted := true;
end;
function RECharIndexByPos(RichEdit: TRichEdit; X, Y: Integer): Integer;
var P: TPoint;
begin
P := Point(X, Y);
Result := SendMessage(RichEdit.Handle, EM_CHARFROMPOS, 0, Longint(@P));
end;
procedure TForm1.RichEdit1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
var P: TPoint;
begin // sprawdza czy źródłem jest ListBox1
Accept := Source = ListBox1; if GetCursorPos(P) then
with RichEdit1 do
begin // pobierz indeks od pozycji myszy
P := ScreenToClient(P);
SelStart := RECharIndexByPos(RichEdit1, P.X, P.Y); SetFocus;
end; end;
procedure TForm1.RichEdit1DragDrop(Sender, Source: TObject; X, Y: Integer);
begin
// w końcu wstawić tekst na pozycji myszy
RichEdit1.SelText := ListBox1.Items[ListBox1.ItemIndex];
end;
procedure ComboColor(C: TWinControl; I : Integer; R : TRect; EColor, OColor, FColor : TColor);
begin
with (C as TCombobox) do //TCombobox oder T.....box
begin
if Odd(I) then Canvas.Brush.color := OColor
else Canvas.Brush.color := EColor;
Canvas.FillRect(R); Canvas.Font.Color := FColor;
Canvas.TextOut(R.Left,R.Top,Items[I]);
end; end;
procedure TForm1.ComboBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
begin
ComboColor(Control, Index, Rect, clInfoBk, clWhite, clBlack);
end;
//właściwość Combobox.Style := csOwnerDrawFixed;
private
procedure CMDialogKey(var Msg: TCMDialogKey); message CM_DIALOGKEY;
end;
implementation
procedure TForm1.CMDialogkey;
begin
with Scrollbox1.VertScrollBar do
begin
case Msg.CharCode of
VK_DWON: Position := Position + Increment; // do dołu
VK_Up: Position := Position - Increment; // w górę
else inherited; end; end;
end;
Kod wymaga użycia pewnych funkcji WinAPI. W projekcie należy ustawić wartość BorderStyle bsNone, dodać panel z właściwością bsSingle dla BorderStyle. Dodaj kolejny panel dodając zdarzenia (MouseDown, MouseMove, MouseUp) i obsługę dla przycisku (Click).
unit Unit1;
interface
uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, ExtCtrls, StdCtrls;
type TForm1 = class(TForm)
Panel1: TPanel;
Panel2: TPanel;
Button1: TButton;
procedure Panel1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure Panel1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
procedure Panel1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure Button1Click(Sender: TObject);
private { Private declarations }
OldX, OldY, OldLeft, OldTop: Integer;
ScreenDC: HDC; MoveRect: TRect; Moving: Boolean;
public { Public declarations }
end;
var Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Panel1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Button = mbLeft then
begin
SetCapture(Panel1.Handle); ScreenDC := GetDC(0);
OldX := X; OldY := Y; OldLeft := X; OldTop := Y;
MoveRect := BoundsRect; DrawFocusRect(ScreenDC, MoveRect);
Moving := True;
end; end;
procedure TForm1.Panel1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
if Moving then
begin
DrawFocusRect(ScreenDC, MoveRect); OldX := X; OldY := Y;
MoveRect := Rect(Left + OldX - OldLeft, Top + OldY - OldTop,
Left + Width + OldX - OldLeft, Top + Height + OldY - OldTop);
DrawFocusRect(ScreenDC, MoveRect);
end; end;
procedure TForm1.Panel1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Button = mbLeft then
begin
ReleaseCapture; DrawFocusRect(ScreenDC, MoveRect);
Left := Left + X - OldLeft; Top := Top + Y - OldTop;
ReleaseDC(0, ScreenDC); Moving := False; end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var TitleHeight, BorderWidth, BorderHeight: Integer;
begin
TitleHeight := GetSystemMetrics(SM_CYCAPTION);
BorderWidth := GetSystemMetrics(SM_CXBORDER) + GetSystemMetrics(SM_CXFRAME) - 1;
BorderHeight := GetSystemMetrics(SM_CYBORDER) + GetSystemMetrics(SM_CYFRAME) - 2;
if BorderStyle = bsNone then
begin
BorderStyle := bsSizeable; Top := Top - TitleHeight - BorderHeight;
Height := Height + TitleHeight + 2 * BorderHeight; Left := Left - BorderWidth;
Width := Width + 2 * BorderWidth;
end else begin
BorderStyle := bsNone; Top := Top + TitleHeight + BorderHeight;
Height := Height - TitleHeight - 2 * BorderHeight; Left := Left + BorderWidth;
Width := Width - 2 * BorderWidth; end;
end;
end.
Wersja 2 - łatwiejsza - poprzez obsługę zdarzenia wm_NCHitTest (komunikat systemowy).
unit Dragmain;
interface
uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls;
type TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
procedure WMNCHitTest(var M: TWMNCHitTest); message wm_NCHitTest;
end;
var Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.WMNCHitTest(var M: TWMNCHitTest);
begin
inherited; { tworzy nastepny uchwyt }
if M.Result = htClient then { następnie klikając w oknie }
M.Result := htCaption; { jeśli tak to dla Windows będzie obszar nagłówka }
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Close;
end;
end.
Należy umieścić na formie TPanel i napisać OnMauseDown obsługi zdarzeń:
procedure TForm1.Panel1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
const SC_DRAGMOVE = $F012;
begin
ReleaseCapture;
{Jeżeli niżej wpiszemy Form1 to ją można przeciągac po ekranie}
Panel1.Perform(WM_SYSCOMMAND, SC_DRAGMOVE, 0);
end;
procedure ListView2StringGrid(Listview: TListView; StringGrid: TStringGrid);
const MAX_SUBITEMS = 5;
var i, j: Integer;
begin
with ListView do for i := 0 to Items.Count - 1 do
begin
{pobierz pozycję pierwszej kolumny}
StringGrid.Cells[1, i + 1] := Items[i].Caption;
for j := 0 to MAX_SUBITEMS do {pętla na podelementy}
begin
if Items[i].SubItems.Count > j then
StringGrid.Cells[j + 2, i + 1] := Items[i].SubItems.Strings[j]
else break; end; end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var i: Integer;
begin // czyszczenie StringGrid w razie potrzeby
i := 0;
while i < StringGrid1.RowCount do
begin
StringGrid1.Rows[i].Clear; Inc(i); end;
// Kopiowanie ListView1 do StringGrid1
ListView2StringGrid(ListView1, StringGrid1);
end;
type TForm1 = class(TForm)
ListView1: TListView;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private { Private declarations }
FListViewWndProc: TWndMethod;
procedure ListViewWndProc(var Msg: TMessage);
public
FShowHoriz: Boolean;
FShowVert: Boolean;
end;
var Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.ListViewWndProc(var Msg: TMessage);
begin
ShowScrollBar(ListView1.Handle, SB_HORZ, FShowHoriz);
ShowScrollBar(ListView1.Handle, SB_VERT, FShowVert);
FListViewWndProc(Msg); // proces wiadomości
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
FShowHoriz := True; // pokaż poziomy scrollbar
FShowVert := False; // ukryj pionowy scrollbar
FListViewWndProc := ListView1.WindowProc; // zapis poprzednich procesów okna
ListView1.WindowProc := ListViewWndProc;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
ListView1.WindowProc := FListViewWndProc; // przywróć poprzednie procesy okna
FListViewWndProc := nil;
end;
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, comctrls, StdCtrls;
type TForm1 = class(TForm)
ListView1: TListView;
Button1: TButton;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
procedure SaveListViewToFile(AListView: TListView; sFileName: string);
procedure LoadListViewToFile(AListView: TListView; sFileName: string);
public
end;
const Msg1 = 'Plik "%s" nie istnieje!'; Msg2 = '"%s" nie jest plikiem ListViewa!';
var Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.SaveListViewToFile(AListView: TListView; sFileName: string);
var idxItem, idxSub, IdxImage: Integer; F: TFileStream; pText: PChar; sText: string;
W, ItemCount, SubCount: Word; MySignature: array[0..2] of Char;
begin
//Initialization
with AListView do
begin
ItemCount := 0; SubCount := 0;
MySignature := 'LVF'; // plik ListViewa
F := TFileStream.Create(sFileName, fmCreate or fmOpenWrite);
F.Write(MySignature, SizeOf(MySignature)); if Items.Count = 0 then
ItemCount := 0 // Lista jest pusta
else
ItemCount := Items.Count; F.Write(ItemCount, SizeOf(ItemCount));
if Items.Count > 0 then
begin
for idxItem := 1 to ItemCount do
begin
with Items[idxItem - 1] do
begin
if SubItems.Count = 0 then SubCount := 0 //zapis wartości podrozdziałów
else
SubCount := Subitems.Count; F.Write(SubCount, SizeOf(SubCount));
IdxImage := ImageIndex; //zapis indeksów obrazków - ImageIndex
F.Write(IdxImage, SizeOf(IdxImage));
sText := Caption; //Zapis tytułów
w := Length(sText); pText := StrAlloc(Length(sText) + 1);
StrPLCopy(pText, sText, Length(sText)); F.Write(w, SizeOf(w));
F.Write(pText^, w); StrDispose(pText); if SubCount > 0 then
begin
for idxSub := 0 to SubItems.Count - 1 do
begin
sText := SubItems[idxSub]; //zapis pozycji podrozdziałów
w := Length(sText); pText := StrAlloc(Length(sText) + 1);
StrPLCopy(pText, sText, Length(sText)); F.Write(w, SizeOf(w));
F.Write(pText^, w); StrDispose(pText); end; end; end; end; end;
F.Free; end;
end;
procedure TForm1.LoadListViewToFile(AListView: TListView; sFileName: string);
var F: TFileStream; IdxItem, IdxSubItem, IdxImage: Integer; W, ItemCount, SubCount: Word;
pText: PChar; PTemp: PChar; MySignature: array[0..2] of Char; sExeName: string;
begin
with AListView do begin
ItemCount := 0; SubCount := 0; sExeName := ExtractFileName(sFileName);
if not FileExists(sFileName) then
begin
MessageBox(Handle, PChar(Format(Msg1, [sExeName])), 'I/O Error', MB_ICONERROR);
Exit;
end;
F := TFileStream.Create(sFileName, fmOpenRead);
F.Read(MySignature, SizeOf(MySignature));
if MySignature < > 'LVF' then
begin
MessageBox(Handle, PChar(Format(Msg2, [sExeName])), 'I/O Error', MB_ICONERROR);
Exit;
end;
F.Read(ItemCount, SizeOf(ItemCount)); Items.Clear;
for idxItem := 1 to ItemCount do
begin
with Items.Add do begin
F.Read(SubCount, SizeOf(SubCount)); //odczyt indeksu obrazka
F.Read(IdxImage, SizeOf(IdxImage)); ImageIndex := IdxImage;
F.Read(w, SizeOf(w)); //odczyt tekstu tytułu
pText := StrAlloc(w + 1); pTemp := StrAlloc(w + 1); F.Read(pTemp^, W);
StrLCopy(pText, pTemp, W); Caption := StrPas(pText); StrDispose(pTemp);
StrDispose(pText); if SubCount > 0 then
begin
for idxSubItem := 1 to SubCount do
begin
F.Read(w, SizeOf(w)); pText := StrAlloc(w + 1); pTemp := StrAlloc(w + 1);
F.Read(pTemp^, W); StrLCopy(pText, pTemp, W);
Items[idxItem - 1].SubItems.Add(StrPas(pText)); StrDispose(pTemp);
StrDispose(pText); end; end; end; end;
F.Free; end;
end;
// przykłady:
procedure TForm1.Button1Click(Sender: TObject);
begin
// Zapis pozycji ListViewa do pliku i wymazanie go
SaveListViewToFile(ListView1, 'MyListView.sav');
ListView1.Items.Clear;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
//Odczyt pozycji z pliku
LoadListViewToFile(ListView1, 'MyListView.sav');
end;
Poniższy przykład pokazuje, wszystkie pliki w katalogach i związane z nimi ikony. Testując kod musisz mieć ListView1 i ImageList1 w którym ikony są przechowywane.
uses ShellApi;
procedure LV_InsertFiles(strPath: string; ListView: TListView; ImageList: TImageList);
var i: Integer; Icon: TIcon; SearchRec: TSearchRec; ListItem: TListItem; FileInfo: SHFILEINFO;
begin
Icon := TIcon.Create; // tworzenie tymczasowego TIcon
ListView.Items.BeginUpdate;
try
i := FindFirst(strPath + '*.*' , faAnyFile, SearchRec); // szukanie pierwszego pliku
while i = 0 do begin with ListView do
begin // w katalogach i woluminach
if ((SearchRec.Attr and FaDirectory < > FaDirectory) and
(SearchRec.Attr and FaVolumeId < > FaVolumeID)) then
begin
ListItem := ListView.Items.Add; //pobierz wyświetlaną nazwę
SHGetFileInfo(PChar(strPath + SearchRec.Name), 0, FileInfo,
SizeOf(FileInfo), SHGFI_DISPLAYNAME);
Listitem.Caption := FileInfo.szDisplayName; // pobierz typ pliku
SHGetFileInfo(PChar(strPath + SearchRec.Name), 0, FileInfo,
SizeOf(FileInfo), SHGFI_TYPENAME);
ListItem.SubItems.Add(FileInfo.szTypeName); //pobierz jego ikonę
SHGetFileInfo(PChar(strPath + SearchRec.Name), 0, FileInfo,
SizeOf(FileInfo), SHGFI_ICON or SHGFI_SMALLICON);
icon.Handle := FileInfo.hIcon;
ListItem.ImageIndex := ImageList.AddIcon(Icon);
DestroyIcon(FileInfo.hIcon); // zniszcz ikonę i szukaj następnego....
end; end; i := FindNext(SearchRec); end;
finally Icon.Free; ListView.Items.EndUpdate; end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ListView1.SmallImages := ImageList1;// dołącz Imagelist do ListView
ListView1.ViewStyle := vsReport; // pokaż stylListview - Report z 2 kolumnami
ListView1.Columns.Add; ListView1.Columns.Add;
LV_InsertFiles('C:Windows', ListView1, ImageList1);
end;
function MoveListViewItem(listView: TListView; ItemFrom, ItemTo: Word): Boolean;
var Source, Target: TListItem;
begin
Result := False; listview.Items.BeginUpdate;
try
Source := listview.Items[ItemFrom]; Target := listview.Items.Insert(ItemTo);
Target.Assign(Source); Source.Free; Result := True;
finally listview.Items.EndUpdate; end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin // Listview1.ViewStyle := vsReport;
if MoveListViewItem(Listview1, 1, 4) then // przemieszcza 1 element za 4ty
ShowMessage(' Element przemieszczony.');
end;
function CustomDateSortProc(Item1, Item2: TListItem; ParamSort: integer): integer; stdcall;
begin
result := 0;
if strtodatetime(item1.SubItems[0]) > strtodatetime(item2.SubItems[0]) then
Result := 1
else if strtodatetime(item1.SubItems[0]) < strtodatetime(item2.SubItems[0])
then Result := -1;
end;
function CustomNameSortProc(Item1, Item2: TListItem; ParamSort: integer): integer
begin
item.Caption := sr.name; Item.SubItems.Add(datetimetostr(filedatetodatetime(sr.time)));
end;
until FindNext(sr) < > 0; FindClose(sr);
end;
procedure TForm1.lv1ColumnClick(Sender: TObject; Column: TListColumn);
begin
if column = lv1.columns[0] then
LV1.CustomSort(@CustomNameSortProc, 0)
else
LV1.CustomSort(@CustomDateSortProc, 0)
end;
Wariant 1 - wyszukiwanie zadanej frazy tekstu (jako Value) przez wywołanie funkcji FindCaption
function FindCaption(StartIndex: Integer; Value: string; Partial, Inclusive, Wrap: Boolean): TListItem;
//wywołanie:
procedure TForm1.Button1Click(Sender: TObject);
var lvItem: TListItem;
begin
lvItem := ListView1.FindCaption(0, // StartIndex: Integer;
'99', // Szukana fraza: string;
True, // Partial,
True, // Inclusive
False); // Wrap : boolean;
if lvItem < > nil then
begin
ListView1.Selected := lvItem; lvItem.MakeVisible(True); ListView1.SetFocus; end;
end;
Wariant 2:
function FindListViewItem(lv: TListView; const S: string; column: Integer): TListItem;
var i: Integer; found: Boolean;
begin
Assert(Assigned(lv)); Assert((lv.viewstyle = vsReport) or (column = 0)); Assert(S < > '');
for i := 0 to lv.Items.Count - 1 do
begin
Result := lv.Items[i]; if column = 0 then
found := AnsiCompareText(Result.Caption, S) = 0
else
if column > 0 then found := AnsiCompareText(Result.SubItems[column - 1], S) = 0
else
found := False; if found then Exit; end;
Result := nil; // jak nie ma frazy to tutaj...
end;
// Wywołanie szukania - szukana fraza wpisywana w TEdit:
procedure TForm1.Button1Click(Sender: TObject);
var lvItem: TListItem;
begin
// Szukanie pierwszego wystąpienia tekstu z Edit1
lvItem := FindListViewItem(ListView1, Edit1.Text, 1);
// jak znaleziono to pokaż pozycję
if lvItem < > nil then
begin
ListView1.Selected := lvItem; lvItem.MakeVisible(True); ListView1.SetFocus; end;
end;
Wariant 3:
// Funkcja wyszukiwania i zaznaczania pozycji:
procedure LV_FindAndSelectItems(lv: TListView; const S: string; column: Integer);
var i: Integer; found: Boolean; lvItem: TListItem;
begin
Assert(Assigned(lv)); Assert((lv.ViewStyle = vsReport) or (column = 0));
Assert(S < > ''); for i := 0 to lv.Items.Count - 1 do
begin
lvItem := lv.Items[i]; if column = 0 then
found := AnsiCompareText(lvItem.Caption, S) = 0
else if column > 0 then
begin
if lvItem.SubItems.Count >= Column then
found := AnsiCompareText(lvItem.SubItems[column - 1], S) = 0
else found := False; end
else
found := False; if found then
begin
lv.Selected := lvItem; end; end;
end;
//wywołanie:
procedure TForm1.Button1Click(Sender: TObject);
var lvItem: TListItem;
begin
LV_FindAndSelectItems(ListView1, Edit1.Text, 1); ListView1.SetFocus;
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ł. Ponizszy 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.Button2Click(Sender: TObject);
var S: TFileStream;
begin
S := TFileStream.Create('C:\Plik_Outline.dat', fmCreate);
try S.WriteComponent(Outline1);
finally S.Free; end;
end;
procedure TForm1.Button3Click(Sender: TObject);
var S: TFileStream;
begin
S := TFileStream.Create('C:\Plik_Outline.dat', fmOpenRead);
try S.ReadComponent(Outline1);
finally S.Free; end;
end;
procedure Popup(Sender: TWinControl; pm: TPopupMenu);
var xPoint: TPoint;
begin
GetParentForm(TWinControl(Sender)).SendCancelMode(nil);
pm.PopupComponent := TWinControl(Sender);
xPoint := Point(-1, TWinControl(Sender).Height);
with TWinControl(Sender).ClientToScreen(xPoint) do pm.Popup(x, y);
end;
// przykład - Popup menu pokazuje się po kliku na btnResplan:
procedure TfmResplan.btnResplanPrintClick(Sender: TObject);
begin
Popup(Sender, pmPrint);
end;
//wariant wolny - nie zalecany
for i := 0 to pred(MyTreeView.Items.Count) do
begin
if MyTreeView.Items[i].Text = 'szukana fraza' then break;
end;
Wyżej pokazany przykład w drzewie liczącym 171 węzłów (pozycji) odnajduje szukaną frazę w czasie 2.15 sekund; poniżej przedstawiony przykład taką frazę odnajduje w 33 milisekund.
Noddy := MyTreeView.Items[0];
Searching := true;
while (Searching) and (Noddy < > nil) do
begin
if Noddy.text = SearchTarget then
begin
Searching := False; MyTreeView.Selected := Noddy; MyTreeView.SetFocus;
end else begin
Noddy := Noddy.GetNext end;
end;
Wariant 1:
uses CommCtrl;
procedure TForm1.Button1Click(Sender: TObject);
begin
Progressbar1.Brush.Color := clTeal; // ustaw tło na kolor teal
//ustaw kolor paska postępu na żółty
SendMessage(ProgressBar1.Handle, PBM_SETBARCOLOR, 0, clYellow);
end;
Wariant 2 - najprościej bez zmian ustawień systemowych:
PostMessage(ProgressBar1.Handle, $0409, 0, clGreen); //zielony
procedure TForm1.Button1Click(Sender: TObject);
var bm : TBitmap; il : TImageList;
begin
bm := TBitmap.Create; bm.LoadFromFile('C:\DownLoadTEST.BMP');
il := TImageList.CreateSize(bm.Width,bm.Height);
il.DrawingStyle := dsTransparent; il.Masked := true; il.AddMasked(bm, clRed);
il.Draw(Form1.Canvas, 0, 0, 0); bm.Free; il.Free;
end;
function Search_And_Replace(RichEdit: TRichEdit; SearchText, ReplaceText: string): Boolean;
var startpos, Position, endpos: integer;
begin
startpos := 0; with RichEdit do
begin
endpos := Length(RichEdit.Text); Lines.BeginUpdate;
while FindText(SearchText, startpos, endpos, [stMatchCase]) < > -1 do
begin
endpos := Length(RichEdit.Text) - startpos;
Position := FindText(SearchText, startpos, endpos, [stMatchCase]);
Inc(startpos, Length(SearchText)); SetFocus; SelStart := Position;
SelLength := Length(SearchText);
richedit.clearselection; SelText := ReplaceText; end;
Lines.EndUpdate; end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Search_And_Replace(Richedit1, 'OldText', 'NewText');
end;
function SearchForText_AndSelect(RichEdit: TRichEdit; SearchText: string): Boolean;
var StartPos, Position, Endpos: Integer;
begin
StartPos := 0; with RichEdit do
begin
Endpos := Length(RichEdit.Text); Lines.BeginUpdate;
while FindText(SearchText, StartPos, Endpos, [stMatchCase]) < > -1 do
begin
Endpos := Length(RichEdit.Text) - startpos;
Position := FindText(SearchText, StartPos, Endpos, [stMatchCase]);
Inc(StartPos, Length(SearchText)); SetFocus;
SelStart := Position; SelLength := Length(SearchText); end;
Lines.EndUpdate; end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
SearchForText_AndSelect(RichEdit1, 'Adamek'); //szukana fraza
end;