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

3508 بازدید

در این پست قصد داریم چند نمونه کد مفید و جالب به زبان دلفی (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;

مطالب مرتبط


برچسب ها : , ,

دیدگاهتان را بنویسید

بخش های مورد نیاز علامت گذاری شده اند

نشانی ایمیل منتشر نخواهد شد

نویسنده : آدرس سایت : ایمیل :
کد روبرو را وارد نمایید
captcha


0

شبکه های اجتماعی

دانشنامه تخصصی مهندسی ایران را در شبکه های اجتماعی دنبال کنید

0 0

همکاران ما

گروه مپنا
گروه مپنا
دانشگاه تهران
دانشگاه تهران
سایپا
سایپا
ایران خودرو
ایران خودرو
شرکت ملی نفت ایران
شرکت ملی نفت ایران
ذوب‌آهن اصفهان
ذوب‌آهن اصفهان
فولاد خوزستان
فولاد خوزستان
درخواست نرم افزار
در صورتی که نیاز به نرم افزار خاصی دارید، با ما تماس بگیرید.
    همکاران ما در سریع ترین زمان ممکن پاسخگو شما خواهند بود.