کدهای مفید و جالب به زبان دلفی

در این پست قصد داریم چند نمونه کد مفید و جالب به زبان دلفی (Delphi) خدمت شما ارائه نماییم. کدهای دلفی بصورت تابع تعریف شده اند و در بعضی از آنها مثالی نیز در انتها آورده شده است. سورس های زبان دلفی بصورت مثال عبارت اند از:

– آیا فایل در حال استفاده است؟

– پیدا کردن پسورد دایل آپ

– شبیه سازی فشردن کلید

– ارسال Message با تابع SendMessage

– جلوگیری از عدم نمایش پیام های ارور در ویندوز

– گرفتن اطلاعات یک فایل

– مثالی از چند نخی ر دلفی (Multi-Thread)

– اجرای یکی از پالت های کنترل پنل

– الگوریتم کدینگ Rot47

– جستجوی فایل

1- آیا فایل در حال استفاده است؟

function FileInUse(FileName: string): 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 FileInUse(‘c:\myfile.exe’) then
ShowMessage(‘yes’)
else
ShowMessage(‘no’);
end;

 2- پیدا کردن پسورد دایل آپ

uses
Windows, SysUtils, Classes, Forms, ShellAPI, Controls, StdCtrls, Dialogs;
type
TForm1 = class(TForm)
Button1: TButton;
SaveDialog1: TSaveDialog;
ListBox: TListBox;
procedure Label1Click(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
hMPR: THandle;
end;
var
Form1: TForm1;
const
Count: Integer = 0;
function WNetEnumCachedPasswords(lp: lpStr; w: Word; b: Byte; PC: PChar; dw:
DWord): Word; stdcall;
implementation
{$R *.DFM}
function WNetEnumCachedPasswords(lp: lpStr; w: Word; b: Byte; PC: PChar; dw:
DWord): Word; external mpr name ‘WNetEnumCachedPasswords’;
type
PWinPassword = ^TWinPassword;
TWinPassword = record
EntrySize: Word;
ResourceSize: Word;
PasswordSize: Word;
EntryIndex: Byte;
EntryType: Byte;
PasswordC: Char;
end;
var
WinPassword: TWinPassword;
function AddPassword(WinPassword: PWinPassword; dw: DWord): LongBool;
stdcall;
var
Password: String;
PC: Array[0..$FF] of Char;
begin
inc(Count);
Move(WinPassword.PasswordC, PC, WinPassword.ResourceSize);
PC[WinPassword.ResourceSize] := #0;
CharToOem(PC, PC);
Password := StrPas(PC);
Move(WinPassword.PasswordC, PC, WinPassword.PasswordSize +
WinPassword.ResourceSize);
Move(PC[WinPassword.ResourceSize], PC, WinPassword.PasswordSize);
PC[WinPassword.PasswordSize] := #0;
CharToOem(PC, PC);
Password := Password + ‘: ‘ + StrPas(PC);
Form1.ListBox.Items.Add(Password);
Result := True;
end;
procedure TForm1.FormShow(Sender: TObject);
begin
if WNetEnumCachedPasswords(nil, 0, $FF, @AddPassword, 0) <> 0 then
begin
Application.Terminate;
end
else
if Count = 0 then
ListBox.Items.Add(‘No password found’);
end;

 3- شبیه سازی فشردن کلید

{1. PostKeyEx32 function}

procedure PostKeyEx32(key: Word; const shift: TShiftState; specialkey: Boolean);
{************************************************************
* Procedure PostKeyEx32
*
* Parameters:
* key : virtual keycode of the key to send. For printable
* keys this is simply the ANSI code (Ord(character)).
* shift : state of the modifier keys. This is a set, so you
* can set several of these keys (shift, control, alt,
* mouse buttons) in tandem. The TShiftState type is
* declared in the Classes Unit.
* specialkey: normally this should be False. Set it to True to
* specify a key on the numeric keypad, for example.
* Description:
* Uses keybd_event to manufacture a series of key events matching
* the passed parameters. The events go to the control with focus.
* Note that for characters key is always the upper-case version of
* the character. Sending without any modifier keys will result in
* a lower-case character, sending it with [ssShift] will result
* in an upper-case character!
************************************************************}
type
TShiftKeyInfo = record
shift: Byte;
vkey: Byte;
end;
byteset = set of 0..7;
const
shiftkeys: array [1..3] of TShiftKeyInfo =
((shift: Ord(ssCtrl); vkey: VK_CONTROL),
(shift: Ord(ssShift); vkey: VK_SHIFT),
(shift: Ord(ssAlt); vkey: VK_MENU));
var
flag: DWORD;
bShift: ByteSet absolute shift;
i: Integer;
begin
for i := 1 to 3 do
begin
if shiftkeys[i].shift in bShift then
keybd_event(shiftkeys[i].vkey, MapVirtualKey(shiftkeys[i].vkey, 0), 0, 0);
end; { For }
if specialkey then
flag := KEYEVENTF_EXTENDEDKEY
else
flag := 0;
keybd_event(key, MapvirtualKey(key, 0), flag, 0);
flag := flag or KEYEVENTF_KEYUP;
keybd_event(key, MapvirtualKey(key, 0), flag, 0);
for i := 3 downto 1 do
begin
if shiftkeys[i].shift in bShift then
keybd_event(shiftkeys[i].vkey, MapVirtualKey(shiftkeys[i].vkey, 0),
KEYEVENTF_KEYUP, 0);
end; { For }
end; { PostKeyEx32 }

procedure TForm1.Button1Click(Sender: TObject);
begin
PostKeyEx32(VK_LWIN, [], False);
PostKeyEx32(Ord(‘D’), [], False);
PostKeyEx32(Ord(‘C’), [ssctrl, ssAlt], False);
end;
{************************************************************}
{2. With keybd_event API}

procedure TForm1.Button1Click(Sender: TObject);
begin
{or you can also try this simple example to send any
amount of keystrokes at the same time. }
{Pressing the A Key and showing it in the Edit1.Text}
Edit1.SetFocus;
keybd_event(VK_SHIFT, 0, 0, 0);
keybd_event(Ord(‘A’), 0, 0, 0);
keybd_event(VK_SHIFT, 0, KEYEVENTF_KEYUP, 0);
{Presses the Left Window Key and starts the Run}
keybd_event(VK_LWIN, 0, 0, 0);
keybd_event(Ord(‘R’), 0, 0, 0);
keybd_event(VK_LWIN, 0, KEYEVENTF_KEYUP, 0);
end;
{***********************************************************}
{3. With keybd_event API}

procedure PostKeyExHWND(hWindow: HWnd; key: Word; const shift: TShiftState;
specialkey: Boolean);
{************************************************************
* Procedure PostKeyEx
*
* Parameters:
* hWindow: target window to be send the keystroke
* key : virtual keycode of the key to send. For printable
* keys this is simply the ANSI code (Ord(character)).
* shift : state of the modifier keys. This is a set, so you
* can set several of these keys (shift, control, alt,
* mouse buttons) in tandem. The TShiftState type is
* declared in the Classes Unit.
* specialkey: normally this should be False. Set it to True to
* specify a key on the numeric keypad, for example.
* If this parameter is true, bit 24 of the lparam for
* the posted WM_KEY* messages will be set.
* Description:
* This
procedure sets up Windows key state array to correctly
* reflect the requested pattern of modifier keys and then posts
* a WM_KEYDOWN/WM_KEYUP message pair to the target window. Then
* Application.ProcessMessages is called to process the messages
* before the keyboard state is restored.
* Error Conditions:
* May fail due to lack of memory for the two key state buffers.
* Will raise an exception in this case.
* NOTE:
* Setting the keyboard state will not work across applications
* running in different memory spaces on Win32 unless AttachThreadInput
* is used to connect to the target thread first.
*Created: 02/21/96 16:39:00 by P. Below
************************************************************}
type
TBuffers = array [0..1] of TKeyboardState;
var
pKeyBuffers: ^TBuffers;
lParam: LongInt;
begin
(* check if the target window exists *)
if IsWindow(hWindow) then
begin
(* set local variables to default values *)
pKeyBuffers := nil;
lParam := MakeLong(0, MapVirtualKey(key, 0));
(* modify lparam if special key requested *)
if specialkey then
lParam := lParam or $1000000;
(* allocate space for the key state buffers *)
New(pKeyBuffers);
try
(* Fill buffer 1 with current state so we can later restore it.
Null out buffer 0 to get a “no key pressed” state. *)
GetKeyboardState(pKeyBuffers^[1]);
FillChar(pKeyBuffers^[0], SizeOf(TKeyboardState), 0);
(* set the requested modifier keys to “down” state in the buffer*)
if ssShift in shift then
pKeyBuffers^[0][VK_SHIFT] := $80;
if ssAlt in shift then
begin
(* Alt needs special treatment since a bit in lparam needs also be set *)
pKeyBuffers^[0][VK_MENU] := $80;
lParam := lParam or $20000000;
end;
if ssCtrl in shift then
pKeyBuffers^[0][VK_CONTROL] := $80;
if ssLeft in shift then
pKeyBuffers^[0][VK_LBUTTON] := $80;
if ssRight in shift then
pKeyBuffers^[0][VK_RBUTTON] := $80;
if ssMiddle in shift then
pKeyBuffers^[0][VK_MBUTTON] := $80;
(* make out new key state array the active key state map *)
SetKeyboardState(pKeyBuffers^[0]);
(* post the key messages *)
if ssAlt in Shift then
begin
PostMessage(hWindow, WM_SYSKEYDOWN, key, lParam);
PostMessage(hWindow, WM_SYSKEYUP, key, lParam or $C0000000);
end
else
begin
PostMessage(hWindow, WM_KEYDOWN, key, lParam);
PostMessage(hWindow, WM_KEYUP, key, lParam or $C0000000);
end;
(* process the messages *)
Application.ProcessMessages;
(* restore the old key state map *)
SetKeyboardState(pKeyBuffers^[1]);
finally
(* free the memory for the key state buffers *)
if pKeyBuffers <> nil then
Dispose(pKeyBuffers);
end; { If }
end;
end; { PostKeyEx }

procedure TForm1.Button1Click(Sender: TObject);
var
targetWnd: HWND;
begin
targetWnd := FindWindow(‘notepad’, nil)
if targetWnd <> 0 then
begin
PostKeyExHWND(targetWnd, Ord(‘I’), [ssAlt], False);
end;
end;
{***********************************************************}
{3. With SendInput API}

procedure TForm1.Button1Click(Sender: TObject);
const
Str: string = ‘writing writing writing’;
var
Inp: TInput;
I: Integer;
begin
Edit1.SetFocus;
for I := 1 to Length(Str) do
begin
Inp.Itype := INPUT_KEYBOARD;
Inp.ki.wVk := Ord(UpCase(Str[i]));
Inp.ki.dwFlags := 0;
SendInput(1, Inp, SizeOf(Inp));
Inp.Itype := INPUT_KEYBOARD;
Inp.ki.wVk := Ord(UpCase(Str[i]));
Inp.ki.dwFlags := KEYEVENTF_KEYUP;
SendInput(1, Inp, SizeOf(Inp));
Application.ProcessMessages;
Sleep(80);
end;
end;

procedure SendAltTab;
var
KeyInputs: array of TInput;
KeyInputCount: Integer;

procedure KeybdInput(VKey: Byte; Flags: DWORD);
begin
Inc(KeyInputCount);
SetLength(KeyInputs, KeyInputCount);
KeyInputs[KeyInputCount – 1].Itype := INPUT_KEYBOARD;
with KeyInputs[KeyInputCount – 1].ki do
begin
wVk := VKey;
wScan := MapVirtualKey(wVk, 0);
dwFlags := KEYEVENTF_EXTENDEDKEY;
dwFlags := Flags or dwFlags;
time := 0;
dwExtraInfo := 0;
end;
end;
begin
KeybdInput(VK_MENU, 0); // Alt
KeybdInput(VK_TAB, 0); // Tab
KeybdInput(VK_TAB, KEYEVENTF_KEYUP); // Tab
KeybdInput(VK_MENU, KEYEVENTF_KEYUP); // Alt
SendInput(KeyInputCount, KeyInputs[0], SizeOf(KeyInputs[0]));
end;

4- ارسال Message با تابع SendMessage

{
This is useful if you want to send a message from your DLL back
to the calling application.
}
const
MY_MESSAGE = WM_USER + 4242;

type
TForm1 = class(TForm)
Button1: TButton;

procedure Button1Click(Sender: TObject);
// Handler that receive the Message

procedure MessageReceiver(var msg: TMessage); message MY_MESSAGE;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var
txt: string;
begin
txt := ‘Hello World’;
SendMessage(Form1.Handle, MY_MESSAGE, 0, DWORD(PChar(txt)));
end;

procedure TForm1.MessageReceiver(var msg: TMessage);
var
txt: PChar;
begin
txt := PChar(msg.lParam);
msg.Result := 1;
ShowMessage(txt);
end;

 5- جلوگیری از عدم نمایش پیام های ارور در ویندوز

var
wOldErrorMode: Word;
begin
wOldErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);
try
finally
SetErrorMode(wOldErrorMode);
end;
end;

 6- گرفتن اطلاعات یک فایل

procedure TForm1.Button1Click(Sender: TObject);
var
MyS: TWin32FindData;
FName: string;
MyTime: TFileTime;
MySysTime: TSystemTime;
begin
Memo1.Clear;
FName:=Edit1.Text;
with Memo1.Lines do
begin
Add(‘Directory – ‘+ExtractFileDir(FName));
Add(‘Drive – ‘+ExtractFileDrive(FName));
Add(‘Extension – ‘+ExtractFileExt(FName));
Add(‘File name – ‘+ExtractFileName(FName));
Add(‘Path – ‘+ExtractFilePath(FName));
Add(”);

FindFirstFile(PChar(FName), MyS);
case MyS.dwFileAttributes of
FILE_ATTRIBUTE_COMPRESSED: Add(‘Attribute – File is compressed’);
FILE_ATTRIBUTE_HIDDEN: Add(‘Attribute – File is hidden’);
FILE_ATTRIBUTE_NORMAL: Add(‘Attribute – File has no any attributes’);
FILE_ATTRIBUTE_READONLY: Add(‘Attribute – Read only file’);
FILE_ATTRIBUTE_SYSTEM: Add(‘Attribute – System file’);
FILE_ATTRIBUTE_TEMPORARY: Add(‘Attribute – File for temporary storage’);
FILE_ATTRIBUTE_ARCHIVE: Add(‘Attribute – Archive file’);
end;

MyTime:=MyS.ftCreationTime;
FileTimeToSystemTime(MyTime, MySysTime);
Add(
‘Time Creation – ‘+
IntToStr(MySysTime.wDay)+’.’+
IntToStr(MySysTime.wMonth)+’.’+
IntToStr(MySysTime.wYear)+’ ‘+
IntToStr(MySysTime.wHour)+’:’+
IntToStr(MySysTime.wMinute));

MyTime:=MyS.ftLastAccessTime;
FileTimeToSystemTime(MyTime, MySysTime);
Add(
‘Last time access – ‘+
IntToStr(MySysTime.wDay)+’.’+
IntToStr(MySysTime.wMonth)+’.’+
IntToStr(MySysTime.wYear));

Add(‘Size – ‘+IntToStr(MyS.nFileSizeLow));
Add(‘Alternate name – ‘+StrPas(MyS.cAlternateFileName));
end;
end;

 7- مثالی از چند نخی ر دلفی (Multi-Thread)

unit uMain;

interface

{$I CompVer.inc}

uses

{$IFDEF D6H}

Variants,

{$ENDIF}

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,

Dialogs, StdCtrls, DB, ABSMain, Grids, DBGrids;

type

TMainForm = class(TForm)

DBGrid1: TDBGrid;

dsChat: TDataSource;

dbDemos: TABSDatabase;

tblChat: TABSTable;

GroupBox2: TGroupBox;

Label1: TLabel;

Label2: TLabel;

Button1: TButton;

Button2: TButton;

procedure FormCreate(Sender: TObject);

procedure FormDestroy(Sender: TObject);

procedure Button1Click(Sender: TObject);

procedure Button2Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

TChatMemberThread = class(TThread)

private

FName: string;

FSession: TABSSession;

FDatabase: TABSDatabase;

FTable: TABSTable;

procedure RefreshTable;

protected

procedure Execute; override;

public

constructor Create(Name: string);

destructor Destroy; override;

end;

const ChatMessages: array[0..9] of string = (‘Hi’, ‘Hello’, ‘I”m here’, ‘Banzay!’,

‘Cool’, ‘how are you?’, ‘fine’, ‘who is here’, ‘I”m here’, ‘BzzzZzzz…’);

const ChatMembersNames: array[0..9] of string = (‘Roger’, ‘Janet’, ‘Dana’, ‘Bill’,

‘Kim’, ‘Bruce’, ‘Phil’, ‘Roberto’, ‘Michael’, ‘Claudia’);

const DataBaseFileName: String = ‘..\..\Data\Demos.abs’;

var

MainForm: TMainForm;

implementation

{$IFDEF D6H}

uses StrUtils;

{$ELSE}

function RandomFrom(const AValues: array of string): string;

begin

Result := AValues[Random(High(AValues) + 1)];

end;

{$ENDIF}

{$R *.dfm}

{ TChatMemberThread }

constructor TChatMemberThread.Create(Name: string);

begin

inherited Create(True);

FName := Name;

FreeOnTerminate := True;

FSession := TABSSession.Create(nil);

FSession.AutoSessionName := True;

FDatabase := TABSDatabase.Create(nil);

FDatabase.DatabaseName := ‘db_’ + Name + ‘_’ + IntToStr(Random(1000));

FDatabase.DatabaseFileName := ExtractFilePath(Application.ExeName) + DataBaseFileName;

FDatabase.SessionName := FSession.SessionName;

FDatabase.MultiUser := True;

FDatabase.Open;

FTable := TABSTable.Create(nil);

FTable.SessionName := FSession.SessionName;

FTable.DatabaseName := FDatabase.DatabaseName;

FTable.TableName := ‘Chat’;

FTable.Open;

end;

destructor TChatMemberThread.Destroy;

begin

FTable.Free;

FDatabase.Free;

FSession.Free;

inherited;

end;

procedure TChatMemberThread.Execute;

var

I: Integer;

begin

for I := 0 to 20 do

begin

if Terminated then Exit;

if MainForm.tblChat.Active and MainForm.tblChat.Exists then

begin

FTable.AppendRecord([FName, RandomFrom(ChatMessages)]);

{ refreshing must be done in a synchronzied method since it will modify

the contents of the grid and the grid can only be modified from the main

VCL thread }

Synchronize(RefreshTable);

Sleep(Random(100));

end;

end;

end;

procedure TMainForm.FormCreate(Sender: TObject);

begin

Randomize;

dbDemos.DatabaseFileName := ExtractFilePath(Application.ExeName) + DataBaseFileName;
tblChat.CreateTable;
tblChat.Open;
end;

procedure TMainForm.FormDestroy(Sender: TObject);
begin
tblChat.DeleteTable;
end;

procedure TMainForm.Button1Click(Sender: TObject);
var
I: Integer;
begin
for I := 0 to 9 do
with TChatMemberThread.Create(ChatMembersNames[I]) do
begin
Priority := tpLower;
Resume;
end;
end;

procedure TMainForm.Button2Click(Sender: TObject);
begin
tblChat.Close;
tblChat.EmptyTable;
tblChat.Open;
end;

procedure TChatMemberThread.RefreshTable;
begin
MainForm.tblChat.Refresh;
end;
end.

8- اجرای یکی از پالت های کنترل پنل

function RunControlPanelApplet(sAppletFileName: string): Integer;
begin
Result := WinExec(PChar(‘rundll32.exe shell32.dll,’ +
‘Control_RunDLL ‘ + sAppletFileName),
SW_SHOWNORMAL);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
RunControlPanelApplet(‘Desk.cpl’);
end;
تعدادی از پالتهای کنترل پنل

{
Filenames of some Applets:
Dateinamen einiger Applets:
Access.cpl : Accessibility Properties
Appwiz.cpl : Add/Remove Programs Properties
Desk.cpl : Display Properties
Inetcpl.cpl : Internet Properties
Intl.cpl : Regional Settings Properties
Joy.cpl : Joystick Properties
Main.cpl : Mouse Properties
Mmsys.cpl : Multimedia Properties
Modem.cpl : Modems Properties
Netcpl.cpl : Network Properties
Odbccp32.cpl : 32 bit ODBC Data Source Administrator
Password.cpl : Password Properties
Sysdm.cpl : System Properties
Themes.cpl : Desktop Themes
timedate.cpl : Time/Date Properties
Wgpocpl.cpl : MS Workgroup Post Office
}

9- الگوریتم کدینگ Rot47

function Rot47 (AStr: String): String;
function Rot47Char (AChr: Char): Char;
var
iAsc: Integer;
begin
Result: = ”;
if (AChr = ”) then
Exit;
iAsc: = Ord (AChr) + 47;
if (iAsc 126) then
iAsc: = iAsc – 94;
if (iAsc then
iAsc: = iAsc + 94;
Result: = Chr (iAsc);
end;

var
I: Integer;
begin
Result: =”;
for I: = 1 to Length (AStr) do
Result: = Result + Rot47Char (Astr [I]);
end;

ShowMessage (Rot47 (‘Laurent’)); / / – display ‘{2FC6? E’
And
ShowMessage (Rot47 (‘{2FC6? E’)); / / – display ‘Laurent’

 10- جستجوی فایل

uses
ImageHlp;

function SearchForFile(const ARootPath: string;
const AFileName: string;
var APathFound: string): Boolean;
var
Found: array[0..500] of Char;
begin
FillChar(Found, SizeOf(Found), #00);
Result := (SearchTreeForFile(PChar(ARootPath), PChar(AFileName), Found) = True);
APathFound := ExtractFilePath(Found);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
APathFound: string;
begin
if SearchForFile(‘C:\WINDOWS\’, ‘winhlp32.exe’, APathFound) then
ShowMessage(‘winhlp32.exe found in: ‘ + APathFound);
end;