neoturk: ...Create balloon tooltips ?...
{....}
uses Commctrl;
{....}
const
TTS_BALLOON = $40;
TTM_SETTITLE = (WM_USER + 32);
var
hTooltip: Cardinal;
ti: TToolInfo;
buffer : array[0..255] of char;
{....}
procedure CreateToolTips(hWnd: Cardinal);
begin
hToolTip := CreateWindowEx(0, 'Tooltips_Class32', nil, TTS_ALWAYSTIP or TTS_BALLOON,
Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT),
Integer(CW_USEDEFAULT), hWnd, 0, hInstance, nil);
if hToolTip <> 0 then
begin
SetWindowPos(hToolTip, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or
SWP_NOSIZE or SWP_NOACTIVATE);
ti.cbSize := SizeOf(TToolInfo);
ti.uFlags := TTF_SUBCLASS;
ti.hInst := hInstance;
end;
end;
procedure AddToolTip(hwnd: DWORD; lpti: PToolInfo; IconType: Integer;
Text, Title: PChar);
var
Item: THandle;
Rect: TRect;
begin
Item := hWnd;
if (Item <> 0) and (GetClientRect(Item, Rect)) then
begin
lpti.hwnd := Item;
lpti.Rect := Rect;
lpti.lpszText := Text;
SendMessage(hToolTip, TTM_ADDTOOL, 0, Integer(lpti));
FillChar(buffer, SizeOf(buffer), #0);
lstrcpy(buffer, Title);
if (IconType > 3) or (IconType < 0) then IconType := 0;
SendMessage(hToolTip, TTM_SETTITLE, IconType, Integer(@buffer));
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
CreateToolTips(Form1.Handle);
AddToolTip(Memo1.Handle, @ti, 1, 'Tooltip text', 'Title');
end;
{
IconType can be:
0 - No icon
1 - Information
2 - Warning
3 - Error
}
Delphi - .....................................
neoturk: ...Use the drawanimatedrects api ?...
{
A lot of Windows applications show a nice zooming animation when they
minimize/maximize their windows. Ofcourse you can do this too!
Microsoft provides the DrawAnimatedRects() function for this purpose and I'll
show you how to use it.
As an example I'll show how to show an animation that you can use to minimize
your application to the system tray area. This example doesn't actually minimize
the application, it only shows the animation.
First create a new application and put a button on the form. Use the following
OnClick-handler for the button:
}
procedure TForm1.Button1Click(Sender: TObject);
var
FormRect, TrayRect: TRect;
hTray: THandle;
begin
// Get handle of tray window
hTray := FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0,'TrayNotifyWnd', nil);
if hTray <> 0 then
begin
// This is the source rect for the animation.
FormRect := BoundsRect;
// Get tray window's coordinates as a TRect. This will be the animation's destination rect.
GetWindowRect(hTray, TrayRect);
{
Now perform the actual animation. Note that this code only shows the
animation. It does NOT minimize this application to the tray. I leave
that up to yourself 
Also notice that the Delphi Help documents are very wrong about this
function! Use the official MSDN docs located Microsoft's website.
Instead of IDANI_CAPTION you can also use IDANI_OPEN and IDANI_CLOSE, but
they don't seem to do anything... Maybe they are for future use?
}
if not DrawAnimatedRects(Handle, IDANI_CAPTION, FormRect, TrayRect) then
begin
MessageDlg('DrawAnimatedRects() failed!', mtError, [mbOK], 0);
end;
end
else
begin
MessageDlg('Can''t get tray window handle!', mtError, [mbOK], 0);
end;
end;
Delphi - .....................................
neoturk: ...Use the drawanimatedrects api ?...
{
A lot of Windows applications show a nice zooming animation when they
minimize/maximize their windows. Ofcourse you can do this too!
Microsoft provides the DrawAnimatedRects() function for this purpose and I'll
show you how to use it.
As an example I'll show how to show an animation that you can use to minimize
your application to the system tray area. This example doesn't actually minimize
the application, it only shows the animation.
First create a new application and put a button on the form. Use the following
OnClick-handler for the button:
}
procedure TForm1.Button1Click(Sender: TObject);
var
FormRect, TrayRect: TRect;
hTray: THandle;
begin
// Get handle of tray window
hTray := FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0,'TrayNotifyWnd', nil);
if hTray <> 0 then
begin
// This is the source rect for the animation.
FormRect := BoundsRect;
// Get tray window's coordinates as a TRect. This will be the animation's destination rect.
GetWindowRect(hTray, TrayRect);
{
Now perform the actual animation. Note that this code only shows the
animation. It does NOT minimize this application to the tray. I leave
that up to yourself
Also notice that the Delphi Help documents are very wrong about this
function! Use the official MSDN docs located Microsoft's website.
Instead of IDANI_CAPTION you can also use IDANI_OPEN and IDANI_CLOSE, but
they don't seem to do anything... Maybe they are for future use?
}
if not DrawAnimatedRects(Handle, IDANI_CAPTION, FormRect, TrayRect) then
begin
MessageDlg('DrawAnimatedRects() failed!', mtError, [mbOK], 0);
end;
end
else
begin
MessageDlg('Can''t get tray window handle!', mtError, [mbOK], 0);
end;
end;
Delphi - .....................................
neoturk: ...Create a graphical hint ?...
{*********************************************************
Mit Hilfe des folgendes Codes lassen sich leicht beliebige
Hints erstellen. Dazu muss nur dir Prozedur "Paint" den
Wünschen entsprechend angepasst werden.
With the following Code you can simply create custom hints.
You just have to change the procedur "Paint".
*********************************************************}
type
TGraphicHintWindow = class(THintWindow)
constructor Create(AOwner: TComponent); override;
private
FActivating: Boolean;
public
procedure ActivateHint(Rect: TRect; const AHint: string); override;
protected
procedure Paint; override;
published
property Caption;
end;
{...}
constructor TGraphicHintWindow.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
{
Hier können beliebige Schrift Eigenschaften gesetzt
werden.
Here you can set custom Font Properties:
}
with Canvas.Font do
begin
Name := 'Arial';
Style := Style + [fsBold];
Color := clBlack;
end;
end;
procedure TGraphicHintWindow.Paint;
var
R: TRect;
bmp: TBitmap;
begin
R := ClientRect;
Inc(R.Left, 2);
Inc(R.Top, 2);
{*******************************************************
Der folgende Code ist ein Beispiel wie man die Paint
Prozedur nutzen kann um einen benutzerdefinierten Hint
zu erzeugen.
The folowing Code ist an example how to create a custom
Hint Object. :
}
bmp := TBitmap.Create;
bmp.LoadfromFile('D:hint.bmp');
with Canvas do
begin
Brush.Style := bsSolid;
Brush.Color := clsilver;
Pen.Color := clgray;
Rectangle(0, 0, 18, R.Bottom + 1);
Draw(2,(R.Bottom div 2) - (bmp.Height div 2), bmp);
end;
bmp.Free;
//Beliebige HintFarbe
//custom Hint Color
Color := clWhite;
Canvas.Brush.Style := bsClear;
Canvas.TextOut(20, (R.Bottom div 2) - (Canvas.Textheight(Caption) div 2), Caption);
{********************************************************}
end;
procedure TGraphicHintWindow.ActivateHint(Rect: TRect; const AHint: string);
begin
FActivating := True;
try
Caption := AHint;
//Höhe des Hints setzen setzen
//Set the "Height" Property of the Hint
Inc(Rect.Bottom, 14);
//Breite des Hints setzen
//Set the "Width" Property of the Hint
Rect.Right := Rect.Right + 20;
UpdateBoundsRect(Rect);
if Rect.Top + Height > Screen.DesktopHeight then
Rect.Top := Screen.DesktopHeight - Height;
if Rect.Left + Width > Screen.DesktopWidth then
Rect.Left := Screen.DesktopWidth - Width;
if Rect.Left < Screen.DesktopLeft then Rect.Left := Screen.DesktopLeft;
if Rect.Bottom < Screen.DesktopTop then Rect.Bottom := Screen.DesktopTop;
SetWindowPos(Handle, HWND_TOPMOST, Rect.Left, Rect.Top, Width, Height,
SWP_SHOWWINDOW or SWP_NOACTIVATE);
Invalidate;
finally
FActivating := False;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
HintWindowClass := TGraphicHintWindow;
Application.ShowHint := False;
Application.ShowHint := True;
end;
-------------------------------------
...Know if the form is modal ?...
procedure TForm1.Button1Click(Sender: TObject);
begin
if (fsModal in FormState) then
ShowMessage('Form is modal.');
end;
Delphi - .....................................
neoturk: ...Create a graphical hint ?...
{*********************************************************
Mit Hilfe des folgendes Codes lassen sich leicht beliebige
Hints erstellen. Dazu muss nur dir Prozedur "Paint" den
Wünschen entsprechend angepasst werden.
With the following Code you can simply create custom hints.
You just have to change the procedur "Paint".
*********************************************************}
type
TGraphicHintWindow = class(THintWindow)
constructor Create(AOwner: TComponent); override;
private
FActivating: Boolean;
public
procedure ActivateHint(Rect: TRect; const AHint: string); override;
protected
procedure Paint; override;
published
property Caption;
end;
{...}
constructor TGraphicHintWindow.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
{
Hier können beliebige Schrift Eigenschaften gesetzt
werden.
Here you can set custom Font Properties:
}
with Canvas.Font do
begin
Name := 'Arial';
Style := Style + [fsBold];
Color := clBlack;
end;
end;
procedure TGraphicHintWindow.Paint;
var
R: TRect;
bmp: TBitmap;
begin
R := ClientRect;
Inc(R.Left, 2);
Inc(R.Top, 2);
{*******************************************************
Der folgende Code ist ein Beispiel wie man die Paint
Prozedur nutzen kann um einen benutzerdefinierten Hint
zu erzeugen.
The folowing Code ist an example how to create a custom
Hint Object. :
}
bmp := TBitmap.Create;
bmp.LoadfromFile('D:hint.bmp');
with Canvas do
begin
Brush.Style := bsSolid;
Brush.Color := clsilver;
Pen.Color := clgray;
Rectangle(0, 0, 18, R.Bottom + 1);
Draw(2,(R.Bottom div 2) - (bmp.Height div 2), bmp);
end;
bmp.Free;
//Beliebige HintFarbe
//custom Hint Color
Color := clWhite;
Canvas.Brush.Style := bsClear;
Canvas.TextOut(20, (R.Bottom div 2) - (Canvas.Textheight(Caption) div 2), Caption);
{********************************************************}
end;
procedure TGraphicHintWindow.ActivateHint(Rect: TRect; const AHint: string);
begin
FActivating := True;
try
Caption := AHint;
//Höhe des Hints setzen setzen
//Set the "Height" Property of the Hint
Inc(Rect.Bottom, 14);
//Breite des Hints setzen
//Set the "Width" Property of the Hint
Rect.Right := Rect.Right + 20;
UpdateBoundsRect(Rect);
if Rect.Top + Height > Screen.DesktopHeight then
Rect.Top := Screen.DesktopHeight - Height;
if Rect.Left + Width > Screen.DesktopWidth then
Rect.Left := Screen.DesktopWidth - Width;
if Rect.Left < Screen.DesktopLeft then Rect.Left := Screen.DesktopLeft;
if Rect.Bottom < Screen.DesktopTop then Rect.Bottom := Screen.DesktopTop;
SetWindowPos(Handle, HWND_TOPMOST, Rect.Left, Rect.Top, Width, Height,
SWP_SHOWWINDOW or SWP_NOACTIVATE);
Invalidate;
finally
FActivating := False;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
HintWindowClass := TGraphicHintWindow;
Application.ShowHint := False;
Application.ShowHint := True;
end;
-------------------------------------
...Know if the form is modal ?...
procedure TForm1.Button1Click(Sender: TObject);
begin
if (fsModal in FormState) then
ShowMessage('Form is modal.');
end;
Delphi - .....................................
neoturk: ...Move the cursor to the currently focused control ?...
{
Dieser Code bewirkt, dass wenn Button1 den Fokus erhält sich die Maus darauf
platziert.
}
{
If Button1 receives the focus, the mouse pointer will be placed over the control.
}
//OnEnter event
procedure TForm1.Button1Enter(Sender: TObject);
var
cntl: TControl;
xCenter, yCenter: Integer;
ptBtn: TPoint;
begin
cntl := TControl(Sender);
xCenter := cntl.Left + (cntl.Width div 2);
yCenter := cntl.Top + (cntl.Height div 2);
ptBtn := ClientToScreen(Point(xCenter, yCenter));
SetCursorPos(ptBtn.X, ptBtn.Y);
end;
Delphi - .....................................
neoturk: ...Move the cursor to the currently focused control ?...
{
Dieser Code bewirkt, dass wenn Button1 den Fokus erhält sich die Maus darauf
platziert.
}
{
If Button1 receives the focus, the mouse pointer will be placed over the control.
}
//OnEnter event
procedure TForm1.Button1Enter(Sender: TObject);
var
cntl: TControl;
xCenter, yCenter: Integer;
ptBtn: TPoint;
begin
cntl := TControl(Sender);
xCenter := cntl.Left + (cntl.Width div 2);
yCenter := cntl.Top + (cntl.Height div 2);
ptBtn := ClientToScreen(Point(xCenter, yCenter));
SetCursorPos(ptBtn.X, ptBtn.Y);
end;
Delphi - .....................................
neoturk: ...Dynamically build a menu from an xml file ?...
{
The following procedure allows you to build a menu from an XML file.
Special feature: You only need to specify the Name of the procedure which then
will be attached to a OnClick handler.
Note that the procedure must be declared as public.
}
{
Mit folgender Prozedur kann man aus einem XML-File ein Menu
erstellen lassen (einfach im OnCreate aufrufen).
Besonderes Feature: Im XML-File gebt ihr nur den Namen der Prozedur an,
die dem OnClick-Ereignis zugewiesen werden soll.
Die einzige Einschränkung besteht darin, dass diese Prozedur
published sein muss.
Bindet einfach diese Prozedur in euer Hauptformular ein:
}
procedure TMainForm.CreateMenuFromXMLFile;
function Get_Int(S: string): Integer;
begin
Result := 0;
try
Result := StrToInt(S);
except
end;
end;
procedure AddRecursive(Parent: TMenuItem; Item: IXMLNode);
var
I: Integer;
Node: TMenuItem;
Child: IXMLNode;
Address: TMethod;
begin
Node := TMenuItem.Create(Parent);
if (Uppercase(Item.Attributes['CAPTION']) <> 'SEPERATOR') then
begin
Node.Caption := Item.Attributes['CAPTION'];
if (Uppercase(Item.Attributes['ID']) <> 'NONE') then
begin
Address.Code := MethodAddress(Item.Attributes['ID']);
Address.Data := Self;
if (Item.ChildNodes.Count - 1 < 0) then
Node.OnClick := TNotifyEvent(Address);
end;
if (Uppercase(Item.Attributes['SHORTCUT']) <> 'NONE') then
Node.ShortCut := TextToShortCut(Item.Attributes['SHORTCUT']);
Node.Checked := (Item.Attributes['CHECKED'] = '1');
end
else
Node.Caption := '-';
Node.Visible := (Item.Attributes['VISIBLE'] = '1');
if Parent <> nil then
Parent.Add(Node)
else
MainMenu.Items.Add(Node);
for I := 0 to Item.ChildNodes.Count - 1 do
begin
Child := item.ChildNodes[i];
if (Child.NodeName = 'ENTRY') then
AddRecursive(Node, Child);
end;
end;
var
Root: IXMLMENUType;
Parent: TMenuItem;
I: Integer;
Child: IXMLNode;
begin
XMLDocument.FileName := ExtractFilePath(Application.ExeName) + XMLFile;
if not FileExists(XMLDocument.FileName) then
begin
MessageDlg('Menu-XML-Document nicht gefunden!', mtError, [mbOK], 0);
Halt;
end;
XMLDocument.Active := True;
Screen.Cursor := crHourglass;
try
Root := GetXMLMenu(XMLDocument);
Parent := nil;
for I := 0 to Root.ChildNodes.Count - 1 do
begin
Child := Root.ChildNodes[i];
if (Child.NodeName = 'ENTRY') then
AddRecursive(Parent, Child);
end;
finally
Screen.Cursor := crDefault;
end;
end;
{----------------------------------------------------------
You also need the encapsulation of the XML-File.
( Save it as unit and add it to your program.
Created with Delphi6 -> New -> XML Data Binding Wizard )
-----------------------------------------------------------}
{----------------------------------------------------------
Natürlich braucht man auch die Kapselung des XML-Files
(Als Unit speichern und ins Programm einbinden.
Die Datei wurde mit Delphi 6 -> Neu -> XML-Datenbindung erstellt):
-----------------------------------------------------------}
{***************************************************}
{ }
{ Delphi XML-Datenbindung }
{ }
{ Erzeugt am: 27.06.2002 13:25:01 }
{ }
{***************************************************}
unit XMLMenuTranslation;
interface
uses xmldom, XMLDoc, XMLIntf;
type
{ Forward-Deklarationen }
IXMLMENUType = interface;
IXMLENTRYType = interface;
{ IXMLMENUType }
IXMLMENUType = interface(IXMLNode)
['{8F36F5E2-834F-41D9-918F-9B1A441C9074}']
{ Zugriff auf Eigenschaften }
function Get_ENTRY: IXMLENTRYType;
{ Methoden & Eigenschaften }
property ENTRY: IXMLENTRYType read Get_ENTRY;
end;
{ IXMLENTRYType }
IXMLENTRYType = interface(IXMLNode)
['{AD85CD05-725E-40F8-A8D7-D6EC05FD4360}']
{ Zugriff auf Eigenschaften }
function Get_CAPTION: WideString;
function Get_VISIBLE: Integer;
function Get_ID: Integer;
function Get_ENTRY: IXMLENTRYType;
procedure Set_CAPTION(Value: WideString);
procedure Set_VISIBLE(Value: Integer);
procedure Set_ID(Value: Integer);
{ Methoden & Eigenschaften }
property Caption: WideString read Get_CAPTION write Set_CAPTION;
property Visible: Integer read Get_VISIBLE write Set_VISIBLE;
property ID: Integer read Get_ID write Set_ID;
property ENTRY: IXMLENTRYType read Get_ENTRY;
end;
{ Forward-Deklarationen }
TXMLMENUType = class;
TXMLENTRYType = class;
{ TXMLMENUType }
TXMLMENUType = class(TXMLNode, IXMLMENUType)
protected
{ IXMLMENUType }
function Get_ENTRY: IXMLENTRYType;
public
procedure AfterConstruction; override;
end;
{ TXMLENTRYType }
TXMLENTRYType = class(TXMLNode, IXMLENTRYType)
protected
{ IXMLENTRYType }
function Get_CAPTION: WideString;
function Get_VISIBLE: Integer;
function Get_ID: Integer;
function Get_ENTRY: IXMLENTRYType;
procedure Set_CAPTION(Value: WideString);
procedure Set_VISIBLE(Value: Integer);
procedure Set_ID(Value: Integer);
public
procedure AfterConstruction; override;
end;
{ Globale Funktionen }
function GetXMLMENU(Doc: IXMLDocument): IXMLMENUType;
function LoadMENU(const FileName: WideString): IXMLMENUType;
function NewMENU: IXMLMENUType;
implementation
{ Globale Funktionen }
function GetXMLMENU(Doc: IXMLDocument): IXMLMENUType;
begin
Result := Doc.GetDocBinding('MENU', TXMLMENUType) as IXMLMENUType;
end;
function LoadMENU(const FileName: WideString): IXMLMENUType;
begin
Result := LoadXMLDocument(FileName).GetDocBinding('MENU', TXMLMENUType) as IXMLMENUType;
end;
function NewMENU: IXMLMENUType;
begin
Result := NewXMLDocument.GetDocBinding('MENU', TXMLMENUType) as IXMLMENUType;
end;
{ TXMLMENUType }
procedure TXMLMENUType.AfterConstruction;
begin
RegisterChildNode('ENTRY', TXMLENTRYType);
inherited;
end;
function TXMLMENUType.Get_ENTRY: IXMLENTRYType;
begin
Result := ChildNodes['ENTRY'] as IXMLENTRYType;
end;
{ TXMLENTRYType }
procedure TXMLENTRYType.AfterConstruction;
begin
RegisterChildNode('ENTRY', TXMLENTRYType);
inherited;
end;
function TXMLENTRYType.Get_CAPTION: WideString;
begin
Result := ChildNodes['CAPTION'].Text;
end;
procedure TXMLENTRYType.Set_CAPTION(Value: WideString);
begin
ChildNodes['CAPTION'].NodeValue := Value;
end;
function TXMLENTRYType.Get_VISIBLE: Integer;
begin
Result := ChildNodes['VISIBLE'].NodeValue;
end;
procedure TXMLENTRYType.Set_VISIBLE(Value: Integer);
begin
ChildNodes['VISIBLE'].NodeValue := Value;
end;
function TXMLENTRYType.Get_ID: Integer;
begin
Result := ChildNodes['ID'].NodeValue;
end;
procedure TXMLENTRYType.Set_ID(Value: Integer);
begin
ChildNodes['ID'].NodeValue := Value;
end;
function TXMLENTRYType.Get_ENTRY: IXMLENTRYType;
begin
Result := ChildNodes['ENTRY'] as IXMLENTRYType;
end;
end.
{---------------------------------------------------------------------
Finally, I'll show you an example for the XML-File.
The Procedure Name is assigned to the ID which then will be called.
---------------------------------------------------------------------}
{---------------------------------------------------------------------
Als Beispiel für das XML-File hier noch eines aus
einem meiner Programme.
In ID steht der Name der Prozedur, die man als OnClick aufrufen will
- denkt auch daran, dass diese Prozedur unbedingt als published
deklariert sein muss, sonst liefert MethodAddress() Nil zurück.
----------------------------------------------------------------------}
{
<?xml version="1.0" encoding="ISO-8859-1"?>
<MENU>
<ENTRY CAPTION="Datei" VISIBLE="1" ID="None" SHORTCUT="None" CHECKED="0">
<ENTRY CAPTION="Beenden" VISIBLE="1" ID="CloseProgram" SHORTCUT="Strg+X" CHECKED="0"></ENTRY>
</ENTRY>
<ENTRY CAPTION="Anzeige" VISIBLE="1" ID="None" SHORTCUT="None" CHECKED="0">
<ENTRY CAPTION="Toolbar" VISIBLE="1" ID="ShowToolbar" SHORTCUT="None" CHECKED="1"></ENTRY>
<ENTRY CAPTION="Seperator" VISIBLE="1"></ENTRY>
<ENTRY CAPTION="Optionen" VISIBLE="1" ID="ShowOptionen" SHORTCUT="Strg+O" CHECKED="0"></ENTRY>
</ENTRY>
<ENTRY CAPTION="News" VISIBLE="1" ID="None" SHORTCUT="None" CHECKED="0">
<ENTRY CAPTION="Refresh" VISIBLE="1" ID="RefreshAll" SHORTCUT="F5" CHECKED="0"></ENTRY>
<ENTRY CAPTION="Seperator" VISIBLE="1"></ENTRY>
<ENTRY CAPTION="Administration" VISIBLE="1" ID="None" SHORTCUT="None" CHECKED="0">
<ENTRY CAPTION="neue Nachricht hinzufügen" VISIBLE="1" ID="NewMarkedNews" SHORTCUT="Strg+N" CHECKED="0"></ENTRY>
<ENTRY CAPTION="markierte Nachricht bearbeiten" VISIBLE="1" ID="EditMarkedNews" SHORTCUT="Strg+E" CHECKED="0"></ENTRY>
<ENTRY CAPTION="markierte Nachricht löschen" VISIBLE="1" ID="DeleteMarkedNews" SHORTCUT="None" CHECKED="0"></ENTRY>
<ENTRY CAPTION="Seperator" VISIBLE="1"></ENTRY>
<ENTRY CAPTION="Film hinzufügen" VISIBLE="1" ID="AddMPG" SHORTCUT="None" CHECKED="0"></ENTRY>
<ENTRY CAPTION="markierten Film löschen" VISIBLE="1" ID="DeleteMPG" SHORTCUT="None" CHECKED="0"></ENTRY>
</ENTRY>
</ENTRY>
<ENTRY CAPTION="Hilfe" VISIBLE="1" ID="None" SHORTCUT="None" CHECKED="0">
<ENTRY CAPTION="LogView" VISIBLE="1" ID="ShowLog" SHORTCUT="Strg+L" CHECKED="0"></ENTRY>
<ENTRY CAPTION="eMail schreiben" VISIBLE="1" ID="WriteEMail" SHORTCUT="None" CHECKED="0"></ENTRY>
<ENTRY CAPTION="Seperator" VISIBLE="1"></ENTRY>
<ENTRY CAPTION="Über" VISIBLE="1" ID="About" SHORTCUT="None" CHECKED="0"></ENTRY>
</ENTRY>
</MENU>
}
Delphi - .....................................
neoturk: ...Dynamically build a menu from an xml file ?...
{
The following procedure allows you to build a menu from an XML file.
Special feature: You only need to specify the Name of the procedure which then
will be attached to a OnClick handler.
Note that the procedure must be declared as public.
}
{
Mit folgender Prozedur kann man aus einem XML-File ein Menu
erstellen lassen (einfach im OnCreate aufrufen).
Besonderes Feature: Im XML-File gebt ihr nur den Namen der Prozedur an,
die dem OnClick-Ereignis zugewiesen werden soll.
Die einzige Einschränkung besteht darin, dass diese Prozedur
published sein muss.
Bindet einfach diese Prozedur in euer Hauptformular ein:
}
procedure TMainForm.CreateMenuFromXMLFile;
function Get_Int(S: string): Integer;
begin
Result := 0;
try
Result := StrToInt(S);
except
end;
end;
procedure AddRecursive(Parent: TMenuItem; Item: IXMLNode);
var
I: Integer;
Node: TMenuItem;
Child: IXMLNode;
Address: TMethod;
begin
Node := TMenuItem.Create(Parent);
if (Uppercase(Item.Attributes['CAPTION']) <> 'SEPERATOR') then
begin
Node.Caption := Item.Attributes['CAPTION'];
if (Uppercase(Item.Attributes['ID']) <> 'NONE') then
begin
Address.Code := MethodAddress(Item.Attributes['ID']);
Address.Data := Self;
if (Item.ChildNodes.Count - 1 < 0) then
Node.OnClick := TNotifyEvent(Address);
end;
if (Uppercase(Item.Attributes['SHORTCUT']) <> 'NONE') then
Node.ShortCut := TextToShortCut(Item.Attributes['SHORTCUT']);
Node.Checked := (Item.Attributes['CHECKED'] = '1');
end
else
Node.Caption := '-';
Node.Visible := (Item.Attributes['VISIBLE'] = '1');
if Parent <> nil then
Parent.Add(Node)
else
MainMenu.Items.Add(Node);
for I := 0 to Item.ChildNodes.Count - 1 do
begin
Child := item.ChildNodes[i];
if (Child.NodeName = 'ENTRY') then
AddRecursive(Node, Child);
end;
end;
var
Root: IXMLMENUType;
Parent: TMenuItem;
I: Integer;
Child: IXMLNode;
begin
XMLDocument.FileName := ExtractFilePath(Application.ExeName) + XMLFile;
if not FileExists(XMLDocument.FileName) then
begin
MessageDlg('Menu-XML-Document nicht gefunden!', mtError, [mbOK], 0);
Halt;
end;
XMLDocument.Active := True;
Screen.Cursor := crHourglass;
try
Root := GetXMLMenu(XMLDocument);
Parent := nil;
for I := 0 to Root.ChildNodes.Count - 1 do
begin
Child := Root.ChildNodes[i];
if (Child.NodeName = 'ENTRY') then
AddRecursive(Parent, Child);
end;
finally
Screen.Cursor := crDefault;
end;
end;
{----------------------------------------------------------
You also need the encapsulation of the XML-File.
( Save it as unit and add it to your program.
Created with Delphi6 -> New -> XML Data Binding Wizard )
-----------------------------------------------------------}
{----------------------------------------------------------
Natürlich braucht man auch die Kapselung des XML-Files
(Als Unit speichern und ins Programm einbinden.
Die Datei wurde mit Delphi 6 -> Neu -> XML-Datenbindung erstellt):
-----------------------------------------------------------}
{***************************************************}
{ }
{ Delphi XML-Datenbindung }
{ }
{ Erzeugt am: 27.06.2002 13:25:01 }
{ }
{***************************************************}
unit XMLMenuTranslation;
interface
uses xmldom, XMLDoc, XMLIntf;
type
{ Forward-Deklarationen }
IXMLMENUType = interface;
IXMLENTRYType = interface;
{ IXMLMENUType }
IXMLMENUType = interface(IXMLNode)
['{8F36F5E2-834F-41D9-918F-9B1A441C9074}']
{ Zugriff auf Eigenschaften }
function Get_ENTRY: IXMLENTRYType;
{ Methoden & Eigenschaften }
property ENTRY: IXMLENTRYType read Get_ENTRY;
end;
{ IXMLENTRYType }
IXMLENTRYType = interface(IXMLNode)
['{AD85CD05-725E-40F8-A8D7-D6EC05FD4360}']
{ Zugriff auf Eigenschaften }
function Get_CAPTION: WideString;
function Get_VISIBLE: Integer;
function Get_ID: Integer;
function Get_ENTRY: IXMLENTRYType;
procedure Set_CAPTION(Value: WideString);
procedure Set_VISIBLE(Value: Integer);
procedure Set_ID(Value: Integer);
{ Methoden & Eigenschaften }
property Caption: WideString read Get_CAPTION write Set_CAPTION;
property Visible: Integer read Get_VISIBLE write Set_VISIBLE;
property ID: Integer read Get_ID write Set_ID;
property ENTRY: IXMLENTRYType read Get_ENTRY;
end;
{ Forward-Deklarationen }
TXMLMENUType = class;
TXMLENTRYType = class;
{ TXMLMENUType }
TXMLMENUType = class(TXMLNode, IXMLMENUType)
protected
{ IXMLMENUType }
function Get_ENTRY: IXMLENTRYType;
public
procedure AfterConstruction; override;
end;
{ TXMLENTRYType }
TXMLENTRYType = class(TXMLNode, IXMLENTRYType)
protected
{ IXMLENTRYType }
function Get_CAPTION: WideString;
function Get_VISIBLE: Integer;
function Get_ID: Integer;
function Get_ENTRY: IXMLENTRYType;
procedure Set_CAPTION(Value: WideString);
procedure Set_VISIBLE(Value: Integer);
procedure Set_ID(Value: Integer);
public
procedure AfterConstruction; override;
end;
{ Globale Funktionen }
function GetXMLMENU(Doc: IXMLDocument): IXMLMENUType;
function LoadMENU(const FileName: WideString): IXMLMENUType;
function NewMENU: IXMLMENUType;
implementation
{ Globale Funktionen }
function GetXMLMENU(Doc: IXMLDocument): IXMLMENUType;
begin
Result := Doc.GetDocBinding('MENU', TXMLMENUType) as IXMLMENUType;
end;
function LoadMENU(const FileName: WideString): IXMLMENUType;
begin
Result := LoadXMLDocument(FileName).GetDocBinding('MENU', TXMLMENUType) as IXMLMENUType;
end;
function NewMENU: IXMLMENUType;
begin
Result := NewXMLDocument.GetDocBinding('MENU', TXMLMENUType) as IXMLMENUType;
end;
{ TXMLMENUType }
procedure TXMLMENUType.AfterConstruction;
begin
RegisterChildNode('ENTRY', TXMLENTRYType);
inherited;
end;
function TXMLMENUType.Get_ENTRY: IXMLENTRYType;
begin
Result := ChildNodes['ENTRY'] as IXMLENTRYType;
end;
{ TXMLENTRYType }
procedure TXMLENTRYType.AfterConstruction;
begin
RegisterChildNode('ENTRY', TXMLENTRYType);
inherited;
end;
function TXMLENTRYType.Get_CAPTION: WideString;
begin
Result := ChildNodes['CAPTION'].Text;
end;
procedure TXMLENTRYType.Set_CAPTION(Value: WideString);
begin
ChildNodes['CAPTION'].NodeValue := Value;
end;
function TXMLENTRYType.Get_VISIBLE: Integer;
begin
Result := ChildNodes['VISIBLE'].NodeValue;
end;
procedure TXMLENTRYType.Set_VISIBLE(Value: Integer);
begin
ChildNodes['VISIBLE'].NodeValue := Value;
end;
function TXMLENTRYType.Get_ID: Integer;
begin
Result := ChildNodes['ID'].NodeValue;
end;
procedure TXMLENTRYType.Set_ID(Value: Integer);
begin
ChildNodes['ID'].NodeValue := Value;
end;
function TXMLENTRYType.Get_ENTRY: IXMLENTRYType;
begin
Result := ChildNodes['ENTRY'] as IXMLENTRYType;
end;
end.
{---------------------------------------------------------------------
Finally, I'll show you an example for the XML-File.
The Procedure Name is assigned to the ID which then will be called.
---------------------------------------------------------------------}
{---------------------------------------------------------------------
Als Beispiel für das XML-File hier noch eines aus
einem meiner Programme.
In ID steht der Name der Prozedur, die man als OnClick aufrufen will
- denkt auch daran, dass diese Prozedur unbedingt als published
deklariert sein muss, sonst liefert MethodAddress() Nil zurück.
----------------------------------------------------------------------}
{
<?xml version="1.0" encoding="ISO-8859-1"?>
<MENU>
<ENTRY CAPTION="Datei" VISIBLE="1" ID="None" SHORTCUT="None" CHECKED="0">
<ENTRY CAPTION="Beenden" VISIBLE="1" ID="CloseProgram" SHORTCUT="Strg+X" CHECKED="0"></ENTRY>
</ENTRY>
<ENTRY CAPTION="Anzeige" VISIBLE="1" ID="None" SHORTCUT="None" CHECKED="0">
<ENTRY CAPTION="Toolbar" VISIBLE="1" ID="ShowToolbar" SHORTCUT="None" CHECKED="1"></ENTRY>
<ENTRY CAPTION="Seperator" VISIBLE="1"></ENTRY>
<ENTRY CAPTION="Optionen" VISIBLE="1" ID="ShowOptionen" SHORTCUT="Strg+O" CHECKED="0"></ENTRY>
</ENTRY>
<ENTRY CAPTION="News" VISIBLE="1" ID="None" SHORTCUT="None" CHECKED="0">
<ENTRY CAPTION="Refresh" VISIBLE="1" ID="RefreshAll" SHORTCUT="F5" CHECKED="0"></ENTRY>
<ENTRY CAPTION="Seperator" VISIBLE="1"></ENTRY>
<ENTRY CAPTION="Administration" VISIBLE="1" ID="None" SHORTCUT="None" CHECKED="0">
<ENTRY CAPTION="neue Nachricht hinzufügen" VISIBLE="1" ID="NewMarkedNews" SHORTCUT="Strg+N" CHECKED="0"></ENTRY>
<ENTRY CAPTION="markierte Nachricht bearbeiten" VISIBLE="1" ID="EditMarkedNews" SHORTCUT="Strg+E" CHECKED="0"></ENTRY>
<ENTRY CAPTION="markierte Nachricht löschen" VISIBLE="1" ID="DeleteMarkedNews" SHORTCUT="None" CHECKED="0"></ENTRY>
<ENTRY CAPTION="Seperator" VISIBLE="1"></ENTRY>
<ENTRY CAPTION="Film hinzufügen" VISIBLE="1" ID="AddMPG" SHORTCUT="None" CHECKED="0"></ENTRY>
<ENTRY CAPTION="markierten Film löschen" VISIBLE="1" ID="DeleteMPG" SHORTCUT="None" CHECKED="0"></ENTRY>
</ENTRY>
</ENTRY>
<ENTRY CAPTION="Hilfe" VISIBLE="1" ID="None" SHORTCUT="None" CHECKED="0">
<ENTRY CAPTION="LogView" VISIBLE="1" ID="ShowLog" SHORTCUT="Strg+L" CHECKED="0"></ENTRY>
<ENTRY CAPTION="eMail schreiben" VISIBLE="1" ID="WriteEMail" SHORTCUT="None" CHECKED="0"></ENTRY>
<ENTRY CAPTION="Seperator" VISIBLE="1"></ENTRY>
<ENTRY CAPTION="Über" VISIBLE="1" ID="About" SHORTCUT="None" CHECKED="0"></ENTRY>
</ENTRY>
</MENU>
}
Delphi - .....................................
neoturk: ...Allow to move form only within working area ?...
{ .... }
type
TForm1 = class(TForm)
private
protected
procedure WMMoving(var Message: TWMMoving); message WM_MOVING;
public
end;
{ .... }
procedure TForm1.WMMoving(var Message: TWMMoving);
var
rec: ^TRect;
wrk: TRect;
begin
SystemParametersInfo(spi_getworkarea, 0, @wrk, 0);
rec := Pointer(Message.DragRect);
if rec^.Left < wrk.Left then
begin
rec^.Right := rec^.Right - (rec^.Left - wrk.Left);
rec^.Left := wrk.Left;
end
else if rec^.Right > wrk.Right then
begin
rec^.Left := rec^.Left - (rec^.Right - wrk.Right);
rec^.Right := wrk.Right;
end;
if rec^.Top < wrk.Top then
begin
rec^.Bottom := rec^.Bottom - (rec^.Top - wrk.Top);
rec^.Top := wrk.Top;
end
else if rec^.Bottom > wrk.Bottom then
begin
rec^.Top := rec^.Top - (rec^.Bottom - wrk.Bottom);
rec^.Bottom := wrk.Bottom;
end;
end;
Delphi - .....................................
neoturk: ...Allow to move form only within working area ?...
{ .... }
type
TForm1 = class(TForm)
private
protected
procedure WMMoving(var Message: TWMMoving); message WM_MOVING;
public
end;
{ .... }
procedure TForm1.WMMoving(var Message: TWMMoving);
var
rec: ^TRect;
wrk: TRect;
begin
SystemParametersInfo(spi_getworkarea, 0, @wrk, 0);
rec := Pointer(Message.DragRect);
if rec^.Left < wrk.Left then
begin
rec^.Right := rec^.Right - (rec^.Left - wrk.Left);
rec^.Left := wrk.Left;
end
else if rec^.Right > wrk.Right then
begin
rec^.Left := rec^.Left - (rec^.Right - wrk.Right);
rec^.Right := wrk.Right;
end;
if rec^.Top < wrk.Top then
begin
rec^.Bottom := rec^.Bottom - (rec^.Top - wrk.Top);
rec^.Top := wrk.Top;
end
else if rec^.Bottom > wrk.Bottom then
begin
rec^.Top := rec^.Top - (rec^.Bottom - wrk.Bottom);
rec^.Bottom := wrk.Bottom;
end;
end;
Delphi - .....................................
neoturk: ...Easily move-resize components at runtime ?...
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Dieser Tip enthält eine Klasse mit der man zur Laufzeit Komponenten
in der Größe verändern bzw verschieben kann so wie man es aus der
Entwicklungsumgebung her gewohnt ist.
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
This Tip provides a tool class that implements the functionality of
moving or resizing any component at runtime (as in the IDE)
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
//Als eigne Unit
unit Egal;
interface
uses Controls, ExtCtrls, QGraphics, Classes, SysUtils, StdCtrls;
type
Markierungen = class
constructor Create(Komponente: TControl);
destructor Destroy();
private
panels: array[0..7] of TPanel;
LblPos: TPanel;
Komp: TControl;
FDownX, FDownY: Integer;
FDragging: Boolean;
OrgMDown, OrgMUp: TMouseEvent;
OrgMMove: TMouseMoveEvent;
OrgMClick: TNotifyEvent;
procedure panelsMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure panelsMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure panelsMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure NewPos();
end;
implementation
type
TMoveCracker = class(TControl);
constructor Markierungen.Create(Komponente: TControl);
var
i: Byte;
begin
Komp := Komponente;
for i := 0 to 7 do
begin //Die acht Markierungspunkte erstellen.
panels[i] := TPanel.Create(Komponente);
panels[i].Parent := Komponente.Parent;
panels[i].Width := 5;
panels[i].Height := 5;
panels[i].Color := clBlack;
panels[i].BevelOuter := bvNone;
panels[i].OnMouseDown := panelsMouseDown;
panels[i].OnMouseMove := panelsMouseMove;
panels[i].OnMouseUp := panelsMouseUp;
panels[i].Tag := i;
end;
NewPos(); //Die Markierungen an die richtige Position bringen
OrgMDown := TPanel(Komp).OnMouseDown; //Sicheren der orginalen Mousereignisse
OrgMUp := TPanel(Komp).OnMouseUp;
OrgMMove := TPanel(Komp).OnMouseMove;
OrgMClick := TPanel(Komp).OnClick;
TPanel(Komp).OnClick := nil; //für funktionen benötige Ereignisse zuweisen
TPanel(Komp).OnMouseDown := panelsMouseDown;
TPanel(Komp).OnMouseUp := panelsMouseUp;
TPanel(Komp).OnMouseMove := panelsMouseMove;
LblPos := TPanel.Create(Komp); //gibt beim Verschieben größe bzw Position an
with LblPos do
begin
Parent := Komp.Parent;
Visible := False;
BevelOuter := bvNone;
Color := clYellow;
Height := 16;
Width := 50;
end;
end;
procedure Markierungen.NewPos();
begin
panels[0].Left := Komp.Left - 2;
panels[0].Top := Komp.Top - 2;
panels[1].Left := Komp.Left + Komp.Width div 2;
panels[1].Top := Komp.Top - 2;
panels[2].Left := Komp.Left + Komp.Width - 2;
panels[2].Top := Komp.Top - 2;
panels[3].Left := Komp.Left + Komp.Width - 2;
panels[3].Top := Komp.Top + Komp.Height - 2;
panels[4].Left := Komp.Left + Komp.Width div 2;
panels[4].Top := Komp.Top + Komp.Height - 2;
panels[5].Left := Komp.Left - 2;
panels[5].Top := Komp.Top + Komp.Height - 2;
panels[6].Left := Komp.Left - 2;
panels[6].Top := Komp.Top + Komp.Height div 2 - 1;
panels[7].Left := Komp.Left + Komp.Width - 2;
panels[7].Top := Komp.Top + Komp.Height div 2 - 1;
end;
destructor Markierungen.Destroy();
var
i: Byte;
begin
TPanel(Komp).OnMouseDown := OrgMDown; //Rückgabe der Orginalen Eregnissprozeduren
TPanel(Komp).OnMouseUp := OrgMUp;
TPanel(Komp).OnMouseMove := OrgMMove;
TPanel(Komp).OnClick := OrgMClick;
for i := 0 to 7 do panels[i].Free;
LblPos.Free;
end;
procedure Markierungen.panelsMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer); //Funktion aus Swissdelphicenter entnommen
begin //Tip: "Komponenten während der Laufzeit verschieben?"
FDownX := X;
FDownY := Y;
FDragging := True;
TMoveCracker(Sender).MouseCapture := True;
LblPos.Visible := True;
end;
procedure Markierungen.panelsMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if FDragging then
with Sender as TControl do
begin
if Sender = Komp then
begin
Left := X - FDownX + Left; //Es wurde direkt auf die Komponente geklickt
Top := Y - FDownY + Top;
LblPos.Caption := '[' + IntToStr(Left) + ',' + IntToStr(Top) + ']';
end
else
begin
case TPanel(Sender).Tag of
0:
begin //oben links
Komp.Top := Y - FDownY + TPanel(Sender).Top + 2;
Komp.Height := Komp.Height - (Y - FDownY);
Komp.Left := X - FDownX + TPanel(Sender).Left + 2;
Komp.Width := Komp.Width - (X - FDownX);
end;
1:
begin //oben mitte
Komp.Top := Y - FDownY + TPanel(Sender).Top + 2;
Komp.Height := Komp.Height - (Y - FDownY);
end;
2:
begin //oben rechts
Komp.Width := X - FDownX + Komp.Width - 2;
Komp.Top := Y - FDownY + TPanel(Sender).Top + 2;
Komp.Height := Komp.Height - (Y - FDownY);
end;
3:
begin //unten rechts
Komp.Width := X - FDownX + Komp.Width - 2;
Komp.Height := Y - FDownY + Komp.Height - 2;
end;
4: Komp.Height := Y - FDownY + Komp.Height - 2; //unten mitte
5:
begin //unten links
Komp.Left := X - FDownX + TPanel(Sender).Left + 2;
Komp.Width := Komp.Width - (X - FDownX);
Komp.Height := Y - FDownY + Komp.Height - 2;
end;
6:
begin //nach links
Komp.Left := X - FDownX + TPanel(Sender).Left + 2;
Komp.Width := Komp.Width - (X - FDownX);
end;
7: Komp.Width := X - FDownX + Komp.Width - 2; //nach rechts
end;
LblPos.Caption := '[' + IntToStr(Komp.Width) + ',' + IntToStr(Komp.Height) + ']';
end;
newPos(); //zum Nachführen der Markierungspanel
LblPos.Left := TControl(Sender).Left + X;
LblPos.Top := TControl(Sender).Top + Y + 20;
LblPos.BringToFront;
LblPos.Refresh;
end;
end;
procedure Markierungen.panelsMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer); //Funktion aus Swissdelphicenter entnommen
begin //Tip: "Komponenten während der Laufzeit verschieben?"
if FDragging then
begin
FDragging := False;
TMoveCracker(Sender).MouseCapture := False;
LblPos.Visible := False;
end;
end;
end.
//In eigenes Programm muss nur noch:
uses Egal;
var
Veraendern: Markierungen;
//In diesem Beispiel über ein Onclickereigniss welches jedes auf dem Form befindliche
//Komponente und das Form selbst bekommt. (Auf Komponente Klicken löst Möglichkeit
//zum größe ändern und verschieben aus und ein Klick wo anders beendet sie wieder.
procedure TForm1.FormClick(Sender: TObject);
begin if Assigned(Veraendern) then
begin
Veraendern.Destroy;
Veraendern := nil;
end
else
Veraendern := Markierungen.Create(TControl(Sender));
end;
//Will man eine PaintBox benutzen muss man diese noch sichtbar machen.
//Z.B. so:
procedure TForm1.FormShow(Sender: TObject);
begin PaintBox1Paint(Sender);
end;
procedure TForm1.PaintBox1Paint(Sender: TObject);
begin with PaintBox1 do
begin
Canvas.Pen.Style := psDash;
Canvas.Rectangle(0, 0, Width, Height);
end;
end;
Delphi - .....................................
neoturk: ...Easily move-resize components at runtime ?...
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Dieser Tip enthält eine Klasse mit der man zur Laufzeit Komponenten
in der Größe verändern bzw verschieben kann so wie man es aus der
Entwicklungsumgebung her gewohnt ist.
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
This Tip provides a tool class that implements the functionality of
moving or resizing any component at runtime (as in the IDE)
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
//Als eigne Unit
unit Egal;
interface
uses Controls, ExtCtrls, QGraphics, Classes, SysUtils, StdCtrls;
type
Markierungen = class
constructor Create(Komponente: TControl);
destructor Destroy();
private
panels: array[0..7] of TPanel;
LblPos: TPanel;
Komp: TControl;
FDownX, FDownY: Integer;
FDragging: Boolean;
OrgMDown, OrgMUp: TMouseEvent;
OrgMMove: TMouseMoveEvent;
OrgMClick: TNotifyEvent;
procedure panelsMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure panelsMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure panelsMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure NewPos();
end;
implementation
type
TMoveCracker = class(TControl);
constructor Markierungen.Create(Komponente: TControl);
var
i: Byte;
begin
Komp := Komponente;
for i := 0 to 7 do
begin //Die acht Markierungspunkte erstellen.
panels[i] := TPanel.Create(Komponente);
panels[i].Parent := Komponente.Parent;
panels[i].Width := 5;
panels[i].Height := 5;
panels[i].Color := clBlack;
panels[i].BevelOuter := bvNone;
panels[i].OnMouseDown := panelsMouseDown;
panels[i].OnMouseMove := panelsMouseMove;
panels[i].OnMouseUp := panelsMouseUp;
panels[i].Tag := i;
end;
NewPos(); //Die Markierungen an die richtige Position bringen
OrgMDown := TPanel(Komp).OnMouseDown; //Sicheren der orginalen Mousereignisse
OrgMUp := TPanel(Komp).OnMouseUp;
OrgMMove := TPanel(Komp).OnMouseMove;
OrgMClick := TPanel(Komp).OnClick;
TPanel(Komp).OnClick := nil; //für funktionen benötige Ereignisse zuweisen
TPanel(Komp).OnMouseDown := panelsMouseDown;
TPanel(Komp).OnMouseUp := panelsMouseUp;
TPanel(Komp).OnMouseMove := panelsMouseMove;
LblPos := TPanel.Create(Komp); //gibt beim Verschieben größe bzw Position an
with LblPos do
begin
Parent := Komp.Parent;
Visible := False;
BevelOuter := bvNone;
Color := clYellow;
Height := 16;
Width := 50;
end;
end;
procedure Markierungen.NewPos();
begin
panels[0].Left := Komp.Left - 2;
panels[0].Top := Komp.Top - 2;
panels[1].Left := Komp.Left + Komp.Width div 2;
panels[1].Top := Komp.Top - 2;
panels[2].Left := Komp.Left + Komp.Width - 2;
panels[2].Top := Komp.Top - 2;
panels[3].Left := Komp.Left + Komp.Width - 2;
panels[3].Top := Komp.Top + Komp.Height - 2;
panels[4].Left := Komp.Left + Komp.Width div 2;
panels[4].Top := Komp.Top + Komp.Height - 2;
panels[5].Left := Komp.Left - 2;
panels[5].Top := Komp.Top + Komp.Height - 2;
panels[6].Left := Komp.Left - 2;
panels[6].Top := Komp.Top + Komp.Height div 2 - 1;
panels[7].Left := Komp.Left + Komp.Width - 2;
panels[7].Top := Komp.Top + Komp.Height div 2 - 1;
end;
destructor Markierungen.Destroy();
var
i: Byte;
begin
TPanel(Komp).OnMouseDown := OrgMDown; //Rückgabe der Orginalen Eregnissprozeduren
TPanel(Komp).OnMouseUp := OrgMUp;
TPanel(Komp).OnMouseMove := OrgMMove;
TPanel(Komp).OnClick := OrgMClick;
for i := 0 to 7 do panels[i].Free;
LblPos.Free;
end;
procedure Markierungen.panelsMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer); //Funktion aus Swissdelphicenter entnommen
begin //Tip: "Komponenten während der Laufzeit verschieben?"
FDownX := X;
FDownY := Y;
FDragging := True;
TMoveCracker(Sender).MouseCapture := True;
LblPos.Visible := True;
end;
procedure Markierungen.panelsMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if FDragging then
with Sender as TControl do
begin
if Sender = Komp then
begin
Left := X - FDownX + Left; //Es wurde direkt auf die Komponente geklickt
Top := Y - FDownY + Top;
LblPos.Caption := '[' + IntToStr(Left) + ',' + IntToStr(Top) + ']';
end
else
begin
case TPanel(Sender).Tag of
0:
begin //oben links
Komp.Top := Y - FDownY + TPanel(Sender).Top + 2;
Komp.Height := Komp.Height - (Y - FDownY);
Komp.Left := X - FDownX + TPanel(Sender).Left + 2;
Komp.Width := Komp.Width - (X - FDownX);
end;
1:
begin //oben mitte
Komp.Top := Y - FDownY + TPanel(Sender).Top + 2;
Komp.Height := Komp.Height - (Y - FDownY);
end;
2:
begin //oben rechts
Komp.Width := X - FDownX + Komp.Width - 2;
Komp.Top := Y - FDownY + TPanel(Sender).Top + 2;
Komp.Height := Komp.Height - (Y - FDownY);
end;
3:
begin //unten rechts
Komp.Width := X - FDownX + Komp.Width - 2;
Komp.Height := Y - FDownY + Komp.Height - 2;
end;
4: Komp.Height := Y - FDownY + Komp.Height - 2; //unten mitte
5:
begin //unten links
Komp.Left := X - FDownX + TPanel(Sender).Left + 2;
Komp.Width := Komp.Width - (X - FDownX);
Komp.Height := Y - FDownY + Komp.Height - 2;
end;
6:
begin //nach links
Komp.Left := X - FDownX + TPanel(Sender).Left + 2;
Komp.Width := Komp.Width - (X - FDownX);
end;
7: Komp.Width := X - FDownX + Komp.Width - 2; //nach rechts
end;
LblPos.Caption := '[' + IntToStr(Komp.Width) + ',' + IntToStr(Komp.Height) + ']';
end;
newPos(); //zum Nachführen der Markierungspanel
LblPos.Left := TControl(Sender).Left + X;
LblPos.Top := TControl(Sender).Top + Y + 20;
LblPos.BringToFront;
LblPos.Refresh;
end;
end;
procedure Markierungen.panelsMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer); //Funktion aus Swissdelphicenter entnommen
begin //Tip: "Komponenten während der Laufzeit verschieben?"
if FDragging then
begin
FDragging := False;
TMoveCracker(Sender).MouseCapture := False;
LblPos.Visible := False;
end;
end;
end.
//In eigenes Programm muss nur noch:
uses Egal;
var
Veraendern: Markierungen;
//In diesem Beispiel über ein Onclickereigniss welches jedes auf dem Form befindliche
//Komponente und das Form selbst bekommt. (Auf Komponente Klicken löst Möglichkeit
//zum größe ändern und verschieben aus und ein Klick wo anders beendet sie wieder.
procedure TForm1.FormClick(Sender: TObject);
begin if Assigned(Veraendern) then
begin
Veraendern.Destroy;
Veraendern := nil;
end
else
Veraendern := Markierungen.Create(TControl(Sender));
end;
//Will man eine PaintBox benutzen muss man diese noch sichtbar machen.
//Z.B. so:
procedure TForm1.FormShow(Sender: TObject);
begin PaintBox1Paint(Sender);
end;
procedure TForm1.PaintBox1Paint(Sender: TObject);
begin with PaintBox1 do
begin
Canvas.Pen.Style := psDash;
Canvas.Rectangle(0, 0, Width, Height);
end;
end;
Delphi - .....................................
neoturk: ...Show an editibox linked balloontip ?...
//Windows +XP
//Form witch one button and one editbox
type
tagEDITBALLOONTIP = record
cbStruct: Longword;
pszTitle: PWChar;
pszText: PWChar;
ttiIcon: Integer;
end;
type
PEDITBALLOONTIP = ^tagEDITBALLOONTIP;
const
ECM_FIRST = $00001500;
EM_SHOWBALLOONTIP = ECM_FIRST + 3;
procedure TForm1.Button1Click(Sender: TObject);
var
ebt: tagEDITBALLOONTIP;
title, Text: Widestring;
icon: Integer;
begin
title := 'tooltip!!';
Text := 'in editbox 
';
icon := 1; //0,1,2,3
with ebt do
begin
cbStruct := SizeOf(ebt);
pszTitle := PWideChar(title);
pszText := PWideChar(Text);
ttiIcon := icon;
end;
SendMessage(Edit1.Handle, EM_SHOWBALLOONTIP, 0, Longint(@ebt));
end;
Delphi - .....................................
neoturk: ...Show an editibox linked balloontip ?...
//Windows +XP
//Form witch one button and one editbox
type
tagEDITBALLOONTIP = record
cbStruct: Longword;
pszTitle: PWChar;
pszText: PWChar;
ttiIcon: Integer;
end;
type
PEDITBALLOONTIP = ^tagEDITBALLOONTIP;
const
ECM_FIRST = $00001500;
EM_SHOWBALLOONTIP = ECM_FIRST + 3;
procedure TForm1.Button1Click(Sender: TObject);
var
ebt: tagEDITBALLOONTIP;
title, Text: Widestring;
icon: Integer;
begin
title := 'tooltip!!';
Text := 'in editbox ';
icon := 1; //0,1,2,3
with ebt do
begin
cbStruct := SizeOf(ebt);
pszTitle := PWideChar(title);
pszText := PWideChar(Text);
ttiIcon := icon;
end;
SendMessage(Edit1.Handle, EM_SHOWBALLOONTIP, 0, Longint(@ebt));
end;
Delphi - .....................................
neoturk: ...Synchronize two richedit by scrolling ?...
//...
private
PRichEdWndProc, POldWndProc: Pointer;
procedure RichEdWndProc(var Msg: TMessage);
//...
procedure TForm1.FormCreate(Sender: TObject);
begin
PRichEdWndProc := MakeObjectInstance(RichEdWndProc);
POldWndProc := Pointer(SetWindowLong(RichEdit1.Handle, GWL_WNDPROC,
Integer(PRichEdWndProc)));
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
if Assigned(PRichEdWndProc) then
begin
SetWindowLong(RichEdit1.Handle, GWL_WNDPROC, Integer(POldWndProc));
FreeObjectInstance(PRichEdWndProc);
end;
end;
procedure TForm1.RichEdWndProc(var Msg: TMessage);
begin
Msg.Result := CallWindowProc(POldWndProc, RichEdit1.Handle, Msg.Msg,
Msg.wParam, Msg.lParam);
if (Msg.Msg = WM_VSCROLL) and (LOWORD(Msg.wParam) = SB_THUMBTRACK) then
begin
Label1.Caption := 'Pos is ' + IntToStr(HIWORD(Msg.wParam));
RichEdit2.Perform(Msg.Msg, Msg.wParam, Msg.lParam);
SetScrollPos(RichEdit2.Handle, SB_VERT, HIWORD(Msg.wParam), True);
end;
end;
Delphi - .....................................
neoturk: ...Synchronize two richedit by scrolling ?...
//...
private
PRichEdWndProc, POldWndProc: Pointer;
procedure RichEdWndProc(var Msg: TMessage);
//...
procedure TForm1.FormCreate(Sender: TObject);
begin
PRichEdWndProc := MakeObjectInstance(RichEdWndProc);
POldWndProc := Pointer(SetWindowLong(RichEdit1.Handle, GWL_WNDPROC,
Integer(PRichEdWndProc)));
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
if Assigned(PRichEdWndProc) then
begin
SetWindowLong(RichEdit1.Handle, GWL_WNDPROC, Integer(POldWndProc));
FreeObjectInstance(PRichEdWndProc);
end;
end;
procedure TForm1.RichEdWndProc(var Msg: TMessage);
begin
Msg.Result := CallWindowProc(POldWndProc, RichEdit1.Handle, Msg.Msg,
Msg.wParam, Msg.lParam);
if (Msg.Msg = WM_VSCROLL) and (LOWORD(Msg.wParam) = SB_THUMBTRACK) then
begin
Label1.Caption := 'Pos is ' + IntToStr(HIWORD(Msg.wParam));
RichEdit2.Perform(Msg.Msg, Msg.wParam, Msg.lParam);
SetScrollPos(RichEdit2.Handle, SB_VERT, HIWORD(Msg.wParam), True);
end;
end;
Delphi - .....................................
neoturk: ...Minimze the application visually to the tray [tna] ?...
function MinimizeToTray(Handle: HWND): Boolean;
var
hwndTray: HWND;
rcWindow: TRect;
rcTray: TRect;
begin
// Check passed window handle
if IsWindow(Handle) then
begin
// Get tray handle
hwndTray := FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'TrayNotifyWnd', nil);
// Check tray handle
if (hwndTray = 0) then
// Failure
Result := False
else
begin
// Get window rect and tray rect
GetWindowRect(Handle, rcWindow);
GetWindowRect(hwndTray, rcTray);
// Perform the animation
DrawAnimatedRects(Handle, IDANI_CAPTION, rcWindow, rcTray);
// Hide the window
ShowWindow(Handle, SW_HIDE);
end;
end
else
// Failure
Result := False;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
MinimizeToTray(Handle);
end;
Delphi - .....................................
neoturk: ...Minimze the application visually to the tray [tna] ?...
function MinimizeToTray(Handle: HWND): Boolean;
var
hwndTray: HWND;
rcWindow: TRect;
rcTray: TRect;
begin
// Check passed window handle
if IsWindow(Handle) then
begin
// Get tray handle
hwndTray := FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'TrayNotifyWnd', nil);
// Check tray handle
if (hwndTray = 0) then
// Failure
Result := False
else
begin
// Get window rect and tray rect
GetWindowRect(Handle, rcWindow);
GetWindowRect(hwndTray, rcTray);
// Perform the animation
DrawAnimatedRects(Handle, IDANI_CAPTION, rcWindow, rcTray);
// Hide the window
ShowWindow(Handle, SW_HIDE);
end;
end
else
// Failure
Result := False;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
MinimizeToTray(Handle);
end;
Delphi - .....................................
neoturk: ...Change the color of a ttoolbutton ?...
procedure TForm1.ToolBar1CustomDrawButton(Sender: TToolBar;
Button: TToolButton; State: TCustomDrawState; var DefaultDraw: Boolean);
begin
// select color
Sender.Canvas.Brush.Color := clAqua;
// Paint selected color
Sender.Canvas.Rectangle(Button.BoundsRect);
end;
Delphi - .....................................
neoturk: ...Change the color of a ttoolbutton ?...
procedure TForm1.ToolBar1CustomDrawButton(Sender: TToolBar;
Button: TToolButton; State: TCustomDrawState; var DefaultDraw: Boolean);
begin
// select color
Sender.Canvas.Brush.Color := clAqua;
// Paint selected color
Sender.Canvas.Rectangle(Button.BoundsRect);
end;
Delphi - .....................................
neoturk: ...Save and load font from a configuration file ?...
unit DelphiCenterU1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, IniFiles;
type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
ListBox1: TListBox;
FontDialog1: TFontDialog;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure ListBox1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
var
MyFile: string = 'C:Font.Ini';
(*----------------------------------------------------*)
function FontStyletoStr(St: TFontStyles): string;
var
S: string;
begin
S := '';
if St = [fsbold] then S := 'Bold'
else if St = [fsItalic] then S := 'Italic'
else if St = [fsStrikeOut] then S := 'StrikeOut'
else if St = [fsUnderline] then S := 'UnderLine'
else if St = [fsbold, fsItalic] then S := 'BoldItalic'
else if St = [fsBold, fsStrikeOut] then S := 'BoldStrike'
else if St = [fsBold, fsUnderline] then S := 'BoldUnderLine'
else if St = [fsBold..fsStrikeOut] then S := 'BoldItalicStrike'
else if St = [fsBold..fsUnderLine] then S := 'BoldItalicUnderLine'
else if St = [fsbold..fsItalic, fsStrikeOut] then S := 'BoldItalicStrike'
else if St = [fsBold, fsUnderline..fsStrikeOut] then S := 'BoldStrikeUnderLine'
else if St = [fsItalic, fsStrikeOut] then S := 'ItalicStrike'
else if St = [fsItalic..fsUnderline] then S := 'ItalicUnderLine'
else if St = [fsUnderLine..fsStrikeOut] then S := 'UnderLineStrike'
else if St = [fsItalic..fsStrikeOut] then S := 'ItalicUnderLineStrike';
FontStyletoStr := S;
end;
(*----------------------------------------------------*)
function StrtoFontStyle(St: string): TFontStyles;
var
S: TfontStyles;
begin
S := [];
St := UpperCase(St);
if St = 'BOLD' then S := [fsBold]
else if St = 'ITALIC' then S := [fsItalic]
else if St = 'STRIKEOUT' then S := [fsStrikeOut]
else if St = 'UNDERLINE' then S := [fsUnderLine]
else if St = 'BOLDITALIC' then S := [fsbold, fsItalic]
else if St = 'BOLDSTRIKE' then S := [fsBold, fsStrikeOut]
else if St = 'BOLDUNDERLINE' then S := [fsBold, fsUnderLine]
else if St = 'BOLDITALICSTRIKE' then S := [fsBold..fsStrikeOut]
else if St = 'BOLDITALICUNDERLINE' then S := [fsBold..fsUnderLine]
else if St = 'BOLDITALICSTRIKE' then S := [fsbold..fsItalic, fsStrikeOut]
else if St = 'BOLDSTRIKEUNDERLINE' then S := [fsBold, fsUnderline..fsStrikeOut]
else if St = 'ITALICSTRIKE' then S := [fsItalic, fsStrikeOut]
else if St = 'ITALICUNDERLINE' then S := [fsItalic..fsUnderline]
else if St = 'UNDERLINESTRIKE' then S := [fsUnderLine..fsStrikeOut]
else if St = 'ITALICUNDERLINESTRIKE' then S := [fsItalic..fsStrikeOut];
StrtoFontStyle := S;
end;
(*----------------------------------------------------*)
//Example for Write Font
procedure SaveFont(S: string);
var
Ini: TIniFile;
begin
Ini := TIniFile.Create(S);
with Form1.ListBox1 do
begin
with Font do
begin
Ini.WriteString('Fonts', 'List Name', Name);
Ini.WriteInteger('Fonts', 'List Size', Size);
Ini.WriteInteger('Fonts', 'List Color', Color);
S := FontStyletoStr(Style);
if S <> '' then Ini.WriteString('Fonts', 'List Style', S);
end;
Ini.WriteInteger('Colors', 'List Color', Color);
end;
Ini.Free;
end;
(*----------------------------------------------------*)
//Example for Read Font
procedure LoadFont(S: string);
var
Ini: TIniFile;
begin
Ini := TIniFile.Create(S);
with Form1.ListBox1 do
begin
with Font do
begin
Name := Ini.ReadString('Fonts', 'List Name', Name);
Size := Ini.ReadInteger('Fonts', 'List Size', Size);
Color := Ini.ReadInteger('Fonts', 'List Color', Color);
S := Ini.ReadString('Fonts', 'List Style', '');
if S <> '' then Style := StrtoFontStyle(S);
end;
Color := Ini.ReadInteger('Colors', 'List Color', Color);
end;
Ini.Free;
end;
(*----------------------------------------------------*)
procedure TForm1.Button1Click(Sender: TObject);
begin
SaveFont(MyFile);
end;
(*----------------------------------------------------*)
procedure TForm1.Button2Click(Sender: TObject);
begin
LoadFont(MyFile);
end;
(*----------------------------------------------------*)
procedure TForm1.ListBox1Click(Sender: TObject);
begin
with FontDialog1 do if Execute then ListBox1.Font := Font;
end;
(*----------------------------------------------------*)
procedure TForm1.FormCreate(Sender: TObject);
var
i: Byte;
begin
for i := 1 to 10 do
ListBox1.Items.Add('Item ' + IntToStr(i));
end;
(*----------------------------------------------------*)
end.
Delphi - .....................................
neoturk: ...Save and load font from a configuration file ?...
unit DelphiCenterU1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, IniFiles;
type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
ListBox1: TListBox;
FontDialog1: TFontDialog;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure ListBox1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
var
MyFile: string = 'C:Font.Ini';
(*----------------------------------------------------*)
function FontStyletoStr(St: TFontStyles): string;
var
S: string;
begin
S := '';
if St = [fsbold] then S := 'Bold'
else if St = [fsItalic] then S := 'Italic'
else if St = [fsStrikeOut] then S := 'StrikeOut'
else if St = [fsUnderline] then S := 'UnderLine'
else if St = [fsbold, fsItalic] then S := 'BoldItalic'
else if St = [fsBold, fsStrikeOut] then S := 'BoldStrike'
else if St = [fsBold, fsUnderline] then S := 'BoldUnderLine'
else if St = [fsBold..fsStrikeOut] then S := 'BoldItalicStrike'
else if St = [fsBold..fsUnderLine] then S := 'BoldItalicUnderLine'
else if St = [fsbold..fsItalic, fsStrikeOut] then S := 'BoldItalicStrike'
else if St = [fsBold, fsUnderline..fsStrikeOut] then S := 'BoldStrikeUnderLine'
else if St = [fsItalic, fsStrikeOut] then S := 'ItalicStrike'
else if St = [fsItalic..fsUnderline] then S := 'ItalicUnderLine'
else if St = [fsUnderLine..fsStrikeOut] then S := 'UnderLineStrike'
else if St = [fsItalic..fsStrikeOut] then S := 'ItalicUnderLineStrike';
FontStyletoStr := S;
end;
(*----------------------------------------------------*)
function StrtoFontStyle(St: string): TFontStyles;
var
S: TfontStyles;
begin
S := [];
St := UpperCase(St);
if St = 'BOLD' then S := [fsBold]
else if St = 'ITALIC' then S := [fsItalic]
else if St = 'STRIKEOUT' then S := [fsStrikeOut]
else if St = 'UNDERLINE' then S := [fsUnderLine]
else if St = 'BOLDITALIC' then S := [fsbold, fsItalic]
else if St = 'BOLDSTRIKE' then S := [fsBold, fsStrikeOut]
else if St = 'BOLDUNDERLINE' then S := [fsBold, fsUnderLine]
else if St = 'BOLDITALICSTRIKE' then S := [fsBold..fsStrikeOut]
else if St = 'BOLDITALICUNDERLINE' then S := [fsBold..fsUnderLine]
else if St = 'BOLDITALICSTRIKE' then S := [fsbold..fsItalic, fsStrikeOut]
else if St = 'BOLDSTRIKEUNDERLINE' then S := [fsBold, fsUnderline..fsStrikeOut]
else if St = 'ITALICSTRIKE' then S := [fsItalic, fsStrikeOut]
else if St = 'ITALICUNDERLINE' then S := [fsItalic..fsUnderline]
else if St = 'UNDERLINESTRIKE' then S := [fsUnderLine..fsStrikeOut]
else if St = 'ITALICUNDERLINESTRIKE' then S := [fsItalic..fsStrikeOut];
StrtoFontStyle := S;
end;
(*----------------------------------------------------*)
//Example for Write Font
procedure SaveFont(S: string);
var
Ini: TIniFile;
begin
Ini := TIniFile.Create(S);
with Form1.ListBox1 do
begin
with Font do
begin
Ini.WriteString('Fonts', 'List Name', Name);
Ini.WriteInteger('Fonts', 'List Size', Size);
Ini.WriteInteger('Fonts', 'List Color', Color);
S := FontStyletoStr(Style);
if S <> '' then Ini.WriteString('Fonts', 'List Style', S);
end;
Ini.WriteInteger('Colors', 'List Color', Color);
end;
Ini.Free;
end;
(*----------------------------------------------------*)
//Example for Read Font
procedure LoadFont(S: string);
var
Ini: TIniFile;
begin
Ini := TIniFile.Create(S);
with Form1.ListBox1 do
begin
with Font do
begin
Name := Ini.ReadString('Fonts', 'List Name', Name);
Size := Ini.ReadInteger('Fonts', 'List Size', Size);
Color := Ini.ReadInteger('Fonts', 'List Color', Color);
S := Ini.ReadString('Fonts', 'List Style', '');
if S <> '' then Style := StrtoFontStyle(S);
end;
Color := Ini.ReadInteger('Colors', 'List Color', Color);
end;
Ini.Free;
end;
(*----------------------------------------------------*)
procedure TForm1.Button1Click(Sender: TObject);
begin
SaveFont(MyFile);
end;
(*----------------------------------------------------*)
procedure TForm1.Button2Click(Sender: TObject);
begin
LoadFont(MyFile);
end;
(*----------------------------------------------------*)
procedure TForm1.ListBox1Click(Sender: TObject);
begin
with FontDialog1 do if Execute then ListBox1.Font := Font;
end;
(*----------------------------------------------------*)
procedure TForm1.FormCreate(Sender: TObject);
var
i: Byte;
begin
for i := 1 to 10 do
ListBox1.Items.Add('Item ' + IntToStr(i));
end;
(*----------------------------------------------------*)
end.
Delphi - .....................................
KAYDETME HATASI ( Lütfen Yardımcı Olurmusunuz...! )
// ARKADAŞLAR FOMMU AÇIYORUM. VE BİLGİLERİ GİRİP KAYIT YAPIYORUM
// NEDEN SE HATA VERİYOR .....
// TABLEYİ BAŞKA NASIL AÇIP NASIL KAYIT YAPTIRABİLİRİM
// YARDIMCI OLABİLİRSENİZ SEVİNİRİM..
procedure TForm14.BitBtn2Click(Sender: TObject);
begin
Close; // Formu Kapat...
end;
procedure TForm14.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Table1.close;
Form3.Enabled:=True;
Table1.open;
Table1.append;
end;
procedure TForm14.FormActivate(Sender: TObject);
begin
table1.close;
table1.open;
table1.append;
Dbedit2.SetFocus;
end;
procedure TForm14.BitBtn1Click(Sender: TObject);
begin
Table1.Post;
Showmessage(Label13.caption +(' "')+('Nolu Müşteri'));
Form14.Close;
end;
procedure TForm14.FormCreate(Sender: TObject);
begin
table1.close;
table1.open;
table1.append;
end;
procedure TForm14.FormShow(Sender: TObject);
begin
end;
procedure TForm14.DBEdit2Exit(Sender: TObject);
begin
SpeedButton1.Click;
DBEdit1.text:=Label32.Caption;
end;
end.
Delphi - .....................................
KAYDETME HATASI ( Lütfen Yardımcı Olurmusunuz...! )
// ARKADAŞLAR FOMMU AÇIYORUM. VE BİLGİLERİ GİRİP KAYIT YAPIYORUM
// NEDEN SE HATA VERİYOR .....
// TABLEYİ BAŞKA NASIL AÇIP NASIL KAYIT YAPTIRABİLİRİM
// YARDIMCI OLABİLİRSENİZ SEVİNİRİM..
procedure TForm14.BitBtn2Click(Sender: TObject);
begin
Close; // Formu Kapat...
end;
procedure TForm14.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Table1.close;
Form3.Enabled:=True;
Table1.open;
Table1.append;
end;
procedure TForm14.FormActivate(Sender: TObject);
begin
table1.close;
table1.open;
table1.append;
Dbedit2.SetFocus;
end;
procedure TForm14.BitBtn1Click(Sender: TObject);
begin
Table1.Post;
Showmessage(Label13.caption +(' "')+('Nolu Müşteri'));
Form14.Close;
end;
procedure TForm14.FormCreate(Sender: TObject);
begin
table1.close;
table1.open;
table1.append;
end;
procedure TForm14.FormShow(Sender: TObject);
begin
end;
procedure TForm14.DBEdit2Exit(Sender: TObject);
begin
SpeedButton1.Click;
DBEdit1.text:=Label32.Caption;
end;
end.
Delphi - .....................................
neoturk: ...Highlight text with tmemo ?...
(**
* Highlight with TMemo Impossible? try this...
* by Gon Perez-Jimenez May'04
*
* This is a sample how to work with highlighting within TMemo component by
* using interjected class technique.
*
* Of course, this code is still uncompleted but it works fine for my
* purposes, so, hope you can improve it and use it.
*
* Drop onto your TForm (Form1), a TMemo (Memo1), a TLabel (Label1)
* and a TListBox (KeywordList)
*
* Insert in the TListBox Items some Pascal keywords in lowercase !!!
*
* That's all! Enjoy
*)
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ComCtrls;
type
// Interjected Class
TMemo = class(stdctrls.TMemo)
private
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
procedure WMSize(var Message: TWMSize); message WM_SIZE;
procedure WMMove(var Message: TWMMove); message WM_MOVE;
procedure WMVScroll(var Message: TWMMove); message WM_VSCROLL;
procedure WMMousewheel(var Message: TWMMove); message WM_MOUSEWHEEL;
protected
procedure Change; override;
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
procedure KeyUp(var Key: Word; Shift: TShiftState); override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
override;
public
PosLabel: TLabel;
procedure Update_label;
procedure GotoXY(mCol, mLine: Integer);
function Line: Integer;
function Col: Integer;
function TopLine: Integer;
function VisibleLines: Integer;
end;
TForm1 = class(TForm)
Memo1: TMemo;
Label1: TLabel;
KeywordList: TListBox;
procedure FormCreate(Sender: TObject);
procedure Memo1KeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
////////////////////////////////////////////////////////////////////////////////
// functions for managing keywords and numbers of each line of TMemo ///////////
////////////////////////////////////////////////////////////////////////////////
function IsSeparator(Car: Char): Boolean;
begin
case Car of
'.', ';', ',', ':', '¡', '!', '·', '"', '''', '^', '+', '-', '*', '/', '', '¨', ' ',
'`', '[', ']', '(', ')', 'º', 'ª', '{', '}', '?', '¿', '%', '=': Result := True;
else
Result := False;
end;
end;
////////////////////////////////////////////////////////////////////////////////
function NextWord(var s: string; var PrevWord: string): string;
begin
Result := '';
PrevWord := '';
if s = '' then Exit;
while (s <> '') and IsSeparator(s[1]) do
begin
PrevWord := PrevWord + s[1];
Delete(s, 1,1);
end;
while (s <> '') and not IsSeparator(s[1]) do
begin
Result := Result + s[1];
Delete(s, 1,1);
end;
end;
////////////////////////////////////////////////////////////////////////////////
function IsKeyWord(s: string): Boolean;
begin
Result := False;
if s = '' then Exit;
Result := Form1.KeywordList.Items.IndexOf(lowercase(s)) <> -1;
end;
////////////////////////////////////////////////////////////////////////////////
function IsNumber(s: string): Boolean;
var
i: Integer;
begin
Result := False;
for i := 1 to Length(s) do
case s[i] of
'0'..'9':;
else
Exit;
end;
Result := True;
end;
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
// New or overrided methods and properties for TMemo using Interjected Class ///
// Technique ///////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
function TMemo.VisibleLines: Integer;
begin
Result := Height div (Abs(Self.Font.Height) + 2);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.GotoXY(mCol, mLine: Integer);
begin
Dec(mLine);
SelStart := 0;
SelLength := 0;
SelStart := mCol + Self.Perform(EM_LINEINDEX, mLine, 0);
SelLength := 0;
SetFocus;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.Update_label;
begin
if PosLabel = nil then Exit;
PosLabel.Caption := '(' + IntToStr(Line + 1) + ',' + IntToStr(Col) + ')';
end;
////////////////////////////////////////////////////////////////////////////////
function TMemo.TopLine: Integer;
begin
Result := SendMessage(Self.Handle, EM_GETFIRSTVISIBLELINE, 0, 0);
end;
////////////////////////////////////////////////////////////////////////////////
function TMemo.Line: Integer;
begin
Result := SendMessage(Self.Handle, EM_LINEFROMCHAR, Self.SelStart, 0);
end;
////////////////////////////////////////////////////////////////////////////////
function TMemo.Col: Integer;
begin
Result := Self.SelStart - SendMessage(Self.Handle, EM_LINEINDEX,
SendMessage(Self.Handle,
EM_LINEFROMCHAR, Self.SelStart, 0), 0);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMVScroll(var Message: TWMMove);
begin
Update_label;
Invalidate;
inherited;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMSize(var Message: TWMSize);
begin
Invalidate;
inherited;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMMove(var Message: TWMMove);
begin
Invalidate;
inherited;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMMousewheel(var Message: TWMMove);
begin
Invalidate;
inherited;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.Change;
begin
Update_label;
Invalidate;
inherited Change;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.KeyDown(var Key: Word; Shift: TShiftState);
begin
Update_label;
inherited KeyDown(Key, Shift);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.KeyUp(var Key: Word; Shift: TShiftState);
begin
Update_label;
inherited KeyUp(Key, Shift);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
Update_label;
inherited MouseDown(Button, Shift, X, Y);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
Update_label;
inherited MouseUp(Button, Shift, X, Y);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMPaint(var Message: TWMPaint);
var
PS: TPaintStruct;
DC: HDC;
Canvas: TCanvas;
i: Integer;
X, Y: Integer;
OldColor: TColor;
Size: TSize;
Max: Integer;
s, Palabra, PrevWord: string;
begin
DC := Message.DC;
if DC = 0 then DC := BeginPaint(Handle, PS);
Canvas := TCanvas.Create;
try
OldColor := Font.Color;
Canvas.Handle := DC;
Canvas.Font.Name := Font.Name;
Canvas.Font.Size := Font.Size;
with Canvas do
begin
Max := TopLine + VisibleLines;
if Max > Pred(Lines.Count) then Max := Pred(Lines.Count);
//Limpio la sección visible
Brush.Color := Self.Color;
FillRect(Self.ClientRect);
Y := 1;
for i := TopLine to Max do
begin
X := 2;
s := Lines[i];
//Detecto todas las palabras de esta línea
Palabra := NextWord(s, PrevWord);
while Palabra <> '' do
begin
Font.Color := OldColor;
TextOut(X, Y, PrevWord);
GetTextExtentPoint32(DC, PChar(PrevWord), Length(PrevWord), Size);
Inc(X, Size.cx);
Font.Color := clBlack;
if IsKeyWord(Palabra) then
begin
Font.Color := clHighlight;
TextOut(X, Y, Palabra);
{
//Draw dot underline
Pen.Color := clHighlight;
Pen.Style := psDot;
PolyLine([ Point(X,Y+13), Point(X+TextWidth(Palabra),Y+13)]);
}
end
else if IsNumber(Palabra) then
begin
Font.Color := $000000DD;
TextOut(X, Y, Palabra);
end
else
TextOut(X, Y, Palabra);
GetTextExtentPoint32(DC, PChar(Palabra), Length(Palabra), Size);
Inc(X, Size.cx);
Palabra := NextWord(s, PrevWord);
if (s = '') and (PrevWord <> '') then
begin
Font.Color := OldColor;
TextOut(X, Y, PrevWord);
end;
end;
if (s = '') and (PrevWord <> '') then
begin
Font.Color := OldColor;
TextOut(X, Y, PrevWord);
end;
s := 'W';
GetTextExtentPoint32(DC, PChar(s), Length(s), Size);
Inc(Y, Size.cy);
end;
end;
finally
if Message.DC = 0 then EndPaint(Handle, PS);
end;
Canvas.Free;
inherited;
end;
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
// Procedures for Form1 ////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
procedure TForm1.FormCreate(Sender: TObject);
begin
Memo1.PosLabel := Label1;
Memo1.Update_label;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TForm1.Memo1KeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if Key = VK_F1 then Memo1.Invalidate;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Action := caFree;
end;
////////////////////////////////////////////////////////////////////////////////
end.
Delphi - .....................................
neoturk: ...Highlight text with tmemo ?...
(**
* Highlight with TMemo Impossible? try this...
* by Gon Perez-Jimenez May'04
*
* This is a sample how to work with highlighting within TMemo component by
* using interjected class technique.
*
* Of course, this code is still uncompleted but it works fine for my
* purposes, so, hope you can improve it and use it.
*
* Drop onto your TForm (Form1), a TMemo (Memo1), a TLabel (Label1)
* and a TListBox (KeywordList)
*
* Insert in the TListBox Items some Pascal keywords in lowercase !!!
*
* That's all! Enjoy
*)
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ComCtrls;
type
// Interjected Class
TMemo = class(stdctrls.TMemo)
private
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
procedure WMSize(var Message: TWMSize); message WM_SIZE;
procedure WMMove(var Message: TWMMove); message WM_MOVE;
procedure WMVScroll(var Message: TWMMove); message WM_VSCROLL;
procedure WMMousewheel(var Message: TWMMove); message WM_MOUSEWHEEL;
protected
procedure Change; override;
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
procedure KeyUp(var Key: Word; Shift: TShiftState); override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
override;
public
PosLabel: TLabel;
procedure Update_label;
procedure GotoXY(mCol, mLine: Integer);
function Line: Integer;
function Col: Integer;
function TopLine: Integer;
function VisibleLines: Integer;
end;
TForm1 = class(TForm)
Memo1: TMemo;
Label1: TLabel;
KeywordList: TListBox;
procedure FormCreate(Sender: TObject);
procedure Memo1KeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
////////////////////////////////////////////////////////////////////////////////
// functions for managing keywords and numbers of each line of TMemo ///////////
////////////////////////////////////////////////////////////////////////////////
function IsSeparator(Car: Char): Boolean;
begin
case Car of
'.', ';', ',', ':', '¡', '!', '·', '"', '''', '^', '+', '-', '*', '/', '', '¨', ' ',
'`', '[', ']', '(', ')', 'º', 'ª', '{', '}', '?', '¿', '%', '=': Result := True;
else
Result := False;
end;
end;
////////////////////////////////////////////////////////////////////////////////
function NextWord(var s: string; var PrevWord: string): string;
begin
Result := '';
PrevWord := '';
if s = '' then Exit;
while (s <> '') and IsSeparator(s[1]) do
begin
PrevWord := PrevWord + s[1];
Delete(s, 1,1);
end;
while (s <> '') and not IsSeparator(s[1]) do
begin
Result := Result + s[1];
Delete(s, 1,1);
end;
end;
////////////////////////////////////////////////////////////////////////////////
function IsKeyWord(s: string): Boolean;
begin
Result := False;
if s = '' then Exit;
Result := Form1.KeywordList.Items.IndexOf(lowercase(s)) <> -1;
end;
////////////////////////////////////////////////////////////////////////////////
function IsNumber(s: string): Boolean;
var
i: Integer;
begin
Result := False;
for i := 1 to Length(s) do
case s[i] of
'0'..'9':;
else
Exit;
end;
Result := True;
end;
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
// New or overrided methods and properties for TMemo using Interjected Class ///
// Technique ///////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
function TMemo.VisibleLines: Integer;
begin
Result := Height div (Abs(Self.Font.Height) + 2);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.GotoXY(mCol, mLine: Integer);
begin
Dec(mLine);
SelStart := 0;
SelLength := 0;
SelStart := mCol + Self.Perform(EM_LINEINDEX, mLine, 0);
SelLength := 0;
SetFocus;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.Update_label;
begin
if PosLabel = nil then Exit;
PosLabel.Caption := '(' + IntToStr(Line + 1) + ',' + IntToStr(Col) + ')';
end;
////////////////////////////////////////////////////////////////////////////////
function TMemo.TopLine: Integer;
begin
Result := SendMessage(Self.Handle, EM_GETFIRSTVISIBLELINE, 0, 0);
end;
////////////////////////////////////////////////////////////////////////////////
function TMemo.Line: Integer;
begin
Result := SendMessage(Self.Handle, EM_LINEFROMCHAR, Self.SelStart, 0);
end;
////////////////////////////////////////////////////////////////////////////////
function TMemo.Col: Integer;
begin
Result := Self.SelStart - SendMessage(Self.Handle, EM_LINEINDEX,
SendMessage(Self.Handle,
EM_LINEFROMCHAR, Self.SelStart, 0), 0);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMVScroll(var Message: TWMMove);
begin
Update_label;
Invalidate;
inherited;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMSize(var Message: TWMSize);
begin
Invalidate;
inherited;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMMove(var Message: TWMMove);
begin
Invalidate;
inherited;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMMousewheel(var Message: TWMMove);
begin
Invalidate;
inherited;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.Change;
begin
Update_label;
Invalidate;
inherited Change;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.KeyDown(var Key: Word; Shift: TShiftState);
begin
Update_label;
inherited KeyDown(Key, Shift);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.KeyUp(var Key: Word; Shift: TShiftState);
begin
Update_label;
inherited KeyUp(Key, Shift);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
Update_label;
inherited MouseDown(Button, Shift, X, Y);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
Update_label;
inherited MouseUp(Button, Shift, X, Y);
end;
////////////////////////////////////////////////////////////////////////////////
procedure TMemo.WMPaint(var Message: TWMPaint);
var
PS: TPaintStruct;
DC: HDC;
Canvas: TCanvas;
i: Integer;
X, Y: Integer;
OldColor: TColor;
Size: TSize;
Max: Integer;
s, Palabra, PrevWord: string;
begin
DC := Message.DC;
if DC = 0 then DC := BeginPaint(Handle, PS);
Canvas := TCanvas.Create;
try
OldColor := Font.Color;
Canvas.Handle := DC;
Canvas.Font.Name := Font.Name;
Canvas.Font.Size := Font.Size;
with Canvas do
begin
Max := TopLine + VisibleLines;
if Max > Pred(Lines.Count) then Max := Pred(Lines.Count);
//Limpio la sección visible
Brush.Color := Self.Color;
FillRect(Self.ClientRect);
Y := 1;
for i := TopLine to Max do
begin
X := 2;
s := Lines[i];
//Detecto todas las palabras de esta línea
Palabra := NextWord(s, PrevWord);
while Palabra <> '' do
begin
Font.Color := OldColor;
TextOut(X, Y, PrevWord);
GetTextExtentPoint32(DC, PChar(PrevWord), Length(PrevWord), Size);
Inc(X, Size.cx);
Font.Color := clBlack;
if IsKeyWord(Palabra) then
begin
Font.Color := clHighlight;
TextOut(X, Y, Palabra);
{
//Draw dot underline
Pen.Color := clHighlight;
Pen.Style := psDot;
PolyLine([ Point(X,Y+13), Point(X+TextWidth(Palabra),Y+13)]);
}
end
else if IsNumber(Palabra) then
begin
Font.Color := $000000DD;
TextOut(X, Y, Palabra);
end
else
TextOut(X, Y, Palabra);
GetTextExtentPoint32(DC, PChar(Palabra), Length(Palabra), Size);
Inc(X, Size.cx);
Palabra := NextWord(s, PrevWord);
if (s = '') and (PrevWord <> '') then
begin
Font.Color := OldColor;
TextOut(X, Y, PrevWord);
end;
end;
if (s = '') and (PrevWord <> '') then
begin
Font.Color := OldColor;
TextOut(X, Y, PrevWord);
end;
s := 'W';
GetTextExtentPoint32(DC, PChar(s), Length(s), Size);
Inc(Y, Size.cy);
end;
end;
finally
if Message.DC = 0 then EndPaint(Handle, PS);
end;
Canvas.Free;
inherited;
end;
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
// Procedures for Form1 ////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
procedure TForm1.FormCreate(Sender: TObject);
begin
Memo1.PosLabel := Label1;
Memo1.Update_label;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TForm1.Memo1KeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if Key = VK_F1 then Memo1.Invalidate;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Action := caFree;
end;
////////////////////////////////////////////////////////////////////////////////
end.
Delphi - .....................................
neoturk: ...Prevent mouvement of a form outside the desktop ?...
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Form1.Left <= 0 then Form1.Left := 0;
if Form1.Top <= 0 then Form1.Top := 0;
if Form1.Left >= Screen.Width - Form1.Width then
Form1.Left := Screen.Width - Form1.Width;
if Form1.Top >= Screen.Height - Form1.Height then
Form1.Top := Screen.Height - Form1.Height;
end;
Delphi - .....................................
neoturk: ...Prevent mouvement of a form outside the desktop ?...
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Form1.Left <= 0 then Form1.Left := 0;
if Form1.Top <= 0 then Form1.Top := 0;
if Form1.Left >= Screen.Width - Form1.Width then
Form1.Left := Screen.Width - Form1.Width;
if Form1.Top >= Screen.Height - Form1.Height then
Form1.Top := Screen.Height - Form1.Height;
end;
Delphi - .....................................
neoturk: ...Show the mainform as a dialog with a mainmenu ?...
(*
--- english -------------------------------------------------------------------
If you want to show your mainform as a dialog (setting BorderStyle := bsDialog)
and don't want to miss your main menu...
--- german --------------------------------------------------------------------
Wer die Hauptform auf BorderStyle := bsDialog gesetzt hat und
dennoch ein TMainMenu haben möchte kann das Handle von TMainMenu nachträglich
wieder aktivieren.
*)
procedure TMain.FormCreate(Sender: TObject);
begin
//...
Windows.SetMenu(Handle, MainMenu1.Handle);
end;
Delphi - .....................................
neoturk: ...Show the mainform as a dialog with a mainmenu ?...
(*
--- english -------------------------------------------------------------------
If you want to show your mainform as a dialog (setting BorderStyle := bsDialog)
and don't want to miss your main menu...
--- german --------------------------------------------------------------------
Wer die Hauptform auf BorderStyle := bsDialog gesetzt hat und
dennoch ein TMainMenu haben möchte kann das Handle von TMainMenu nachträglich
wieder aktivieren.
*)
procedure TMain.FormCreate(Sender: TObject);
begin
//...
Windows.SetMenu(Handle, MainMenu1.Handle);
end;
Delphi - .....................................
neoturk: ...Retrieve the non-transparent label with xpman ?...
{
Did you ever try to put the XPMan on a form which uses the color
property of a TLabel ?
Have you noticed that the background color disappear with XPMan ?
It's because XPMan sets the Transparent properties to TRUE.
And because this is done before the OnCreate event, we cannot
retrieve which one was having the Transparent value to FALSE.
The tip I'll describe here is that simple :
if you want to keep the background color property of some labels
(but not all) while using XPMan, put the value "1" to the TAG
property of the label which may not be transparent.
Then, put this code inside the create event of your form :
}
procedure TForm1.FormCreate(Sender: TObject);
var
Cpt: Integer;
begin
for Cpt := 0 to Self.ComponentCount - 1 do
if (Self.Components[Cpt] is TLabel) then
with (Self.Components[Cpt] as TLabel) do
Transparent := not (Tag = 1);
end;
Delphi - .....................................
neoturk: ...Retrieve the non-transparent label with xpman ?...
{
Did you ever try to put the XPMan on a form which uses the color
property of a TLabel ?
Have you noticed that the background color disappear with XPMan ?
It's because XPMan sets the Transparent properties to TRUE.
And because this is done before the OnCreate event, we cannot
retrieve which one was having the Transparent value to FALSE.
The tip I'll describe here is that simple :
if you want to keep the background color property of some labels
(but not all) while using XPMan, put the value "1" to the TAG
property of the label which may not be transparent.
Then, put this code inside the create event of your form :
}
procedure TForm1.FormCreate(Sender: TObject);
var
Cpt: Integer;
begin
for Cpt := 0 to Self.ComponentCount - 1 do
if (Self.Components[Cpt] is TLabel) then
with (Self.Components[Cpt] as TLabel) do
Transparent := not (Tag = 1);
end;
Delphi - .....................................
Cevap -neoturk - re: mcsd
Neoturk..
çok kısa bir süre önce kaliteli bilgileri kendine sakladığına dair bir şeyler söylemiştin..
kodbanktaki insanlara faydalı olmaya çalışan bir coder olduğun için sana karşı
sevgim ve saygım var.. ancak o "kaliteli kodları" nı "kendine saklamak"dansa
neden paylaşmayı tercih etmiyorsun ?
kodbankın yalnızca "ileri düzey" programcılar için midir?
yani burası "bir formun yaratılıp yaratılmadığını" öğrenmek isteyen insanlara
öğrencilerine yaptığını yapabileceğin bir yer midir ?
burada bir şeyler öğrenmek isteyen herkes senin öğrencin değildir ve onlara
sen öğrencinmiş gibi davranamazsın.
kodbankın içinde aynı kodların tekrar tekrar listelenmesi
senin olduğu gibi burada kimsenin hoşuna gitmiyor ama yinede kodbankın
denetimini sana vermelerini istemezdim ozaman da kanaat notu kullanmaya
kalkardın :)
burada programlama bilgisinin düzeyleri çok farklı yüzlerde insan var
ve sen bunların bir bölümünü bi kenara atamazsın
burası soru sorma platformu değil; doğrudur, ancak buraya gelen hiç bir kimse de
aptal değil!
arama bölümüne "iskender" yaz.. göreceksin ki bir zamanlar burada ben de soru sormuştum
ve ozamanlar senin gibi "insanların öğrenme isteklerini yanlış yerde yapıyorlar diye
bastırma çabalarına girmiş" birileri yoktu
sonuç olarak forumla buranın ayrımına bir gün herkes varır..
o gün bunu anlayanın seni "mcsd"(!) öğrencisi ve bildiğinden başka doğru tanımayan
biri olarak tanımasındansa "bildiğinin zekatını öğreterek veren" biri olarak tanımasına
ne dersin ?
lütfen buna cevap yazma.. sadece düşün!
Saygılarımla
Yolcu1453
Delphi - .....................................
Cevap -neoturk - re: mcsd
Neoturk..
çok kısa bir süre önce kaliteli bilgileri kendine sakladığına dair bir şeyler söylemiştin..
kodbanktaki insanlara faydalı olmaya çalışan bir coder olduğun için sana karşı
sevgim ve saygım var.. ancak o "kaliteli kodları" nı "kendine saklamak"dansa
neden paylaşmayı tercih etmiyorsun ?
kodbankın yalnızca "ileri düzey" programcılar için midir?
yani burası "bir formun yaratılıp yaratılmadığını" öğrenmek isteyen insanlara
öğrencilerine yaptığını yapabileceğin bir yer midir ?
burada bir şeyler öğrenmek isteyen herkes senin öğrencin değildir ve onlara
sen öğrencinmiş gibi davranamazsın.
kodbankın içinde aynı kodların tekrar tekrar listelenmesi
senin olduğu gibi burada kimsenin hoşuna gitmiyor ama yinede kodbankın
denetimini sana vermelerini istemezdim ozaman da kanaat notu kullanmaya
kalkardın :)
burada programlama bilgisinin düzeyleri çok farklı yüzlerde insan var
ve sen bunların bir bölümünü bi kenara atamazsın
burası soru sorma platformu değil; doğrudur, ancak buraya gelen hiç bir kimse de
aptal değil!
arama bölümüne "iskender" yaz.. göreceksin ki bir zamanlar burada ben de soru sormuştum
ve ozamanlar senin gibi "insanların öğrenme isteklerini yanlış yerde yapıyorlar diye
bastırma çabalarına girmiş" birileri yoktu
sonuç olarak forumla buranın ayrımına bir gün herkes varır..
o gün bunu anlayanın seni "mcsd"(!) öğrencisi ve bildiğinden başka doğru tanımayan
biri olarak tanımasındansa "bildiğinin zekatını öğreterek veren" biri olarak tanımasına
ne dersin ?
lütfen buna cevap yazma.. sadece düşün!
Saygılarımla
Yolcu1453
Delphi - .....................................
neoturk: ...read MSN user contact list ?...
*********************************************************************
this code was tested with microsoft messenger 4.6..
not yet tested on 6.1 or 6.2
this code shows you all msn contact/allow/block user list from registry,
you know, this values type is Binary..
good luck.. if you have news please write me, thx..
written by neoturk from turkey [ xxnt03@lycos.co.uk ]
*********************************************************************)
//.. put the memo on the form, name as memo2 ..
function msnlist(xx: string): string;
var
x2, x, x3, xtemp: string;
reg: TRegistry;
fBuffer: array [0..1024] of Byte;
m, n: Longint;
begin
Form1.Memo2.Clear;
for n := 0 to 125 do
begin
x2 := xx + IntToStr(n);
reg := TRegistry.Create;
reg.RootKey := HKEY_CURRENT_USER;
reg.OpenKey('SoftwareMicrosoftMessengerServiceListCache.NET Messenger Service',
False);
if reg.ValueExists(x2) then
begin
reg.ReadBinaryData(x2, fBuffer, 1024);
m := 0;
x := '';
x3 := '';
repeat
xtemp := IntToHex(fbuffer[m], 2);
x := x + xtemp + ' ';
x3 := x3 + chr(StrToInt('$' + xtemp));
m := m + 1;
until m >= 1024;
Form1.Memo2.Lines.Add(x2 + '=' + x3);
//showmessage(trim(x2+'='+x3));
end;
end;
reg.CloseKey;
reg.Free;
Result := Form1.Memo2.Text;
//final
end;
// in your program:
procedure DoSomething;
begin
//...
memo5.Lines.Add('--------------');
memo5.Lines.Add(msnlist('allow'));
memo5.Lines.Add('--------------');
memo5.Lines.Add('Reverse_list:');
memo5.Lines.Add('--------------');
memo5.Lines.Add(msnlist('reverse'));
memo5.Lines.Add('--------------');
memo5.Lines.Add('Contact_list:');
memo5.Lines.Add('--------------');
memo5.Lines.Add(msnlist('contact'));
memo5.Lines.Add('--------------');
memo5.Lines.Add('Block_list:');
memo5.Lines.Add('--------------');
memo5.Lines.Add(msnlist('block'));
//......ok.
end;
Delphi - .....................................
neoturk: ...read MSN user contact list ?...
*********************************************************************
this code was tested with microsoft messenger 4.6..
not yet tested on 6.1 or 6.2
this code shows you all msn contact/allow/block user list from registry,
you know, this values type is Binary..
good luck.. if you have news please write me, thx..
written by neoturk from turkey [ xxnt03@lycos.co.uk ]
*********************************************************************)
//.. put the memo on the form, name as memo2 ..
function msnlist(xx: string): string;
var
x2, x, x3, xtemp: string;
reg: TRegistry;
fBuffer: array [0..1024] of Byte;
m, n: Longint;
begin
Form1.Memo2.Clear;
for n := 0 to 125 do
begin
x2 := xx + IntToStr(n);
reg := TRegistry.Create;
reg.RootKey := HKEY_CURRENT_USER;
reg.OpenKey('SoftwareMicrosoftMessengerServiceListCache.NET Messenger Service',
False);
if reg.ValueExists(x2) then
begin
reg.ReadBinaryData(x2, fBuffer, 1024);
m := 0;
x := '';
x3 := '';
repeat
xtemp := IntToHex(fbuffer[m], 2);
x := x + xtemp + ' ';
x3 := x3 + chr(StrToInt('$' + xtemp));
m := m + 1;
until m >= 1024;
Form1.Memo2.Lines.Add(x2 + '=' + x3);
//showmessage(trim(x2+'='+x3));
end;
end;
reg.CloseKey;
reg.Free;
Result := Form1.Memo2.Text;
//final
end;
// in your program:
procedure DoSomething;
begin
//...
memo5.Lines.Add('--------------');
memo5.Lines.Add(msnlist('allow'));
memo5.Lines.Add('--------------');
memo5.Lines.Add('Reverse_list:');
memo5.Lines.Add('--------------');
memo5.Lines.Add(msnlist('reverse'));
memo5.Lines.Add('--------------');
memo5.Lines.Add('Contact_list:');
memo5.Lines.Add('--------------');
memo5.Lines.Add(msnlist('contact'));
memo5.Lines.Add('--------------');
memo5.Lines.Add('Block_list:');
memo5.Lines.Add('--------------');
memo5.Lines.Add(msnlist('block'));
//......ok.
end;
Delphi - .....................................
neoturk: ...Check if a file is in use ?...
function IsFileInUse(FileName: TFileName): Boolean;
var
HFileRes: HFILE;
begin
Result := False;
if not FileExists(FileName) then Exit;
HFileRes := CreateFile(PChar(FileName),
GENERIC_READ or GENERIC_WRITE,
0,
nil,
OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL,
0);
Result := (HFileRes = INVALID_HANDLE_VALUE);
if not Result then
CloseHandle(HFileRes);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if IsFileInUse('c:Programsdelphi6bindelphi32.exe') then
ShowMessage('File is in use.');
else
ShowMessage('File not in use.');
end;
Delphi - .....................................
neoturk: ...Check if a file is in use ?...
function IsFileInUse(FileName: TFileName): Boolean;
var
HFileRes: HFILE;
begin
Result := False;
if not FileExists(FileName) then Exit;
HFileRes := CreateFile(PChar(FileName),
GENERIC_READ or GENERIC_WRITE,
0,
nil,
OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL,
0);
Result := (HFileRes = INVALID_HANDLE_VALUE);
if not Result then
CloseHandle(HFileRes);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if IsFileInUse('c:Programsdelphi6bindelphi32.exe') then
ShowMessage('File is in use.');
else
ShowMessage('File not in use.');
end;
Delphi - .....................................
neoturk: ...Determine which application is associated with a file type ?...
{
FindExecutable returns the name and handle to the executable
(.EXE) file associated with a specified file type (.BMP)
}
{
Wenn du z.B eine BMP-Datei anklickst, wird die
dazugehörige Anwendung MSPAINT.EXE mit der Datei als
Parameter ausgeführt. In diesem Beispiel wird
herausgefunden, welche Anwendung (hier MSPAINT.EXE)
mit dem jeweiligen Datei Typ verknüpft ist.
}
function ShellFindExecutable(const FileName, DefaultDir: string): string;
var
Res: HINST;
Buffer: array[0..MAX_PATH] of Char;
P: PChar;
begin
FillChar(Buffer, SizeOf(Buffer), #0);
if DefaultDir = '' then P := nil
else
P := PChar(DefaultDir);
Res := FindExecutable(PChar(FileName), P, Buffer);
if Res > 32 then
begin
P := Buffer;
while PWord(P)^ <> 0 do
begin
if P^ = #0 then // FindExecutable replaces #32 with #0
P^ := #32;
Inc(P);
end;
Result := Buffer;
end
else
Result := '';
end;
// Example, Beispiel:
procedure TForm1.Button1Click(Sender: TObject);
begin
ShellFindExecutable('1stboot.bmp', 'c:windows');
end;
Delphi - .....................................
neoturk: ...Determine which application is associated with a file type ?...
{
FindExecutable returns the name and handle to the executable
(.EXE) file associated with a specified file type (.BMP)
}
{
Wenn du z.B eine BMP-Datei anklickst, wird die
dazugehörige Anwendung MSPAINT.EXE mit der Datei als
Parameter ausgeführt. In diesem Beispiel wird
herausgefunden, welche Anwendung (hier MSPAINT.EXE)
mit dem jeweiligen Datei Typ verknüpft ist.
}
function ShellFindExecutable(const FileName, DefaultDir: string): string;
var
Res: HINST;
Buffer: array[0..MAX_PATH] of Char;
P: PChar;
begin
FillChar(Buffer, SizeOf(Buffer), #0);
if DefaultDir = '' then P := nil
else
P := PChar(DefaultDir);
Res := FindExecutable(PChar(FileName), P, Buffer);
if Res > 32 then
begin
P := Buffer;
while PWord(P)^ <> 0 do
begin
if P^ = #0 then // FindExecutable replaces #32 with #0
P^ := #32;
Inc(P);
end;
Result := Buffer;
end
else
Result := '';
end;
// Example, Beispiel:
procedure TForm1.Button1Click(Sender: TObject);
begin
ShellFindExecutable('1stboot.bmp', 'c:windows');
end;
Delphi - .....................................
neoturk: ...Copy files ?...
{
The CopyFile function copies an existing file to a new file.
CopyFile(
lpExistingFileName : PChar, // name of an existing file
lpNewFileName : PChar, // name of new file
bFailIfExists : Boolean); // operation if file exists
bFailIfExists:
Specifies how this operation is to proceed if a file of the same name as
that specified by lpNewFileName already exists.
If this parameter is TRUE and the new file already exists, the function fails.
If this parameter is FALSE and the new file already exists,
the function overwrites the existing file and succeeds.
}
var
fileSource, fileDest: string;
begin
fileSource := 'C:SourceFile.txt';
fileDest := 'G:DestFile.txt';
CopyFile(PChar(fileSource), PChar(fileDest), False);
end;
Delphi - .....................................
neoturk: ...Copy files ?...
{
The CopyFile function copies an existing file to a new file.
CopyFile(
lpExistingFileName : PChar, // name of an existing file
lpNewFileName : PChar, // name of new file
bFailIfExists : Boolean); // operation if file exists
bFailIfExists:
Specifies how this operation is to proceed if a file of the same name as
that specified by lpNewFileName already exists.
If this parameter is TRUE and the new file already exists, the function fails.
If this parameter is FALSE and the new file already exists,
the function overwrites the existing file and succeeds.
}
var
fileSource, fileDest: string;
begin
fileSource := 'C:SourceFile.txt';
fileDest := 'G:DestFile.txt';
CopyFile(PChar(fileSource), PChar(fileDest), False);
end;
Delphi - .....................................
neoturk: ...Create a directory ?...
uses
Dialogs;
begin
{$I-}
MkDir('c:windows');
{$I+}
if IOResult <> 0 then
MessageDlg('Cannot Create Directory/Verzeichnis kann nicht angelegt werden!',
mtWarning, [mbOK], 0)
else
MessageDlg('Directory Created/Neues Verzeichnis angelegt.', mtInformation, [mbOK], 0);
end;
Delphi - .....................................
neoturk: ...Create a directory ?...
uses
Dialogs;
begin
{$I-}
MkDir('c:windows');
{$I+}
if IOResult <> 0 then
MessageDlg('Cannot Create Directory/Verzeichnis kann nicht angelegt werden!',
mtWarning, [mbOK], 0)
else
MessageDlg('Directory Created/Neues Verzeichnis angelegt.', mtInformation, [mbOK], 0);
end;
Delphi - .....................................
neoturk: ...Patch binary files ?...
// Replaces a string in a file with new string.
// Ersetzt eine Zeichenkette in einer Datei mit einer anderen Zeichenkette.
procedure TForm1.Button1Click(Sender: TObject);
var
f: file;
l: Longint;
FileName, oldstring, newstring, s: string;
begin
oldstring := 'old string';
newstring := 'new string';
FileName := 'c:YourFileName.xyz';
s := oldstring;
AssignFile(f, FileName);
Reset(f, 1);
for l := 0 to FileSize(f) - Length(oldstring) - 1 do
begin
Application.ProcessMessages;
Seek(f, l);
BlockRead(f, oldstring[1], Length(oldstring));
if oldstring = s then
begin
Seek(f, l);
BlockWrite(f, newstring[1], Length(newstring));
ShowMessage('String successfully replaced!');
end;
Application.ProcessMessages;
end;
CloseFile(f);
end;
Delphi - .....................................
neoturk: ...Patch binary files ?...
// Replaces a string in a file with new string.
// Ersetzt eine Zeichenkette in einer Datei mit einer anderen Zeichenkette.
procedure TForm1.Button1Click(Sender: TObject);
var
f: file;
l: Longint;
FileName, oldstring, newstring, s: string;
begin
oldstring := 'old string';
newstring := 'new string';
FileName := 'c:YourFileName.xyz';
s := oldstring;
AssignFile(f, FileName);
Reset(f, 1);
for l := 0 to FileSize(f) - Length(oldstring) - 1 do
begin
Application.ProcessMessages;
Seek(f, l);
BlockRead(f, oldstring[1], Length(oldstring));
if oldstring = s then
begin
Seek(f, l);
BlockWrite(f, newstring[1], Length(newstring));
ShowMessage('String successfully replaced!');
end;
Application.ProcessMessages;
end;
CloseFile(f);
end;
Delphi - .....................................
neoturk: ...Convert short to long filenames ?...
uses
Shellapi;
function GetLongFileName(const FileName: string): string;
var
SHFileInfo: TSHFileInfo;
begin
if SHGetFileInfo(PChar(FileName),
0,
SHFileInfo,
SizeOf(SHFileInfo),
SHGFI_DISPLAYNAME) <> 0 then
Result := string(SHFileInfo.szDisplayName)
else
Result := FileName;
end;
// Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
Caption := GetLongFileName('C:Program FilesDelphi6LibBK_STR~1.DPK');
// --> BK_StringGrid.dpk
end;
// For > Delphi 4 you can use the ExpandFileName() function
// ExpandFileName converts the relative file name into a fully qualified path name.
Delphi - .....................................
neoturk: ...Convert short to long filenames ?...
uses
Shellapi;
function GetLongFileName(const FileName: string): string;
var
SHFileInfo: TSHFileInfo;
begin
if SHGetFileInfo(PChar(FileName),
0,
SHFileInfo,
SizeOf(SHFileInfo),
SHGFI_DISPLAYNAME) <> 0 then
Result := string(SHFileInfo.szDisplayName)
else
Result := FileName;
end;
// Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
Caption := GetLongFileName('C:Program FilesDelphi6LibBK_STR~1.DPK');
// --> BK_StringGrid.dpk
end;
// For > Delphi 4 you can use the ExpandFileName() function
// ExpandFileName converts the relative file name into a fully qualified path name.
Delphi - .....................................
neoturk: ...Read the version of a file ?...
function GetVersion: string;
var
VerInfoSize: DWORD;
VerInfo: Pointer;
VerValueSize: DWORD;
VerValue: PVSFixedFileInfo;
Dummy: DWORD;
begin
VerInfoSize := GetFileVersionInfoSize(PChar(ParamStr(0)), Dummy);
GetMem(VerInfo, VerInfoSize);
GetFileVersionInfo(PChar(ParamStr(0)), 0, VerInfoSize, VerInfo);
VerQueryValue(VerInfo, '', Pointer(VerValue), VerValueSize);
with VerValue^ do
begin
Result := IntToStr(dwFileVersionMS shr 16);
Result := Result + '.' + IntToStr(dwFileVersionMS and $FFFF);
Result := Result + '.' + IntToStr(dwFileVersionLS shr 16);
Result := Result + '.' + IntToStr(dwFileVersionLS and $FFFF);
end;
FreeMem(VerInfo, VerInfoSize);
end;
procedure Form1.Button1Click(Sender: TObject);
begin
label1.Caption := GetVersion;
end;
Delphi - .....................................
neoturk: ...Read the version of a file ?...
function GetVersion: string;
var
VerInfoSize: DWORD;
VerInfo: Pointer;
VerValueSize: DWORD;
VerValue: PVSFixedFileInfo;
Dummy: DWORD;
begin
VerInfoSize := GetFileVersionInfoSize(PChar(ParamStr(0)), Dummy);
GetMem(VerInfo, VerInfoSize);
GetFileVersionInfo(PChar(ParamStr(0)), 0, VerInfoSize, VerInfo);
VerQueryValue(VerInfo, '', Pointer(VerValue), VerValueSize);
with VerValue^ do
begin
Result := IntToStr(dwFileVersionMS shr 16);
Result := Result + '.' + IntToStr(dwFileVersionMS and $FFFF);
Result := Result + '.' + IntToStr(dwFileVersionLS shr 16);
Result := Result + '.' + IntToStr(dwFileVersionLS and $FFFF);
end;
FreeMem(VerInfo, VerInfoSize);
end;
procedure Form1.Button1Click(Sender: TObject);
begin
label1.Caption := GetVersion;
end;
Delphi - .....................................
neoturk: ...Add a file to the document menu ?...
uses ShellAPI, ShlOBJ;
procedure AddToStartDocumentsMenu(sFilePath: string);
begin
SHAddToRecentDocs(SHARD_PATH, PChar(sFilePath));
end;
Delphi - .....................................
neoturk: ...Add a file to the document menu ?...
uses ShellAPI, ShlOBJ;
procedure AddToStartDocumentsMenu(sFilePath: string);
begin
SHAddToRecentDocs(SHARD_PATH, PChar(sFilePath));
end;
Delphi - .....................................
neoturk: ...Get the last access from a file ?...
{1.}
function GetFileLastAccessTime(sFileName: string): TDateTime;
var
ffd: TWin32FindData;
dft: DWORD;
lft: TFileTime;
h: THandle;
begin
//
// get file information
h := Windows.FindFirstFile(PChar(sFileName), ffd);
if (INVALID_HANDLE_VALUE <> h) then
begin
//
// we're looking for just one file,
// so close our "find"
Windows.FindClose(h);
//
// convert the FILETIME to
// local FILETIME
FileTimeToLocalFileTime(ffd.ftLastAccessTime, lft);
//
// convert FILETIME to
// DOS time
FileTimeToDosDateTime(lft, LongRec(dft).Hi, LongRec(dft).Lo);
//
// finally, convert DOS time to
// TDateTime for use in Delphi's
// native date/time functions
Result := FileDateToDateTime(dft);
end;
end;
{********************************************************************}
{2.}
function GetFileTimes(const FileName: string; var Created: TDateTime;
var Accessed: TDateTime; var Modified: TDateTime): Boolean;
var
h: THandle;
Info1, Info2, Info3: TFileTime;
SysTimeStruct: SYSTEMTIME;
TimeZoneInfo: TTimeZoneInformation;
Bias: Double;
begin
Result := False;
Bias := 0;
h := FileOpen(FileName, fmOpenRead or fmShareDenyNone);
if h > 0 then
begin
try
if GetTimeZoneInformation(TimeZoneInfo) <> $FFFFFFFF then
Bias := TimeZoneInfo.Bias / 1440; // 60x24
GetFileTime(h, @Info1, @Info2, @Info3);
if FileTimeToSystemTime(Info1, SysTimeStruct) then
Created := SystemTimeToDateTime(SysTimeStruct) - Bias;
if FileTimeToSystemTime(Info2, SysTimeStruct) then
Accessed := SystemTimeToDateTime(SysTimeStruct) - Bias;
if FileTimeToSystemTime(Info3, SysTimeStruct) then
Modified := SystemTimeToDateTime(SysTimeStruct) - Bias;
Result := True;
finally
FileClose(h);
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Date1, Date2, Date3: TDateTime;
begin
if GetFileTimes(Edit1.Text, Date1, Date2, Date3) then
begin
ShowMessage('Created: ' + DateTimeToStr(Date1));
ShowMessage('Last Accessed: ' + DateTimeToStr(Date2));
ShowMessage('Last Modified: ' + DateTimeToStr(Date3));
end;
end;
Delphi - .....................................
neoturk: ...Get the last access from a file ?...
{1.}
function GetFileLastAccessTime(sFileName: string): TDateTime;
var
ffd: TWin32FindData;
dft: DWORD;
lft: TFileTime;
h: THandle;
begin
//
// get file information
h := Windows.FindFirstFile(PChar(sFileName), ffd);
if (INVALID_HANDLE_VALUE <> h) then
begin
//
// we're looking for just one file,
// so close our "find"
Windows.FindClose(h);
//
// convert the FILETIME to
// local FILETIME
FileTimeToLocalFileTime(ffd.ftLastAccessTime, lft);
//
// convert FILETIME to
// DOS time
FileTimeToDosDateTime(lft, LongRec(dft).Hi, LongRec(dft).Lo);
//
// finally, convert DOS time to
// TDateTime for use in Delphi's
// native date/time functions
Result := FileDateToDateTime(dft);
end;
end;
{********************************************************************}
{2.}
function GetFileTimes(const FileName: string; var Created: TDateTime;
var Accessed: TDateTime; var Modified: TDateTime): Boolean;
var
h: THandle;
Info1, Info2, Info3: TFileTime;
SysTimeStruct: SYSTEMTIME;
TimeZoneInfo: TTimeZoneInformation;
Bias: Double;
begin
Result := False;
Bias := 0;
h := FileOpen(FileName, fmOpenRead or fmShareDenyNone);
if h > 0 then
begin
try
if GetTimeZoneInformation(TimeZoneInfo) <> $FFFFFFFF then
Bias := TimeZoneInfo.Bias / 1440; // 60x24
GetFileTime(h, @Info1, @Info2, @Info3);
if FileTimeToSystemTime(Info1, SysTimeStruct) then
Created := SystemTimeToDateTime(SysTimeStruct) - Bias;
if FileTimeToSystemTime(Info2, SysTimeStruct) then
Accessed := SystemTimeToDateTime(SysTimeStruct) - Bias;
if FileTimeToSystemTime(Info3, SysTimeStruct) then
Modified := SystemTimeToDateTime(SysTimeStruct) - Bias;
Result := True;
finally
FileClose(h);
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Date1, Date2, Date3: TDateTime;
begin
if GetFileTimes(Edit1.Text, Date1, Date2, Date3) then
begin
ShowMessage('Created: ' + DateTimeToStr(Date1));
ShowMessage('Last Accessed: ' + DateTimeToStr(Date2));
ShowMessage('Last Modified: ' + DateTimeToStr(Date3));
end;
end;
Delphi - .....................................
neoturk: ...Move a file in the recycle bin ?...
uses ShellAPI;
function DeleteFileWithUndo(sFileName: string): Boolean;
var
fos: TSHFileOpStruct;
begin
FillChar(fos, SizeOf(fos), 0);
with fos do
begin
wFunc := FO_DELETE;
pFrom := PChar(sFileName);
fFlags := FOF_ALLOWUNDO or FOF_NOCONFIRMATION or FOF_SILENT;
end;
Result := (0 = ShFileOperation(fos));
end;
Delphi - .....................................
neoturk: ...Move a file in the recycle bin ?...
uses ShellAPI;
function DeleteFileWithUndo(sFileName: string): Boolean;
var
fos: TSHFileOpStruct;
begin
FillChar(fos, SizeOf(fos), 0);
with fos do
begin
wFunc := FO_DELETE;
pFrom := PChar(sFileName);
fFlags := FOF_ALLOWUNDO or FOF_NOCONFIRMATION or FOF_SILENT;
end;
Result := (0 = ShFileOperation(fos));
end;
Delphi - .....................................
neoturk: ...Check if a path exists ?...
uses FileCtrl;
procedure TForm1.Button1Click(Sender: TObject);
begin
if DirectoryExists('c:windows') then
ShowMessage('Path exists!');
end;
'