Z wykorzystaniem komunikatu Win API: EM_LINEFROMCHAR i EM_LINEINDEX
var LineNum: longint; CharsBeforeLine: longint;
begin
LineNum := SendMessage(Memo1.Handle, EM_LINEFROMCHAR, Memo1.SelStart,0);
CharsBeforeLine := SendMessage(Memo1.Handle, EM_LINEINDEX, LineNum, 0);
Label1.Caption := 'Line ' + IntToStr(LineNum +1)
Label2.Caption := 'Position ' + IntToStr((Memo1.SelStart -CharsBeforeLine) + 1);
end;
Klawisz wciskamy w oknie Edit1 a w Edit2 mamy pozycję tego znaku
unit Cursor;
interface
uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls;
type TForm1 = class(TForm)
Edit1: TEdit; Edit2: TEdit;
procedure Edit1Change(Sender: TObject);
procedure Edit1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
private { Private declarations }
public { Public declarations }
CurPos : integer;
end;
var Form1: TForm1;
implementation {$R *.DFM}
procedure TForm1.Edit1Change(Sender: TObject);
begin
CurPos := Edit1.SelStart; edit2.Text := IntToStr(CurPos);
end;
procedure TForm1.Edit1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
If Key = VK_LEFT then dec(CurPos);
if Key = VK_RIGHT then inc(CurPos); {RIGHT Arrow}
edit2.text := inttostr(CurPos);
end;
end.
procedura podaje pozycję kursora myszy bez potrzeby wciskania jakiegokolwiek jej klawisza
Var MyX, MyY : Integer;
Procedure Form1.Image1MouseMove(Sender : TObject...);
Var MyPoint : TPoint;
Begin If Timer1.Enabled Then Begin
MyPoint.X:=X; MyPoint.Y:=Y;
MyPoint:=ClientToScreen(MyPoint);
MyX:=MyPoint.X; MyY:=MyPoint.Y
End End;
w przykładzie dodano pozycję ''Zarejestruj''
procedure AppendToSystemMenu (Form: TForm; Item: string; ItemID: word);
var NormalSysMenu, MinimizedMenu: HMenu; AItem: array[0..255] of Char; PItem: PChar;
begin
NormalSysMenu := GetSystemMenu(Form.Handle, false);
MinimizedMenu := GetSystemMenu(Application.Handle, false);
if Item = '-' then begin //pozycja dodana po znaku separatora
AppendMenu(NormalSysMenu, MF_SEPARATOR, 0, nil);
AppendMenu(MinimizedMenu, MF_SEPARATOR, 0, nil);
end else begin
PItem := StrPCopy(@AItem, Item);
AppendMenu(NormalSysMenu, MF_STRING, ItemID, PItem);
AppendMenu(MinimizedMenu, MF_STRING, ItemID, PItem);
end end; {AppendToSystemMenu}
{ i teraz dodawanie............ }
AppendToSystemMenu(MainForm, '-', 0); {dodaj linie separatora}
AppendToSystemMenu(MainForm, 'Zarejestruj...', 99);
Application.OnMessage := MainForm.RegisterMsg;
//jak użytkownik kliknie na pozycję ''Zarejestruj'' to uaktywnia się procedura poniżej....
procedure TMainForm.RegisterMsg (var Msg: TMsg; var Handled: boolean);
begin
if Msg.Message = WM_SYSCOMMAND then if Msg.wParam = 99 then {Registration stuff}
end;
z tą procedurą ostrożnie - upewnij się czy nowe dane w tych aplikacjach już zapisane - bo inaczej to przepadną!
procedure TForm1.ButtonKillAllClick(Sender: TObject);
var pTask : PTaskEntry; Task : Bool; ThisTask: THANDLE;
begin
GetMem (pTask, SizeOf (TTaskEntry)); pTask^.dwSize := SizeOf (TTaskEntry);
Task := TaskFirst (pTask);
while Task do begin
if pTask^.hInst = hInstance then ThisTask := pTask^.hTask
else TerminateApp (pTask^.hTask, NO_UAE_BOX); Task := TaskNext (pTask);
end; TerminateApp (ThisTask, NO_UAE_BOX);
end;
unit Unit1;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,shellapi,Dialogs;
type TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private { Private declarations }
public { Public declarations }
end;
var Form1: TForm1; DesktopIcon: TimageList; // I Love you imagelist
implementation {$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
Var Ico: TIcon; Sfi: Tshfileinfo; I : Integer;
begin // Assign Handle to imageList
DesktopIcon:= TImageList.Create(Self);
DesktopIcon.Handle := SHGetFileInfo('', 0, sfi, SizeOf(TSHFileInfo),
shGFI_SYSICONINDEX or SHGFI_SMALLICON);
DesktopIcon.ShareImages := TRUE;
For I:=0 to DesktopIcon.count -1 do Begin
Ico := Ticon.Create; DesktopIcon.GetIcon(I,Ico);
Ico.SaveToFile('c:\icons\'+inttostr(i)+'.ico'); Ico.Free;
End; end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Desktopicon.free;
end;
end.
z wykorzystaniem typowego okna Windowsa ''Search directory''
Uses FileCtrl;
Procedure BrowseClick;
Var S : string;
Begin
S := ''; If SelectDirectory ('Select Directory', '', S) Then SetPath (S);
End;
uses ...,ShellApi
function TDM.DeleteTree(SrcPath: String): Boolean;
var FileOpStruct: TShFileOpStruct;
begin
FileOpStruct.Wnd := Application.Handle; FileOpStruct.wFunc := FO_DELETE;
FileOpStruct.pFrom := PChar(SrcPath); FileOpStruct.pTo := Nil;
FileOpStruct.fFlags := FOF_NOCONFIRMATION or FOF_SILENT or FOF_NOERRORUI;
FileOpStruct.lpszProgressTitle := Nil; Result := ShFileOperation(FileOpStruct) = 0;
end;
uses ShellAPI;
function FileCopy(Source, Destination: string): boolean;
var ShFileOpStruct: TShFileOpStruct;
begin
with ShFileOpStruct do begin { operation; FO_MOVE to move the file }
wFunc := FO_COPY; { set source filename }
pFrom := PChar(Source); { set destination filename }
pTo := PChar(Destination);
end;
{ zwraca true jeżeli operacja przeprowadzona poprawnie lub false gdy niepowodzenie }
result := (0 = SHFileOperation(ShFileOpStruct));
end;
procedure hideStartbutton(visi:boolean);
Var Tray, Child : hWnd; C : Array[0..127] of Char; S : String;
Begin
Tray := FindWindow('Shell_TrayWnd', NIL); Child := GetWindow(Tray, GW_CHILD);
While Child < > 0 do Begin
If GetClassName(Child, C, SizeOf(C)) > 0 Then Begin
S := StrPAS(C); If UpperCase(S) = 'TRAYNOTIFYWND' then begin
If Visi then ShowWindow(Child, 1)
else ShowWindow(Child, 0); end; End; Child := GetWindow(Child, GW_HWNDNEXT);
End; End;
//a wykonanie to...
hideStartbutton(true); //jeżeli ma być widoczny
hideStartbutton(false); //jeżeli ma być ukryty
{ Zwraca rozmiar fontów w Menu }
function GetMenuFontSize: Integer;
var ncm: TNonClientMetrics; PixelsPerInch: integer;
begin
ncm.cbSize := sizeof(TNonClientMetrics);
SystemParametersInfo( SPI_GETNONCLIENTMETRICS,
sizeof(NONCLIENTMETRICS), @ncm, SPIF_UPDATEINIFILE );
PixelsPerInch := GetDeviceCaps(GetDC(0), LOGPIXELSY);
Result := -MulDiv(ncm.lfMenuFont.lfHeight, 72, PixelsPerInch);
end;
{ Ustawai rozmiar.... }
procedure SetMenuFontSize(FontSize: Integer);
var ncm: TNonClientMetrics; PixelsPerInch: Integer;
begin
ncm.cbSize := sizeof(TNonClientMetrics);
SystemParametersInfo( SPI_GETNONCLIENTMETRICS,
sizeof(NONCLIENTMETRICS), @ncm, 0 );
PixelsPerInch := GetDeviceCaps(GetDC(0), LOGPIXELSY);
ncm.lfMenuFont.lfHeight := -MulDiv(FontSize, PixelsPerInch, 72);
SystemParametersInfo( SPI_SETNONCLIENTMETRICS,
sizeof(NONCLIENTMETRICS), @ncm, SPIF_UPDATEINIFILE );
end;
dostęp do nich (ich katalogu) poprzez funkcję API - GetTempPath . W przykładzie po kliku na Button1 te pliki są wyszczególnone w polu Memo1.
procedure TForm1.Button1Click(Sender: TObject);
function CreateTmpFileName(Prefijo: String): String;
var Path : array[0..MAX_PATH] of Char; Fichero : array[0..MAX_PATH] of Char;
begin
FillChar(Path,SizeOf(Path),#0); FillChar(Fichero,SizeOf(Fichero),#0);
GetTempPath(MAX_PATH, Path); GetTempFilename(Path, PChar(Prefijo), 0, Fichero);
Result := Fichero;
end;
begin
Memo1.Lines.Append( CreateTmpFileName('TmpF') );
end;
W przykładzie poniżej klawisz ENTER (VK_RETURN) w oknach edycyjnych pochodnych od TCustomEdit (TEdit, TDBEdit, TMaskEdit, SpinEdit, TDBMaskEdit, TMemo, TDBMemo itp) bedzie wykorzystywany jak klawisz tabulatora (VK_TAB) . W Memo będzie to zmiana linii.
type TForm1 = class(TForm)
...
private
...
procedure ApplicationMessage(var Msg: TMsg; var Handled: Boolean);
...
end;
var Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
Application.OnMessage := ApplicationMessage;
end;
procedure TForm1.ApplicationMessage(var Msg: TMsg; var Handled: Boolean);
var ActiveControl : TWinControl; Form : TCustomForm;
ShiftState : TShiftState; KeyState : TKeyboardState;
begin
case Msg.Message of
WM_KEYDOWN, WM_KEYUP:
case Msg.wParam of
VK_RETURN: // zamienia ENTER na TAB i CTRL+ENTER na ENTER...
begin
GetKeyboardState(KeyState);
ShiftState := KeyboardStateToShiftState(KeyState);
if (ShiftState = []) or (ShiftState = [ssCtrl]) then begin
ActiveControl := Screen.ActiveControl;
if (ActiveControl is TCustomComboBox) and
(TCustomComboBox(ActiveControl).DroppedDown) then begin
if ShiftState = [ssCtrl] then begin
KeyState[VK_LCONTROL] := KeyState[VK_LCONTROL] and $7F;
KeyState[VK_RCONTROL] := KeyState[VK_RCONTROL] and $7F;
KeyState[VK_CONTROL] := KeyState[VK_CONTROL] and $7F;
SetKeyboardState(KeyState);
end;
end else if (ActiveControl is TCustomEdit)
and not (ActiveControl is TCustomMemo)
or (ActiveControl is TCustomCheckbox)
or (ActiveControl is TRadioButton)
or (ActiveControl is TCustomListBox)
or (ActiveControl is TCustomComboBox)
// You can add more controls to the list with "or"
then
if ShiftState = [] then begin
Msg.wParam := VK_TAB
end else begin // ShiftState = [ssCtrl]
Msg.wParam := 0; // Discard the key
if Msg.Message = WM_KEYDOWN then begin
Form := GetParentForm(ActiveControl);
if (Form < > nil) and
(ActiveControl.Perform(CM_WANTSPECIALKEY, VK_RETURN, 0) = 0) and
(ActiveControl.Perform(WM_GETDLGCODE, 0, 0) and DLGC_WANTALLKEYS = 0) then
begin
KeyState[VK_LCONTROL] := KeyState[VK_LCONTROL] and $7F;
KeyState[VK_RCONTROL] := KeyState[VK_RCONTROL] and $7F;
KeyState[VK_CONTROL] := KeyState[VK_CONTROL] and $7F;
SetKeyboardState(KeyState);
Form.Perform(CM_DIALOGKEY, VK_RETURN, Msg.lParam);
end; end; end; end; end; end; end;
end;
Typowa forma ma z reguły kształt prostokąta. Tworząc jednak proste Regiony i łącząc je można uzyskać skomplikowane formy.
// poniżej kod tworzy formę eliptyczną
procedure TForm1.FormCreate(Sender: TObject);
var hRgn: THandle;
begin
// tworzenie elipsy mniejszej o 10 pikseli od formy
hRgn := CreateEllipticRgn(10, 10, Width - 20, Height - 20);
//ustawia nowy region
SetWindowRgn(Handle, hRgn, False);
end;
// to tworzy formę z dziurą pośrodku
procedure TForm1.FormCreate(Sender: TObject);
var hRgn1, hRgn2: THandle;
begin
// tworzy prostokąt o szer. formy
hRgn1 := CreateRectRgn(0, 0, Width, Height);
// tworzenie koła 100 na 100 pośrodku formy
hRgn2 := CreateEllipticRgn((Width div 2) - 50, (Height div 2) - 50, (Width div 2) + 50, (Height div 2) + 50);
// łączy regiony poprzez odejmowanie od prostokąta koła
CombineRgn(hRgn1, hRgn1, hRgn2, RGN_DIFF);
// ustawia nowy region
SetWindowRgn(Handle, hRgn1, False);
// usuwa region 2
DeleteObject(hRgn2);
end;
procedure TForm1.FormOnCreate(Sender: TOBject);
begin
SetWindowLong(Application.Handle, GWL_EXSTYLE, WS_EX_TOOLWINDOW);
end;
ponizszy objekt dostarcza (wyciąga) informacje z plików wykonywalnych i bibliotek
unit siverinfo;
interface
uses Windows, Classes, SysUtils;
type TVersionInfo = class(TObject)
private
FData: Pointer; FSize: Cardinal; FCompanyName: string; FFileDescription: string;
FFileVersion: string; FInternalName: string; FLegalCopyright: string;
FLegalTrademarks: string; FOriginalFilename: string; FProductName: string;
FProductVersion: string; FComments: string;
public
constructor Create(FileName: string);
destructor Destroy; override;
property CompanyName: string read FCompanyName;
property FileDescription: string read FFileDescription;
property FileVersion: string read FFileVersion;
property InternalName: string read FInternalName;
property LegalCopyright: string read FLegalCopyright;
property LegalTrademarks: string read FLegalTrademarks;
property OriginalFilename: string read FOriginalFilename;
property ProductName: string read FProductName;
property ProductVersion: string read FProductVersion;
property Comments: string read FComments;
end;
implementation { TVersionInfo }
constructor TVersionInfo.Create(FileName: string);
var sz, lpHandle, tbl: Cardinal; lpBuffer: Pointer; str: PChar;
strtbl: string; int: PInteger; hiW, loW: Word;
begin
inherited Create;
FSize := GetFileVersionInfoSize(PChar(FileName), lpHandle);
FData := AllocMem(FSize);
GetFileVersionInfo(PChar(FileName), lpHandle, FSize, FData);
VerQueryValue(FData, '\\VarFileInfo\Translation', lpBuffer, sz);
int := lpBuffer; hiW := HiWord(int^); loW := LoWord(int^);
tbl := (loW shl 16) or hiW; strtbl := Format('%x', [tbl]);
if Length(strtbl) < 8 then strtbl := '0' + strtbl;
VerQueryValue(FData, PChar('\\StringFileInfo\'+strtbl+'\CompanyName'), lpBuffer, sz);
str := lpBuffer; FCompanyName := str;
VerQueryValue(FData, PChar('\\StringFileInfo\'+strtbl+'\FileDescription'), lpBuffer, sz);
str := lpBuffer; FFileDescription := str;
VerQueryValue(FData, PChar('\\StringFileInfo\'+strtbl+'\FileVersion'), lpBuffer, sz);
str := lpBuffer; FFileVersion := str;
VerQueryValue(FData, PChar('\\StringFileInfo\'+strtbl+'\InternalName'), lpBuffer, sz);
str := lpBuffer; FInternalName := str;
VerQueryValue(FData, PChar('\\StringFileInfo\'+strtbl+'\LegalCopyright'), lpBuffer, sz);
str := lpBuffer; FLegalCopyright := str;
VerQueryValue(FData, PChar('\\StringFileInfo\'+strtbl+'\LegalTrademarks'), lpBuffer, sz);
str := lpBuffer; FLegalTrademarks := str;
VerQueryValue(FData, PChar('\\StringFileInfo\'+strtbl+'\OriginalFilename'), lpBuffer, sz);
str := lpBuffer; FOriginalFilename := str;
VerQueryValue(FData, PChar('\\StringFileInfo\'+strtbl+'\ProductName'), lpBuffer, sz);
str := lpBuffer; FProductName := str;
VerQueryValue(FData, PChar('\\StringFileInfo\'+strtbl+'\ProductVersion'), lpBuffer, sz);
str := lpBuffer; FProductVersion := str;
VerQueryValue(FData, PChar('\\StringFileInfo\'+strtbl+'\Comments'), lpBuffer, sz);
str := lpBuffer; FComments := str;
end;
destructor TVersionInfo.Destroy;
begin
FreeMem(FData);
inherited;
end;
end.
przesuwa na formie takie komponenty jak TButton, TLabel i inne
w OnMouseDown tych komponentów wprowadzić - MoveObject(Sender, X, Y);
uses Windows, Messages;
procedure MoveObject(Sender: TObject; X, Y: Integer);
const SC_DragMove = $F012;
begin
ReleaseCapture;
(Sender as TControl).Perform(WM_SysCommand, SC_DragMove, 0);
end;
za pomocą funkcji API - SetWindowLong w procedurze FormCreate
procedure TForm1.FormCreate(Sender: TObject);
begin
SetWindowLong(Handle, GWL_STYLE,
GetWindowLong(Handle,GWL_STYLE) AND NOT WS_CAPTION);
ClientHeight := Height;
Refresh;
end;
Opis można wprawdzie ukryć dając własciwość BorderStyle = bsNone ale wówczas okno nie ma ramki.
wysłanie do systemu zdarzenia WM_QUIT:
PostMessage(FindWindow(Nil, 'window caption'), WM_QUIT, 0, 0);
//gdzie 'window caption' jest nagłówkiem okna wysyłającego wiadomość
w przykładzie użyto pętli, która sprawdza czas i wysyła wiadomości (ProcessMessage) pozwalając Windowsowi na wykonywanie petli.
procedure Delay(ms : longint);
var TheTime : LongInt;
begin
TheTime := GetTickCount + ms;
while GetTickCount < TheTime do
Application.ProcessMessages;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage('Start Test');
Delay(2000);
ShowMessage('End Test');
end;
uses ...,ShellApi
function TDM.DeleteTree(SrcPath: String): Boolean;
var FileOpStruct: TShFileOpStruct;
begin
FileOpStruct.Wnd := Application.Handle;
FileOpStruct.wFunc := FO_DELETE;
FileOpStruct.pFrom := PChar(SrcPath);
FileOpStruct.pTo := Nil;
FileOpStruct.fFlags := FOF_NOCONFIRMATION or FOF_SILENT or FOF_NOERRORUI;
FileOpStruct.lpszProgressTitle := Nil;
Result := ShFileOperation(FileOpStruct) = 0;
end;
uses ShellAPI;
{ ...code...}
procedure SendMail(Address, Subject, Text: string);
var H: HWND;
begin
H:=Application.Handle;
ShellExecute(H,'open',PChar('mailto:'+Address+'?subject='+Subject+
'&body='+Text),nil,nil,SW_SHOW);
end;
{ a tak używać }
procedure TMainForm.EmailButtonClick(Sender: TObject);
begin
SendMail('awalum@interia.pl','Fajna informacja','Serwus Johny!');
end;
ta funkcja wykrywa tylko czy aktualny plik .DLL posiada w sobie funkcje czy nie. Jeżeli posiada to zwraca TRUE; w innym przypadku zwraca FALSE
function FuncAvail (VLibraryname, VFunctionname: string; var VPointer: pointer): boolean;
var Vlib: tHandle;
begin
Result := false;
VPointer := NIL;
if LoadLibrary(PChar(VLibraryname)) = 0 then exit;
VPointer := GetModuleHandle(PChar(VLibraryname));
if Vlib < > 0 then begin
VPointer := GetProcAddress(Vlib, PChar(VFunctionname));
if VPointer < > NIL then
Result := true;
end;
end;
funkcja zwraca łańcuch w formacie 'n.n.n.n' i ładuje odpowiednie wartości do zmiennych nValue1,2,3,4, które muszą być różnymi..
function GetFileVersion(const sFilename: String; var nValue1,nValue2,nValue3,nValue4: Integer): string;
var pInfo,pPointer: Pointer; nSize: DWORD; nHandle: DWORD;
pVerInfo: PVSFIXEDFILEINFO; nVerInfoSize: DWORD;
begin
Result:='?.?.?.?';
nValue1:=-1;
nValue2:=-1;
nValue3:=-1;
nValue4:=-1;
nSize:=GetFileVersionInfoSize(PChar(sFilename),nHandle);
if (nSize< >0) then begin
GetMem(pInfo,nSize);
try FillChar(pInfo^,nSize,0);
if (GetFileVersionInfo(PChar(sFilename),nHandle,nSize,pInfo)) then begin
nVerInfoSize:=SizeOf(VS_FIXEDFILEINFO);
GetMem(pVerInfo,nVerInfoSize);
try FillChar(pVerInfo^,nVerInfoSize,0);
pPointer:=Pointer(pVerInfo);
VerQueryValue(pInfo,'\',pPointer,nVerInfoSize);
nValue1:=PVSFIXEDFILEINFO(pPointer)^.dwFileVersionMS shr 16;
nValue2:=PVSFIXEDFILEINFO(pPointer)^.dwFileVersionMS and $FFFF;
nValue3:=PVSFIXEDFILEINFO(pPointer)^.dwFileVersionLS shr 16;
nValue4:=PVSFIXEDFILEINFO(pPointer)^.dwFileVersionLS and $FFFF;
Result:=IntToStr(nValue1)+'.'+IntToStr(nValue2)+'.'+IntToStr(nValue3)+'.'+IntToStr(nValue4);
finally FreeMem(pVerInfo,nVerInfoSize);
end; end;
finally FreeMem(pInfo,nSize);
end; end;
end;
W przykładzie czcionka jest obrócona o 45 stopni. Do tego nalezy używac jedynie czcionki TrueType
procedure TForm1.Button1Click(Sender: TObject);
var lf : TLogFont; tf : TFont;
begin
with Form1.Canvas do begin
Font.Name := 'Arial';
Font.Size := 24;
tf := TFont.Create;
tf.Assign(Font);
GetObject(tf.Handle, sizeof(lf), @lf);
lf.lfEscapement := 450;
lf.lfOrientation := 450;
tf.Handle := CreateFontIndirect(lf);
Font.Assign(tf);
tf.Free;
TextOut(20, Height div 2, 'Ten tekst jest pokręcony!');
end; end;
kompletny program - tworzy formę z rysunkiem koła ; rozmiar pliku - ok 18 kb
program PlainAPI;
uses Windows, Messages;
{$R *.res}
function PlainWinProc (hWnd: THandle; nMsg: UINT;
wParam, lParam: Cardinal): Cardinal; export; stdcall;
var hdc: THandle; ps: TPaintStruct;
begin
Result := 0; case nMsg of
wm_lButtonDown:
MessageBox (hWnd, 'Mysz kliknięta', 'Plain API', MB_OK);
wm_Paint:
begin
hdc := BeginPaint (hWnd, ps); Ellipse (hdc, 100, 100, 300, 300);
EndPaint (hWnd, ps);
end;
wm_Destroy:
PostQuitMessage (0);
else Result := DefWindowProc (hWnd, nMsg, wParam, lParam);
end; end;
procedure WinMain;
var hWnd: THandle; Msg: TMsg; WndClassEx: TWndClassEx;
begin
// initialize the window class structure
WndClassEx.cbSize := sizeOf (TWndClassEx);
WndClassEx.lpszClassName := 'PlainWindow';
WndClassEx.style := cs_VRedraw or cs_HRedraw;
WndClassEx.hInstance := HInstance;
WndClassEx.lpfnWndProc := @PlainWinProc;
WndClassEx.cbClsExtra := 0;
WndClassEx.cbWndExtra := 0;
WndClassEx.hIcon := LoadIcon (hInstance, MakeIntResource ('MAINICON'));
WndClassEx.hIconSm := LoadIcon (hInstance, MakeIntResource ('MAINICON'));
WndClassEx.hCursor := LoadCursor (0, idc_Arrow);;
WndClassEx.hbrBackground := GetStockObject (white_Brush);
WndClassEx.lpszMenuName := nil;
// register the class
if RegisterClassEx (WndClassEx) = 0 then
MessageBox (0, 'Zła klasa', 'Plain API', MB_OK)
else begin
hWnd := CreateWindowEx (ws_Ex_OverlappedWindow, // extended styles
WndClassEx.lpszClassName, // class name
'Plain API Demo', // title
ws_OverlappedWindow, // styles
cw_UseDefault, 0, // position
cw_UseDefault, 0, // size
0, // parent window
0, // menu
HInstance, // instance handle
nil); // initial parameters
if hWnd = 0 then
MessageBox (0, 'Okno nie jest stworzone', 'Plain API', MB_OK)
else begin
ShowWindow (hWnd, sw_ShowNormal);
while GetMessage (Msg, 0, 0, 0) do begin
TranslateMessage (Msg); DispatchMessage (Msg);
end; end; end; end;
begin
WinMain;
end.
procedure TForm1.Button1Click(Sender: TObject); //to klawiatura ruska
var Layout: array[0.. KL_NAMELENGTH] of char;
begin
LoadKeyboardLayout( StrCopy(Layout,'00000419'),KLF_ACTIVATE);
end;
procedure TForm1.Button2Click(Sender: TObject); //teraz klawiatura polska
var Layout: array[0.. KL_NAMELENGTH] of char;
begin
LoadKeyboardLayout(StrCopy(Layout,'00000415'),KLF_ACTIVATE);
end;
inne klawiatury... 410 - włoska, 409 - angielska (USA), 40C - francuska, 40A - hiszpańska itd.
W NT/2000/XP nie można odczytać wartości bezpośrednio z biosu, ale nic nie stoi na przeszkodzie, aby wziąć pod uwagę odpowiednie wartości z rejestru.
procedure tbiosinfo.getreginfowinnt;
var registryv : tregistry; regpath : string; sl : tstrings;
begin
params.clear;
regpath := '\hardware\description\system';
registryv:=tregistry.create;
registryv.rootkey:=hkey_local_machine; sl := nil;
try
registryv.openkey(regpath,false);
showmessage('bios date: '+registryv.readstring('systembiosdate'));
sl := readmultirowkey(registryv,'systembiosversion');
showmessage('bios version: '+sl.text);
except
end;
registryv.free; if assigned(sl) then sl.free;
end;
/ / Poniższa metoda pobiera wiele wartości z rejestru i zamienia je na TStringList
function readmultirowkey(reg: tregistry; key: string): tstrings;
const bufsize = 100;
var i: integer; s1: string; sl: tstringlist; bin: array[1..bufsize] of char;
begin
try result := nil; sl := nil; sl := tstringlist.create;
if not assigned(reg) then
raise exception.create('tregistry object not assigned.');
fillchar(bin,bufsize,#0); reg.readbinarydata(key,bin,bufsize);
i := 1; s1 := '';
while i < bufsize do begin
if ord(bin[i]) > = 32 then s1 := s1 + bin[i]
else begin
if length(s1) > 0 then begin
sl.add(s1); s1 := ''; end; end; inc(i); end; result := sl;
except
sl.free; raise; end;
end;
1. Uruchom delphi.Pojawi się puste okno.
2. Wybierz project - view source.
3. Usuń wszystko z wyjątkiem: program, uses, var, begin, end.
4. Wstaw poniższy kod.
program api;
uses windows, messages;
varwindow:twndclassex;mwindow: hwnd;mmsg: msg;
//Procedura przetwarzania wiadomości
function windowproc (wnd: hwnd; msg: integer; wparam: wparam; lparam: lparam):lresult;stdcall;
begin
case msg of wm_destroy:
begin
postquitmessage (0); result := 0; exit;
end; else result := defwindowproc(wnd,msg,wparam,lparam);
end; end;
// Rejestracja klasy okna
begin
window.cbsize := sizeof (window); window.style := cs_hredraw or cs_vredraw;
window.lpfnwndproc := @windowproc;
window.cbclsextra := 0; window.cbwndextra := 0;
window.hinstance := hinstance; window.hicon := loadicon (0,idi_application);
window.hcursor := loadcursor (0,idc_arrow); window.hbrbackground:=color_btnface+12;
window.lpszmenuname := nil; window.lpszclassname := 'main_window';
registerclassex (window);
// Utworzenie okna na podstawie wygenerowanej klasy
mwindow := createwindowex(0,'main_window','first_winapi_programm',
ws_overlappedwindow,100,100,300,300,0,0,hinstance,nil);
//Wyświetlenie okna utworzonego przez
showwindow (mwindow,sw_show);
//Pętla wiadomości
while getmessage (mmsg,0,0,0) do
begin
translatemessage (mmsg); dispatchmessage (mmsg);
end; end.
Jak wstawić własny kursor z pliku zewnętrznego? Korzystanie z loadcursorfromfile procedury
var h:hcursor;
begin
h:=loadcursorfromfile('d:mc.cur'); screen.cursors[1]:=h; form1.cursor:=1;
end;
var h : thandle;
begin
h := loadimage(0, 'c:cursor.cur', image_cursor, 0, 0, lr_defaultsize or lr_loadfromfile);
if h = 0 then showmessage('kursora nie mogę załadować!')
else begin
screen.cursors[1] := h; form1.cursor := 1;
end; end;
Ten przykład pozwala na wykorzystanie animowanych kursorów (*. ani)! Oto kawałek kodu, aby załadować animowany kursor, który można włożyć do przetwarzania zdarzeń aktywizacji formy:
var h : thandle; name: array[0..255] of char;
begin
strpcopy(name,'animcurs.ani');
h:=loadimage(0,name,image_cursor, 0, 0, lr_defaultsize or lr_loadfromfile);
if h< >0 then begin
screen.cursors[1]:=h; screen.cursor:=1;
end else
screen.cursor:=crdefault;
end;
Musisz wiedzieć o stałych, które odpowiadają za określanie ikon. Wszystkie one są zdefiniowane w pliku odpowiedzialnym za API w Delphi - windows.pas:
idi_hand, idi_exclamation lub idi_question
Poniższy przykład rysuje ikonę znaku zapytania na pasku narzędzi:
var dc: hdc; icon: hicon;
begin
dc:= getwindowdc(panel1.handle); icon:= loadicon(0, idi_question);
drawicon(dc, 5,5, icon); releasedc(panel1.handle, dc);
end;
{$r cursors.res}
const crzoomin = 1; crzoomout = 2;
screen.cursors[crzoomin] := loadcursor(hinstance, 'cursor_zoomin');
screen.cursors[crzoomout] := loadcursor(hinstance, 'cursor_zoomout');
Zapisywanie całej zawartości schowka do pliku
var fs:tfilestream;
procedure tform1.bclearclick(sender: tobject);
begin
openclipboard(0); emptyclipboard; closeclipboard;
end;
procedure tform1.bsaveclick(sender: tobject);
var cbf:cardinal; cbflist:tlist; i:integer; h:thandle; p:pointer;
cbblocklength,temp:cardinal; fs:tfilestream;
begin
if openclipboard(0)then begin
cbflist:=tlist.create; cbf:=0;
repeat
cbf:=enumclipboardformats(cbf);
if cbf< >0 then cbflist.add(pointer(cbf));
until cbf=0;
edit1.text:=inttostr(cbflist.count); if cbflist.count > 0 then
begin
fs:=tfilestream.create('e:cp.dat',fmcreate); temp:=cbflist.count;
fs.write(temp,sizeof(integer));
for i:=0 to cbflist.count-1 do
begin
h:=getclipboarddata(cardinal(cbflist[i])); if h >0 then
begin
cbblocklength:=globalsize(h); if h >0 then
begin
p:=globallock(h); if p < > nil then
begin
temp:=cardinal(cbflist[i]); fs.write(temp,sizeof(cardinal));
fs.write(cbblocklength,sizeof(cardinal)); fs.write(p^,cbblocklength);
end;
globalunlock(h); end; end; end;
fs.free; end;
cbflist.free; closeclipboard;
end; end;
procedure tform1.bloadclick(sender: tobject);
var h:thandle; p:pointer; cbf:cardinal; cbblocklength:cardinal;
i, cbcount:integer; fs:tfilestream;
begin
if openclipboard(0)then begin
fs:=tfilestream.create('e:cp.dat',fmopenread);
if fs.size=0 then exit;
fs.read(cbcount,sizeof(integer)); if cbcount=0 then exit;
for i:=1 to cbcount do begin
fs.read(cbf,sizeof(cardinal)); fs.read(cbblocklength,sizeof(cardinal));
h:=globalalloc(gmem_moveable or gmem_share or gmem_zeroinit,cbblocklength);
if h > 0 then begin
p:=globallock(h); if p=nil then globalfree(h)
else begin
fs.read(p^,cbblocklength); globalunlock(h); setclipboarddata(cbf,h);
end; end; end;
fs.free; closeclipboard;
end; end;
W tym przykładzie użyto buttona i komponentu TShape na formie. Gdy użytkownik kliknie button obraz jest przechowywany w postaci zmiennej formimage i kopiowany do schowka (clipboard). Obraz jest następnie kopiowany spowrotem do TShape tworząc ciekawy efekt, zwłaszcza jeśli button klikniemy kilka razy.
procedure tform1.button1click(sender: tobject);
var formimage: tbitmap;
begin
formimage := getformimage;
try clipboard.assign(formimage);
image1.picture.assign(clipboard);
finally formimage.free; end;
end;
procedure tform1.formcreate(sender: tobject);
begin
shape1.shape := stellipse; shape1.brush.color := cllime; image1.stretch := true;
end;
W ponizszym przykładzie skopiowano zawartość ekranu do schowka:
procedure copyscreentoclipboard;
var dx,dy : integer; hsourcdc,hdestdc, hbm, hbmold : thandle;
begin
dx := screen.width; dy := screen.height;
hsourcdc := createdc('display',nil,nil,nil); hdestdc := createcompatibledc(hsourcdc);
hbm := createcompatiblebitmap(hsourcdc, dx, dy);
hbmold:= selectobject(hdestdc, hbm); bitblt(hdestdc, 0, 0, dx, dy, hsourcdc, 0, 0, srccopy);
openclipboard(form1.handle); emptyclipboard;
setclipboarddata(cf_bitmap, hbm); closeclipboard;
selectobject(hdestdc,hbmold); deleteobject(hbm);
deletedc(hdestdc); deletedc(hsourcdc);
end;
procedure tform1.cut1click(sender: tobject);
begin
sendmessage (activecontrol.handle, wm_cut, 0, 0);
end;
procedure tform1.copy1click(sender: tobject);
begin
sendmessage (activecontrol.handle, wm_copy, 0, 0);
end;
procedure tform1.paste1click(sender: tobject);
begin
sendmessage (activecontrol.handle, wm_paste, 0, 0);
end;
Dla aplikacji MDI należy wysłać wiadomość do aktywnego okna dziecka (MDI Child) stosując:
activemdichild.activecontrol.handle
Aby do schoka wpakować strumień TMemorystream stworzyć fwłasny format danych za pomocą funkcji:
registerclipboardformat():
cf_myformat: = registerclipboardformat ("mój opis formatu ');
Następnie wykonaj następujące czynności:
1. Tworzenie strumienia (stream) i zapisać danych.
2. Stworzenia globalnego bufora pamięci i skopiować strumień (stream).
3. Przy pomocy Clipboard.setashandle() wcisnąć globalny bufor do schowka.
// przykład:
var hbuf : thandle; bufptr : pointer; mstream : tmemorystream;
begin
mstream := tmemorystream.create;
try
{zapis danych do mstream. }
hbuf := globalalloc(gmem_moveable, mstream.size);
try bufptr := globallock(hbuf);
try move(mstream.memory^, bufptr^, mstream.size);
clipboard.setashandle(cf_myformat, hbuf);
finally globalunlock(hbuf); end;
except
globalfree(hbuf); raise; end;
finally mstream.free; end;
end;
WAŻNE: Nie usuwaj buforu po GlobalAlloc (). Jak tylko włożysz go do schowka to tego schoka już można używać.
Aby pobrać dane ze strumienia, można użyć następującego kodu:
var hbuf : thandle; bufptr : pointer; mstream : tmemorystream;
begin
hbuf := clipboard.getashandle(cf_myformat);
if hbuf < > 0 then begin
bufptr := globallock(hbuf); if bufptr < > nil then begin
try mstream := tmemorystream.create;
try mstream.writebuffer(bufptr^, globalsize(hbuf));
mstream.position := 0; { odczyt danych z mstream.}
finally mstream.free; end;
finally globalunlock(hbuf); end; end;
end; end;
procedure tform1.formcreate(sender: tobject);
var ofn : openfilename;
begin
zeromemory(@ofn, sizeof(openfilename));
with ofn do
begin
lstructsize:=sizeof(openfilename); lpstrinitialdir:='c:\windows';
lpstrtitle:='wybór dowolnego pliku'; nmaxfile:=255;
lpstrfile:=virtualalloc(0, 255, mem_commit, page_readwrite);
lpstrfilter:='win32 executables'+#0+'*.exe'+#0+'dowolny typ pliku'#0+'*.*'+#0#0;
flags:=ofn_filemustexist + ofn_hidereadonly + ofn_pathmustexist;
end;
if getopenfilename(ofn) then messagebox(0, ofn.lpstrfile, nil, mb_ok);
virtualfree(ofn.lpstrfile, 0, mem_release);
end;
Oto program, który nie będzie korzystał z vcl a będzie wukorzystywał wywołania funkcji z Windows API.
Aplikacje tego typu są potrzebne, gdy rozmiar pliku wykonywalnego jest krytyczny. Na przykład w instalatorze, deinstalatorze czy dla archiwów samorozpakowujących się.
W rzeczywistości jest to bardzo proste ...
W tym celu musimy:
1. Zarejestrować klasę okna dla okna formularza głównego.
function initapplication: boolean;
var wcx: twndclass;
begin
//wypełnienie struktury twndclass
// odświeżanie jeśli rozmiar zmienia się
wcx.style := cs_hredraw or cs_vredraw;
// adres procedury okna
wcx.lpfnwndproc := @mainwndproc;
wcx.cbclsextra := 0; wcx.cbwndextra := 0;
wcx.hinstance := hinstance; // uchwyt do instancji
wcx.hicon := loadicon(0, idi_application); //załaduj standardową ikonę
wcx.hcursor := loadcursor(0, idc_arrow); // wczytaj standardowy kursor
wcx.hbrbackground := color_window; // szare tło
wcx.lpszmenuname := nil; // nazwa klasy okna
wcx.lpszclassname := pchar(winname);
// rejestracja okna naszej klasy.
result := registerclass(wcx) < > 0;
end;
2. Napisz podprogram przetwarzania wiadomość okna.
function mainwndproc(window: hwnd; amessage, wparam, lparam: longint): longint; stdcall; export;
begin
//podprogram przetwarzania wiadomości
case amessage of
wm_destroy: begin
postquitmessage(0); exit; end;
else
result := defwindowproc(window, amessage, wparam, lparam);
end; end;
3. Utwórz główne okno aplikacji.
function initinstance: hwnd;
begin
// utwórz w oknie głównym.
result := createwindow( pchar(winname),// nazwa klasy okna
'small program', // nagłówek
ws_overlappedwindow, // styl okna standardowego
// pozycja w pionie i poziomie,szerokość i wysokość
integer(cw_usedefault), integer(cw_usedefault),
integer(cw_usedefault), integer(cw_usedefault),
0,//bez okna nadrzędnego
0,//bez menu
hinstance, //uchwyt do instancji aplikacji
nil); // okno nie dla tworzenia danych
end;
4. Tworzenie treści (ciała0 programu.
var hwndmain: hwnd; amessage: msg;
begin
if (not initapplication) then
begin
messagebox(0, 'nie mogę zarejestrować okna', nil, mb_ok); exit;
end;
hwndmain := initinstance; if (hwndmain = 0) then
begin
messagebox(0, 'Błąd podczas tworzenia okna', nil, mb_ok); exit;
end else begin
// wyświetl okno i wyślij wiadomość procedury okna wm_paint
showwindow(hwndmain, cmdshow); updatewindow(hwndmain);
end;
while (getmessage(amessage, 0, 0, 0)) do
begin
//początek pętli wiadomości
translatemessage(amessage); dispatchmessage(amessage);
end;
halt(amessage.wparam);
end.
5. Uruchom program:
Nasz program nie może zbyt wiele - pokazuje formatkę i po naciśnięciu przycisku zamyka go.... Ale spójrz na rozmiar pliku wykonywalnego - plik jest mniejszy więcej niż jeden rząd wielkości od takiego samego, stworzonego z wykorzystaniem VCL. Ponadto mając szkielet aplikacji możemy ją rozbudowywać dalej.
Oto pełny tekst programu. - program smallprg;
uses windows, messages;
const winname = 'mainwclass';
function mainwndproc(window: hwnd; amessage, wparam,lparam: longint): longint; stdcall; export;
begin
case amessage of //sub wiadomości
wm_destroy: begin
postquitmessage(0); exit;
end; else
result := defwindowproc(window, amessage, wparam, lparam);
end; end;
function initapplication: boolean;
var wcx: twndclass;
begin
//wypełnienie struktury twndclass
// odświeżanie jeśli rozmiar zmienia się
wcx.style := cs_hredraw or cs_vredraw; // adres procedury okna
wcx.lpfnwndproc := @mainwndproc;
wcx.cbclsextra := 0; wcx.cbwndextra := 0;
wcx.hinstance := hinstance; //uchwyt do instancji aplikacji
wcx.hicon := loadicon(0, idi_application); //załaduj standardową ikonę
wcx.hcursor := loadcursor(0, idc_arrow); // załaduj standardowy kursor
wcx.hbrbackground := color_window; //szare tło okna
wcx.lpszmenuname := nil; //brak głównego menu
wcx.lpszclassname := pchar(winname); // nazwa klasy okna
//rejestracja naszej klasy okna.
result := registerclass(wcx) < > 0;
end;
function initinstance: hwnd;
begin
// utwórz w oknie głównym.
result := createwindow(pchar(winname), // nazwa klasy okna
'small program', // nagłówek
ws_overlappedwindow, //okno typ standardowy
// pozycja w pionie, poziomie oraz szerokość i wysokość
integer(cw_usedefault), integer(cw_usedefault),
integer(cw_usedefault), integer(cw_usedefault),
0,//bez okna nadrzędnego
0,//bez menu
hinstance, //uchwyt do instancji aplikacji
nil); // okno nie dla tworzenia danych
end;
var hwndmain: hwnd; amessage: msg;
begin
if (not initapplication) then
begin
messagebox(0, 'nie mogę zarejestrować okna', nil, mb_ok); exit;
end;
hwndmain := initinstance; if (hwndmain = 0) then
begin
messagebox(0, 'Błąd podczas tworzenia okna', nil, mb_ok); exit;
end else begin
// wyświetl okno i wyślij wiadomość procedury okna wm_paint
showwindow(hwndmain, cmdshow); updatewindow(hwndmain);
end;
while (getmessage(amessage, 0, 0, 0)) do
begin
//początek pętli wiadomości
translatemessage(amessage); dispatchmessage(amessage);
end;
halt(amessage.wparam);
end.
Napęd CD może chociaż nie musi mieć numer seryjny i / lub uniwersalny kod produktu (Universal Product Code). MCI-rozszerzenie systemu Windows udostępnia te informacje z ppomocą polecenia MCI_INFO_MEDIA_IDENTITY. Polecenie to zwraca unikalny ID-string.
przykład:
uses MMSystem, MPlayer;
procedure TForm1.Button1Click(Sender: TObject);
var mp : TMediaPlayer; msp : TMCI_INFO_PARMS; MediaString : array[0..255] of char; ret : longint;
begin
mp := TMediaPlayer.Create(nil); mp.Visible := false; mp.Parent := Application.MainForm;
mp.Shareable := true; mp.DeviceType := dtCDAudio; mp.FileName := 'D:';
mp.Open;
Application.ProcessMessages; FillChar(MediaString, sizeof(MediaString), #0);
FillChar(msp, sizeof(msp), #0); msp.lpstrReturn := @MediaString;
msp.dwRetSize := 255;
ret := mciSendCommand(Mp.DeviceId, MCI_INFO, MCI_INFO_MEDIA_IDENTITY, longint(@msp));
if Ret < > 0 then
begin
MciGetErrorString(ret, @MediaString, sizeof(MediaString));
Memo1.Lines.Add(StrPas(MediaString));
end else
Memo1.Lines.Add(StrPas(MediaString)); mp.Close;
Application.ProcessMessages; mp.free;
end; end.
Plik DLL w Delphi podłączamy statycznie -aktywowana razem z plikiem EXE lub dynamicznie - przywoływana kiedy jest potrzebna. Poniżej przykład dynamicznego użycia pliku (biblioteki) DLL:
uses Windows, ...;
type TTimeRec = record
Second: Integer;
Minute: Integer;
Hour: Integer;
end;
TGetTime = procedure(var Time: TTimeRec);
THandle = Integer;
var Time: TTimeRec; Handle: THandle; GetTime: TGetTime;
...
begin
Handle := LoadLibrary('DATETIME.DLL');
if Handle < > 0 then
begin
@GetTime := GetProcAddress(Handle, 'GetTime');
if @GetTime < > nil then begin GetTime(Time);
with Time do
WriteLn('The time is ', Hour, ':', Minute, ':', Second); end;
FreeLibrary(Handle); end;
end;
procedure TForm1.Button1Click(Sender: TObject);
VAR Wnd : hWnd; buff: ARRAY [0..127] OF Char;
begin
ListBox1.Clear;
Wnd := GetWindow(Handle, gw_HWndFirst);
WHILE Wnd < > 0 DO BEGIN {w osobnym oknie}
IF (Wnd < > Application.Handle) AND {niewidzialne okna}
IsWindowVisible(Wnd) AND {okna główne}
(GetWindow(Wnd, gw_Owner) = 0) AND {okna dziecka Child}
(GetWindowText(Wnd, buff, sizeof(buff)) < > 0){okna bez opisów}
THEN BEGIN
GetWindowText(Wnd, buff, sizeof(buff));
ListBox1.Items.Add(StrPas(buff));
END;
Wnd := GetWindow(Wnd, gw_hWndNext);
END;
ListBox1.ItemIndex := 0;
end;
Poniższy przykład zmienia priorytet aplikacji. Zmiana priorytetów powinna być stosowane z dużą ostrożnością - ponieważ przypisywanie zbyt wysokiego priorytetu może spowolnić pracę innych programów i systemów w ogóle. Zobacz help Win32 i jego funkcji SetThreadPriority ().
przykład:
procedure TForm1.Button1Click(Sender: TObject);
var ProcessID : DWORD; ProcessHandle : THandle; ThreadHandle : THandle;
begin
ProcessID := GetCurrentProcessID;
ProcessHandle := OpenProcess(PROCESS_SET_INFORMATION, false, ProcessID);
SetPriorityClass(ProcessHandle, REALTIME_PRIORITY_CLASS);
ThreadHandle := GetCurrentThread;
SetThreadPriority(ThreadHandle, THREAD_PRIORITY_TIME_CRITICAL);
end;
To niemożliwe. Skasować go można przy następnym uruchomieniu Windows przez dodanie klucza RunOnce:
HKEY_LOCAL_MACHINE \ Software \ Microsoft \ Windows \ CurrentVersion \ RunOnce
przykład:
uses Registry;
procedure TForm1.Button1Click(Sender: TObject);
var reg: TRegistry;
begin
reg := TRegistry.Create; with reg do begin
RootKey := HKEY_LOCAL_MACHINE; LazyWrite := false;
OpenKey('Software\Microsoft\Windows\CurrentVersion\RunOnce', false);
WriteString('Delete Me!','command.com /c del FILENAME.EXT'); CloseKey;
free; end;
end;
uses Registry, {For Win32} IniFiles; {For Win16}
{$IFNDEF WIN32} const MAX_PATH = 144; {$ENDIF}
{For Win32}
procedure TForm1.Button1Click(Sender: TObject);
var reg: TRegistry;
begin
reg := TRegistry.Create; reg.RootKey := HKEY_LOCAL_MACHINE; reg.LazyWrite := false;
reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Run', false);
reg.WriteString('My App', Application.ExeName); reg.CloseKey; reg.free;
end;
{For Win16}
procedure TForm1.Button2Click(Sender: TObject);
var WinIni : TIniFile; WinIniFileName : array[0..MAX_PATH] of char; s : string;
begin
GetWindowsDirectory(WinIniFileName, sizeof(WinIniFileName));
StrCat(WinIniFileName, '\win.ini'); WinIni := TIniFile.Create(WinIniFileName);
s := WinIni.ReadString('windows', 'run', '');
if s = '' then s := Application.ExeName else s := s + ';' + Application.ExeName;
WinIni.WriteString('windows', 'run', s);
WinIni.Free;
end;
TMainForm = class(TForm)
...
private
procedure WMDROPFILES(var Message: TWMDROPFILES); message WM_DROPFILES;
procedure ProcessFile(Filename: string);
end;
procedure TMainForm.FormCreate(Sender: TObject);
begin
DragAcceptFiles(MainForm.Handle, TRUE); //umożliwia przeciągnij i upuść
end;
procedure TMainForm.ProcessFile(Filename: string);
begin
// dowolna akcja - any actions
end;
procedure TMainForm.WMDROPFILES(var Message: TWMDROPFILES);
var Files : Longint; I : Longint; Buffer : array[0..MAX_PATH] of Char;
begin
Files := DragQueryFile(Message.Drop,$FFFFFFFF,nil,0); // zwraca liczbę plików
for I := 0 to Files - 1 do begin
DragQueryFile(Message.Drop,I,@Buffer,SizeOf(Buffer)); // pobierz plik N
ProcessFile(Buffer); // można coś zrobic z plikiem
end;
DragFinish(Message.Drop); // koniec przeciągania i upuszczania
end;
Ten przykład demonstruje użycie funkcji API mouse_event () do symulacji zdarzeń myszy. Po kliknięciu na Button2 program przesuwa kursor myszy na Button1 i klika na niego. Położenie kursora myszy ustawia się na "bezwzględne" współrzędne ("Mickeys"), gdzie 65 535 "Mickeys" jest równe szerokości ekranu.
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage('Button 1 kliknięty');
end;
procedure TForm1.Button2Click(Sender: TObject);
var Pt : TPoint;
begin
Application.ProcessMessages; {z Button2 wysyłamy wiadomość}
Pt.x := Button1.Left + (Button1.Width div 2); {znajdz współrzędne srodka button1}
Pt.y := Button1.Top + (Button1.Height div 2);
Pt := ClientToScreen(Pt); {zmiana Pt w koordynaty ekranu}
{konwersja Pt do "mickeys" (absolutne położenie myszy}
Pt.x := Round(Pt.x * (65535 / Screen.Width)); Pt.y := Round(Pt.y * (65535 / Screen.Height));
{przenoszenie kursora myszy}
Mouse_Event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_MOVE, Pt.x, Pt.y, 0, 0);
{symulacja wciśnięcia lewego klawisza myszy}
Mouse_Event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_LEFTDOWN, Pt.x, Pt.y, 0, 0);
{symulacja zwolnienia lewego klawisza myszy}
Mouse_Event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_LEFTUP, Pt.x, Pt.y, 0, 0);
end;
procedure SetNumLock(bState:Boolean);
var KeyState : TKeyboardState;
begin
GetKeyboardState(KeyState);
if ( (bState) and (not ((KeyState[VK_NUMLOCK] and 1)=1) ) or
( (not (bState)) and ((KeyState[VK_NUMLOCK] and 1)=1))) then
// symulacja wciśnięcia klawisza
keybd_event(VK_NUMLOCK, $45, (KEYEVENTF_EXTENDEDKEY or 0), 0);
// symulacja zwolnienia klawisza
keybd_event( VK_NUMLOCK, $45, (KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP), 0);
end;
zmien klawisz VK_NUMLOCK na inny, dowolny.
Przykład:
type TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
protected
procedure hotykey(var msg:TMessage); message WM_HOTKEY;
end;
var Form1: TForm1; id,id2:Integer;
implementation
{$R *.DFM}
procedure TForm1.hotykey(var msg:TMessage);
begin
if (msg.LParamLo=MOD_CONTROL) and (msg.LParamHi=81) then
begin
ShowMessage('Ctrl + Q teraz wcisnięty !');
end;
if (msg.LParamLo=MOD_CONTROL) and (msg.LParamHi=82) then
begin
ShowMessage('Ctrl + R teraz wcisnięty !');
end; end;
procedure TForm1.FormCreate(Sender: TObject);
begin
id:=GlobalAddAtom('hotkey'); RegisterHotKey(handle,id,mod_control,81);
id2:=GlobalAddAtom('hotkey2'); RegisterHotKey(handle,id2,mod_control,82);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
UnRegisterHotKey(handle,id); UnRegisterHotKey(handle,id2);
end;
type TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private { Private declarations }
procedure WMHotKey(var Msg : TWMHotKey); message WM_HOTKEY;
public { Public declarations }
end;
var Form1: TForm1;
implementation
{$R *.DFM}
const id_SnapShot = 101;
procedure TForm1.WMHotKey (var Msg : TWMHotKey);
begin
if Msg.HotKey = id_SnapShot then ShowMessage('PrintScreen wciśnięty');
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
RegisterHotKey(Form1.Handle, id_SnapShot, 0, VK_SNAPSHOT);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
UnRegisterHotKey (Form1.Handle, id_SnapShot);
end;
Jeżeli chcesz wiedzieć kiedy np. klawisz Ctrl jest wciśnięty wykorzystaj funkcje:
GetKeyState, GetAsyncKeyState, GetKeyboardState.
Przykłady;
function AltKeyDown : boolean;
begin
result:=(Word(GetKeyState(VK_MENU)) and $8000)< >0;
end;
function CtrlKeyDown : boolean;
begin
result:=(Word(GetKeyState(VK_CONTROL)) and $8000)< >0;
end;
function ShiftKeyDown : boolean;
begin
result:=(Word(GetKeyState(VK_SHIFT)) and $8000)< >0;
end;
function CapsLock : boolean;
begin
result:=(GetKeyState(VK_CAPITAL) and 1)< >0;
end;
function InsertOn : boolean;
begin
result:=(GetKeyState(VK_INSERT) and 1)< >0;
end;
function NumLock : boolean;
begin
result:=(GetKeyState(VK_NUMLOCK) and 1)< >0;
end;
function ScrollLock : boolean;
begin
result:=(GetKeyState(VK_SCROLL) and 1)< >0;
end;
function TaskBarAddIcon( hWindow : THandle; ID : Cardinal; ICON : hicon;
CallbackMessage : Cardinal; Tip : String ) : Boolean;
var NID : TNotifyIconData;
begin
FillChar( NID, SizeOf( TNotifyIconData ), 0 );
with NID do begin
cbSize := SizeOf( TNotifyIconData ); Wnd := hWindow; uID := ID;
uFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP;
uCallbackMessage := CallbackMessage; hIcon := Icon;
if Length( Tip )> 63 then SetLength( Tip, 63 ); StrPCopy( szTip, Tip );
end;
Result := Shell_NotifyIcon( NIM_ADD, @NID );
end;
Czasami systemowe pop-up menu nie znika kiedy przestaje być aktywne. Aby go zamknąć trzeba wysłąć wiadomość WM_NULL .
procedure TForm1.WndProc(var Msg : TMessage);
var p : TPoint;
begin
case Msg.Msg of WM_USER + 1:
case Msg.lParam of WM_RBUTTONDOWN: begin
SetForegroundWindow(Handle); GetCursorPos(p);
PopupMenu1.Popup(p.x, p.y); PostMessage(Handle, WM_NULL, 0, 0);
end; end; end;
inherited;
end;
//ukrycie
procedure TForm1.Button1Click(Sender: TObject);
Var hTaskBar : THandle;
begin
hTaskbar := FindWindow('Shell_TrayWnd', Nil); ShowWindow(hTaskBar, SW_HIDE);
end;
//pokazanie
procedure TForm1.Button2Click(Sender: TObject);
Var hTaskBar : THandle;
begin
hTaskbar := FindWindow('Shell_TrayWnd', Nil); ShowWindow(hTaskBar, SW_SHOWNORMAL);
end;
uses CommCtrl;
var i, k:Integer; XYold, XY : Array[1..100] of TPoint; CurPos:TPoint;
Najpierw pobierz uchwyt DeskTop'a:
function GetHandle: THandle;
var S: String;
begin
Result := FindWindow('ProgMan', nil); Result := GetWindow(Result, GW_CHILD);
Result := GetWindow(Result, GW_CHILD); SetLength(S, 40);
GetClassName(Result, PChar(S), 39); if PChar(S) < > 'SysListView32' then Result := 0;
end;
Policz ikony na pulpicie:...
i:=SendMessage(GetHandle,LVM_GETITEMCOUNT,0,0);
...
Uzyskiwanie współrzędnych ikon na pulpicie. Jak się okazuje, jest to najtrudniejsza część.
Jeśli spojrzeć na CommCtrl.pas GETITEMPOSITION kod, a następnie powtórzyć je w Delphi z jakiegoś powodu nie działa. Oznacza to, że to działa, ale nie jest jasne, w jaki sposób.
Więc to zrobić tak:
function GetXY(hwndLV: HWND; i: Integer; var ppt: TPoint): Bool;
var PointBuf : ^TPoint;
begin
try
PointBuf := VirtualAlloc(NIL,Sizeof(TPoint), $8000000 or MEM_COMMIT, PAGE_READWRITE);
Result := Bool( SendMessage(hWndLV, LVM_GETITEMPOSITION, i, Longint(PointBuf)));
if Result then begin
ppt.x := PointBuf^.x; ppt.y := PointBuf^.y; end;
finally VirtualFree(PointBuf,0,MEM_RELEASE);
end; end;
...
Zapisz współrzędne ikony w XYold:
for k:=1 to i do GetXY(GetHandle,k-1,XYold[k]);
Ikona z indeksem =0 to zawsze Mój komputer, pozostali ....
...
A oto jak z pomocą Timera przenosić ikony tam i z powrotem jeżeli przesunąć na nie kursor:
procedure TForm1.Timer1Timer(Sender: TObject);
var k:Integer;
begin
GetCursorPos(CurPos);
for k:=1 to i do begin
GetXY(GetHandle,k-1,XY[k]);
if (CurPos.x > XY[k].x+4) and (CurPos.xand (CurPos.y > XY[k].y+4) and (CurPos.y then
begin
SendMessage(GetHandle,LVM_SETITEMPOSITION,k-1,MakeLong(XY[k].x+Random(64)-Random(64),
XY[k].y+Random(64)-Random(64)));
end; end;
end;
...
Wreszcie pozostawiamy wszystkie ikony na poprzednim miejscu przed zakończeniem programu:
procedure TForm1.FormDestroy(Sender: TObject);
var k:Integer;
begin
for k:=1 to i do
SendMessage(GetHandle,LVM_SETITEMPOSITION,k-1,MakeLong(XYold[k].x,XYold[k].y));
end;
// Pokaże nazwy dostępnych portów comm (COM1, COM2, ...)
// Użyty klucz rejestru: HKEY_LOCAL_MACHINE \ hardware \ DeviceMap \ serialcomm
uses registry;
...
procedure TForm1.Button1Click(Sender: TObject);
var reg : TRegistry; st : TStrings; i : integer;
begin
reg := TRegistry.Create; reg.RootKey := HKEY_LOCAL_MACHINE;
reg.OpenKey('hardware\devicemap\serialcomm',false);
st := TStringList.Create; reg.GetValueNames(st);
for i := 0 to st.Count -1 do begin
Memo1.Lines.Add(reg.ReadString(st.Strings[i])); end;
st.Free; reg.CloseKey; reg.free;
end;
Możesz użyć Windows API SetErrorMode (), aby wyłączyć okno dialogowe krytycznych błędów.
function IsDriveReady(DriveLetter : char) : bool;
var OldErrorMode : Word; OldDirectory : string;
begin
OldErrorMode := SetErrorMode(SEM_NOOPENFILEERRORBOX);
GetDir(0, OldDirectory); {$I-} ChDir(DriveLetter + ':\'); {$I+}
if IoResult < > 0 then Result := False
else Result := True;
ChDir(OldDirectory); SetErrorMode(OldErrorMode);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if not IsDriveReady('A') then
ShowMessage('Dysk nie jest gotowy') else
ShowMessage('Dysk jest gotowy');
end;
Poprzez wywołanie funkcji GetDiskFreeSpaceEx(). Zwracana liczba typu integer jest od razu konwertowana do Double.
przykład:
function GetDiskFreeSpaceEx(lpDirectoryName: PAnsiChar;
var lpFreeBytesAvailableToCaller : Integer; var lpTotalNumberOfBytes: Integer;
var lpTotalNumberOfFreeBytes: Integer) : bool; stdcall;
external kernel32 name 'GetDiskFreeSpaceExA';
procedure GetDiskSizeAvail(TheDrive : PChar; var TotalBytes : double; var TotalFree : double);
var AvailToCall : integer; TheSize : integer; FreeAvail : integer;
begin
GetDiskFreeSpaceEx(TheDrive, AvailToCall, TheSize, FreeAvail);
{$IFOPT Q+} {$DEFINE TURNOVERFLOWON} {$Q-} {$ENDIF}
if TheSize > = 0 then
TotalBytes := TheSize else if TheSize = -1 then begin
TotalBytes := $7FFFFFFF; TotalBytes := TotalBytes * 2; TotalBytes := TotalBytes + 1;
end else begin
TotalBytes := $7FFFFFFF; TotalBytes := TotalBytes + abs($7FFFFFFF - TheSize);
end;
if AvailToCall > = 0 then TotalFree := AvailToCall else
if AvailToCall = -1 then begin
TotalFree := $7FFFFFFF; TotalFree := TotalFree * 2; TotalFree := TotalFree + 1;
end else begin
TotalFree := $7FFFFFFF; TotalFree := TotalFree + abs($7FFFFFFF - AvailToCall);
end; end;
procedure TForm1.Button1Click(Sender: TObject);
var TotalBytes : double; TotalFree : double;
begin
GetDiskSizeAvail('C:\', TotalBytes, TotalFree);
ShowMessage(FloatToStr(TotalBytes)); ShowMessage(FloatToStr(TotalFree));
end;
Użyj funkcji Win32_Find_Data w TSearchRec.
przykład:
procedure TForm1.Button1Click(Sender: TObject);
var SearchRec : TSearchRec; Success : integer;
begin
Success := SysUtils.FindFirst('C:\DownLoad\dial-u~1.htm', faAnyFile, SearchRec);
if Success = 0 then begin
ShowMessage(SearchRec.FindData.CFileName);
end; SysUtils.FindClose(SearchRec);
end;
przykład od Andrey Klimov:
function ShortToLongPath(const ShortName: string): string;
var LastSlash: PChar; TempPathPtr: PChar; strTmp: string;
begin
Result := ''; TempPathPtr := PChar(ShortName);
LastSlash := StrRScan(TempPathPtr, '\');
while LastSlash < > nil do begin
strTmp := ShortToLongFileName(TempPathPtr);
if strTmp < > '' then begin
Result := '\' + strTmp + Result; if LastSlash < > nil then begin
LastSlash^ := char(0); LastSlash := StrRScan(TempPathPtr, '\');
end; end else
LastSlash := nil; end; Result := TempPathPtr + Result;
end;
do tego wykorzystaj funkcję Windows API GetDriveType ().
przykład:
procedure TForm1.Button1Click(Sender: TObject);
begin
case GetDriveType('C:\') of
0 : ShowMessage('The drive type cannot be determined');
1 : ShowMessage('The root directory does not exist');
DRIVE_REMOVABLE:ShowMessage('The disk can be removed');
DRIVE_FIXED : ShowMessage('The disk cannot be removed');
DRIVE_REMOTE : ShowMessage('The drive is remote (network) drive');
DRIVE_CDROM : ShowMessage('The drive is a CD-ROM drive');
DRIVE_RAMDISK : ShowMessage('The drive is a RAM disk');
end;
end;
unit TestRosh;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls;
type TForm1 = class(TForm)
Panel1: TPanel;
Label1: TLabel;
PortCombo: TComboBox;
Label2: TLabel;
BaudCombo: TComboBox;
Label3: TLabel;
ByteSizeCombo: TComboBox;
Label4: TLabel;
ParityCombo: TComboBox;
Label5: TLabel;
StopBitsCombo: TComboBox;
Label6: TLabel;
Memo1: TMemo;
Edit1: TEdit;
Button1: TButton;
Memo2: TMemo;
Edit2: TEdit;
Label7: TLabel;
Button2: TButton;
Label8: TLabel;
Edit3: TEdit;
procedure Button1Click(Sender: TObject);
procedure Memo2Change(Sender: TObject);
procedure Memo1Change(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure PortComboChange(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure Memo1DblClick(Sender: TObject);
end;
var Form1: TForm1;
implementation
{$R *.DFM}
uses Registry;
var hPort: THandle;
procedure TForm1.Memo1Change(Sender: TObject);
var i: Integer;
begin
Edit1.Text := ''; for i := 1 to Length(Memo1.Text) do
Edit1.Text := Edit1.Text + Format('%x', [Ord(Memo1.Text[i])]) + ' '
end;
procedure TForm1.Memo2Change(Sender: TObject);
var i: Integer;
begin
Edit2.Text := ''; for i := 1 to Length(Memo2.Text) do
Edit2.Text := Edit2.Text + Format('%x', [Ord(Memo2.Text[i])]) + ' '
end;
procedure TForm1.Button1Click(Sender: TObject);
var S, D: array[0..127] of Char; actual_bytes: Integer; DCB: TDCB;
begin
FillChar(S, 128, #0); FillChar(D, 128, #0);
DCB.DCBlength := SizeOf(DCB);
if not GetCommState(hPort, DCB) then begin
ShowMessage('Can''t get port state: ' + IntToStr(GetLastError)); Exit;
end;
try
DCB.BaudRate := StrToInt(BaudCombo.Text);
except BaudCombo.Text := IntToStr(DCB.BaudRate);
end;
try DCB.ByteSize := StrToInt(ByteSizeCombo.Text);
except ByteSizeCombo.Text := IntToStr(DCB.ByteSize);
end;
if ParityCombo.ItemIndex > -1 then DCB.Parity := ParityCombo.ItemIndex
else ParityCombo.ItemIndex := DCB.Parity;
if StopBitsCombo.ItemIndex > -1 then DCB.StopBits := StopBitsCombo.ItemIndex
else StopBitsCombo.ItemIndex := DCB.StopBits;
if not SetCommState(hPort, DCB) then begin
ShowMessage('Can''t set new port settings: ' + IntToStr(GetLastError)); Exit;
end;
PurgeComm(hPort, PURGE_TXABORT or PURGE_RXABORT or PURGE_TXCLEAR or PURGE_RXCLEAR);
StrPCopy(S, Memo1.Text);
if not WriteFile(hPort, S, StrLen(S), actual_bytes, nil) then begin
ShowMessage('Can''t write to port: ' + IntToStr(GetLastError)); Exit;
end;
if not ReadFile(hPort, D, StrToInt(Edit3.Text), actual_bytes, nil) then
ShowMessage('Can''t read from port: ' + IntToStr(GetLastError))
else ShowMessage('Read ' + IntToStr(actual_bytes) + ' bytes'); Memo2.Text := D;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
with TRegistry.Create do begin
OpenKey('\Software\MBEM\Rosh Shkila', True);
WriteString('Port', PortCombo.Text); WriteString('Baud Rate', BaudCombo.Text);
WriteString('Byte Size', ByteSizeCombo.Text);
WriteString('Parity', IntToStr(ParityCombo.ItemIndex));
WriteString('Stop Bits', IntToStr(StopBitsCombo.ItemIndex)); Destroy;
end;
if not CloseHandle(hPort) then begin
ShowMessage('Can''t close port: ' + IntToStr(GetLastError)); Exit;
end; end;
procedure TForm1.Button2Click(Sender: TObject);
begin
hPort := CreateFile(PChar(PortCombo.Text), GENERIC_READ + GENERIC_WRITE,
0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
if hPort = INVALID_HANDLE_VALUE then
ShowMessage('Can''t open ' + PortCombo.Text + ': ' + IntToStr(GetLastError))
else Button2.Hide;
end;
procedure TForm1.PortComboChange(Sender: TObject);
begin
FormDestroy(Sender); Button2.Show;
end;
procedure TForm1.FormShow(Sender: TObject);
begin
with TRegistry.Create do begin
OpenKey('\Software\MBEM\Rosh Shkila', True);
PortCombo.Text := ReadString('Port'); BaudCombo.Text := ReadString('Baud Rate');
ByteSizeCombo.Text := ReadString('Byte Size');
ParityCombo.ItemIndex := StrToInt(ReadString('Parity'));
StopBitsCombo.ItemIndex := StrToInt(ReadString('Stop Bits')); Destroy;
end; end;
procedure TForm1.Memo1DblClick(Sender: TObject);
begin
Memo1.Lines.Clear; Memo2.Lines.Clear;
Edit1.Text := ''; Edit2.Text := '';
end;
end.
Przykład wysłania tekstu do drukarki za pomocą portu com
Var Printer: THandle; N : Cardinal; C : POverlapped;
begin //otwieramy port drukarki do zapisu
Printer := CreateFile(PChar('LPT1'), GENERIC_READ or GENERIC_WRITE,0,nil,
OPEN_EXISTING,FILE_FLAG_OVERLAPPED,0);
WriteFile(Printer,'Hello World',11,N,c); //drukuje słowo 'Hello World';
CloseHandle(Printer);//zamyka port
uses ShellAPI, ShlObj;
procedure TForm1.Button1Click(Sender: TObject);
var TitleName : string; lpItemID : PItemIDList; BrowseInfo : TBrowseInfo;
DisplayName : array[0..MAX_PATH] of char; TempPath : array[0..MAX_PATH] of char;
begin
FillChar(BrowseInfo, sizeof(TBrowseInfo), #0); BrowseInfo.hwndOwner := Form1.Handle;
BrowseInfo.pszDisplayName := @DisplayName;
TitleName := 'Please specify a directory'; BrowseInfo.lpszTitle := PChar(TitleName);
BrowseInfo.ulFlags := BIF_RETURNONLYFSDIRS;
lpItemID := SHBrowseForFolder(BrowseInfo);
if lpItemId < > nil then begin
SHGetPathFromIDList(lpItemID, TempPath); ShowMessage(TempPath);
GlobalFreePtr(lpItemID);
end; end;
wariant według SAVwa@eleks.lviv.ua
threadvar myDir: string;
function BrowseCallbackProc(hwnd: HWND; uMsg: UINT; lParam: LPARAM; lpData: LPARAM): integer; stdcall;
begin
Result := 0; if uMsg = BFFM_INITIALIZED then begin
SendMessage(hwnd, BFFM_SETSELECTION, 1, LongInt(PChar(myDir)))
end; end;
function SelectDirectory(const Caption: string; const Root: WideString; var Directory: string): Boolean;
var WindowList: Pointer; BrowseInfo: TBrowseInfo; Buffer: PChar;
RootItemIDList, ItemIDList: PItemIDList; ShellMalloc: IMalloc;
IDesktopFolder: IShellFolder; Eaten, Flags: LongWord;
begin
myDir := Directory; Result := False;
FillChar(BrowseInfo, SizeOf(BrowseInfo), 0);
if (ShGetMalloc(ShellMalloc) = S_OK) and (ShellMalloc < > nil) then
begin
Buffer := ShellMalloc.Alloc(MAX_PATH);
try
RootItemIDList := nil; if Root < > '' then
begin
SHGetDesktopFolder(IDesktopFolder);
IDesktopFolder.ParseDisplayName(Application.Handle, nil,
POleStr(Root), Eaten, RootItemIDList, Flags);
end;
with BrowseInfo do
begin
hwndOwner := Application.Handle; pidlRoot := RootItemIDList;
pszDisplayName := Buffer; lpfn := @BrowseCallbackProc;
lParam := Integer(PChar(Directory)); lpszTitle := PChar(Caption);
ulFlags := BIF_RETURNONLYFSDIRS or $0040 or BIF_EDITBOX or BIF_STATUSTEXT ;
end;
WindowList := DisableTaskWindows(0);
try
ItemIDList := ShBrowseForFolder(BrowseInfo);
finally EnableTaskWindows(WindowList); end;
Result := ItemIDList < > nil; if Result then
begin
ShGetPathFromIDList(ItemIDList, Buffer); ShellMalloc.Free(ItemIDList);
Directory := Buffer; end;
finally ShellMalloc.Free(Buffer);
end; end;
end;
Uwaga: nie wszystkie pliki systemowe dają się tak odczytać.
przykład:
procedure TForm1.Button1Click(Sender: TObject);
var SearchRec : TSearchRec; Success : integer; DT : TFileTime; ST : TSystemTime;
begin
Success := SysUtils.FindFirst('C:\autoexec.bat', faAnyFile, SearchRec);
if (Success = 0) and
(( SearchRec.FindData.ftLastAccessTime.dwLowDateTime < > 0)
or ( SearchRec.FindData.ftLastAccessTime.dwHighDateTime < > 0))
then begin
FileTimeToLocalFileTime(SearchRec.FindData.ftLastAccessTime,DT);
FileTimeToSystemTime(DT,ST);
Memo1.Lines.Clear;
Memo1.Lines.Add('AutoExec.Bat was last accessed at:');
Memo1.Lines.Add('Year := ' + IntToStr(st.wYear));
Memo1.Lines.Add('Month := ' + IntToStr(st.wMonth));
Memo1.Lines.Add('DayOfWeek := ' + IntToStr(st.wDayOfWeek));
Memo1.Lines.Add('Day := ' + IntToStr(st.wDay));
Memo1.Lines.Add('Hour := ' + IntToStr(st.wHour));
Memo1.Lines.Add('Minute := ' + IntToStr(st.wMinute));
Memo1.Lines.Add('Second := ' + IntToStr(st.wSecond));
Memo1.Lines.Add('Milliseconds := ' + IntToStr(st.wMilliseconds));
end;
SysUtils.FindClose(SearchRec);
end;
function GetFileDate(FileName: string): string;
var FHandle: Integer;
begin
FHandle := FileOpen(FileName, 0);
try
Result := DateTimeToStr(FileDateToDateTime(FileGetDate(FHandle)));
finally FileClose(FHandle);
end; end;
uses ShlObj, ComObj, ActiveX;
procedure CreateLink(const PathObj, PathLink, Desc, Param: string);
var IObject: IUnknown; SLink: IShellLink; PFile: IPersistFile;
begin
IObject := CreateComObject(CLSID_ShellLink);
SLink := IObject as IShellLink; PFile := IObject as IPersistFile;
with SLink do begin
SetArguments(PChar(Param)); SetDescription(PChar(Desc));
SetPath(PChar(PathObj));
end;
PFile.Save(PWChar(WideString(PathLink)), FALSE);
end;
Aby to zrobić musisz wywołać kilka funkcji API. W poniższym przykładzie wykorzystano do odczytu shell32.dll. Funkcja zwraca True - jeśli to wersja DLL większa lub równa 4,71
function TForm1.CheckShell32Version: Boolean;
procedure GetFileVersion(FileName: string; var Major1, Major2, Minor1, Minor2: Integer);
{funkcja pomocnicza aby pobrać aktualne informacje o wersji pliku }
var Info: Pointer; InfoSize: DWORD; FileInfo: PVSFixedFileInfo;
FileInfoSize: DWORD; Tmp: DWORD;
begin
// odczyt rozmiaru tego pliku
InfoSize := GetFileVersionInfoSize(PChar(FileName), Tmp);
// jeśli InfoSize = 0 to plik ten może nie istnieć lub nie ma ifo o wersji pliku.
if InfoSize = 0 then
raise Exception.Create('Nie mogę uzyskać informacji o wersji pliku ' + FileName);
GetMem(Info, InfoSize);// Allokacja pamięci dla info o wersji pliku
try
GetFileVersionInfo(PChar(FileName), 0, InfoSize, Info); // pobranie informacji
VerQueryValue(Info, '\', Pointer(FileInfo), FileInfoSize); // Kwerenda informacji o wersji
Major1 := FileInfo.dwFileVersionMS shr 16; // teraz wypełnij informacje o wersji
Major2 := FileInfo.dwFileVersionMS and $FFFF;
Minor1 := FileInfo.dwFileVersionLS shr 16;
Minor2 := FileInfo.dwFileVersionLS and $FFFF;
finally
FreeMem(Info, FileInfoSize);
end; end;
var tmpBuffer: PChar; Shell32Path: string; VersionMajor: Integer;
VersionMinor: Integer; Blank: Integer;
begin
tmpBuffer := AllocMem(MAX_PATH);// pobierz ścieżkę doshell32.dll
try
GetSystemDirectory(tmpBuffer, MAX_PATH); Shell32Path := tmpBuffer + '\shell32.dll';
finally FreeMem(tmpBuffer);
end;
if FileExists(Shell32Path) then // sprawdź czy istnieje
begin // pobierz wersję pliku
GetFileVersion(Shell32Path, VersionMajor, VersionMinor, Blank, Blank);
if (VersionMajor >= 4) and (VersionMinor >= 71) then //szukaj jak większa niż 4.71
Result := True else Result := False;
end else
Result := False;
end;
uses Registry;
procedure TForm1.Button1Click(Sender: TObject);
var reg : TRegistry; ts : TStrings; i : integer;
begin
reg := TRegistry.Create; reg.RootKey := HKEY_LOCAL_MACHINE;
reg.OpenKey( 'SOFTWARE\Microsoft\Windows\CurrentVersion\Time Zones', false);
if reg.HasSubKeys then begin
ts := TStringList.Create; reg.GetKeyNames(ts); reg.CloseKey;
for i := 0 to ts.Count -1 do begin
reg.OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion\Time Zones\' + ts.Strings[i], false);
Memo1.Lines.Add(ts.Strings[i]); Memo1.Lines.Add(reg.ReadString('Display'));
Memo1.Lines.Add(reg.ReadString('Std')); Memo1.Lines.Add(reg.ReadString('Dlt'));
Memo1.Lines.Add('----------------------');
reg.CloseKey;
end; ts.Free; end else
reg.CloseKey; reg.free;
end;
var FolderPath :string;
Registry := TRegistry.Create;
try
Registry.RootKey := HKey_Current_User;
Registry.OpenKey('Software\Microsoft\Windows\'+ 'CurrentVersion\Explorer\Shell Folders', False);
FolderName := Registry.ReadString('StartUp');
{takimi folderami mogą byC: Cache, Cookies, Desktop, Favorites, Fonts, Personal, Programs, SendTo, Start Menu, StarUp}
finally Registry.Free;
end;
uses ShellAPI;
function DeleteFileWithUndo( sFileName : string ) : boolean;
var fos : TSHFileOpStruct;
begin
sFileName:= sFileName+#0; 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;
sProgTitle: Nazwa programu
sCmdLine: nazwa pliku EXE ze ścieżką dostępu
bRunOnce: Uruchamiaj zawsze przy starcie Windows lub tylko raz (true/false)
procedure RunOnStartup(sProgTitle, sCmdLine : string; bRunOnce : boolean );
var sKey : string; reg : TRegIniFile;
begin
if( bRunOnce )then sKey := 'Once'
else
sKey := ''; reg := TRegIniFile.Create( '' );
reg.RootKey := HKEY_LOCAL_MACHINE;
reg.WriteString( 'Software\Microsoft' + '\Windows\CurrentVersion\Run'
+ sKey + #0, sProgTitle, sCmdLine );
reg.Free;
end;
//przykład użycia:
RunOnStartup('To jest mój program','MyProg.exe',False );
//wersja idealna dla programu deinstalacyjnego
function DeleteDir(Dir : string) : boolean;
Var Found : integer; SearchRec : TSearchRec;
begin
result:=false; if IOResult< >0 then ChDir(Dir);
if IOResult< >0 then begin
ShowMessage('Nie mogę otworzyć katalogu: '+Dir); exit;
end;
Found := FindFirst('*.*', faAnyFile, SearchRec);
while Found = 0 do
begin
if (SearchRec.Name< >'.')and(SearchRec.Name< >'..') then
if (SearchRec.Attr and faDirectory)< >0 then begin
if not DeleteDir(SearchRec.Name) then exit;
end else
if not DeleteFile(SearchRec.Name) then begin
ShowMessage('Nie mogę usunąć katalogu: '+SearchRec.Name); exit;
end;
Found := FindNext(SearchRec);
end;
FindClose(SearchRec); ChDir('..'); RmDir(Dir); result:=IOResult=0;
end;
uses ShellApi;
procedure TForm1.Button1Click(Sender: TObject);
var OpStruc: TSHFileOpStruct; frombuf, tobuf: Array [0..128] of Char;
Begin
FillChar( frombuf, Sizeof(frombuf), 0 ); FillChar( tobuf, Sizeof(tobuf), 0 );
StrPCopy( frombuf, 'h:\hook\*.*' ); StrPCopy( tobuf, 'd:\temp\brief' );
With OpStruc DO Begin
Wnd:= Handle; wFunc:= FO_COPY; pFrom:= @frombuf; pTo:=@tobuf;
fFlags:= FOF_NOCONFIRMATION or FOF_RENAMEONCOLLISION;
fAnyOperationsAborted:= False; hNameMappings:= Nil; lpszProgressTitle:= Nil;
end;
ShFileOperation( OpStruc );
end;
procedure TForm1.Button1Click(Sender: TObject);
var VolumeName, FileSystemName : array [0..MAX_PATH-1] of Char;
VolumeSerialNo : DWord; MaxComponentLength, FileSystemFlags : DWORD;
begin
GetVolumeInformation('C:\',VolumeName,MAX_PATH,@VolumeSerialNo,
MaxComponentLength,FileSystemFlags, FileSystemName,MAX_PATH);
Memo1.Lines.Add('VName = '+VolumeName);
Memo1.Lines.Add('SerialNo = $'+IntToHex(VolumeSerialNo,8));
Memo1.Lines.Add('CompLen = '+IntToStr(MaxComponentLength));
Memo1.Lines.Add('Flags = $'+IntToHex(FileSystemFlags,4));
Memo1.Lines.Add('FSName = '+FileSystemName);
end;