سورس دلفی

[lord_viper]

حذف یک پوشه با زیر مجموعه هایش

کد:

uses
Winapi.ShellAPI;

procedure TForm1.Button1Click(Sender: TObject);
var
shf:TSHFileOpStruct;
begin
shf.Wnd:=Handle;
shf.wFunc:=FO_DELETE;
shf.pFrom:=PChar('D:\pic');
shf.pTo:=nil;
shf.fFlags:=FOF_NO_UI;
SHFileOperation(shf);
end;

[The.Ghost]

پیدا کردن ورژن فایل.

کد:

Function GetVersionFile(PathFile:string): string;
var
  VerInfoSize: DWORD;
  VerInfo: Pointer;
  VerValueSize: DWORD;
  VerValue: PVSFixedFileInfo;
  Dummy: DWORD;
begin
Result := '';

VerInfoSize := GetFileVersionInfoSize(PChar(Trim(PathFile)), Dummy);

if VerInfoSize = 0 then Exit;
   GetMem(VerInfo, VerInfoSize);

GetFileVersionInfo(PChar(Trim(PathFile)), 0, VerInfoSize, VerInfo);
VerQueryValue(VerInfo, '\', Pointer(VerValue), VerValueSize);


With VerValue^ do
   begin
     Result := IntToStr(dwFileVersionMS shr 16);
     Result := Result + '.' + IntToStr(dwFileVersionMS and $FFFF);
     Result := Result + '.' + IntToStr(dwFileVersionLS shr 16);
     Result := Result + '.' + IntToStr(dwFileVersionLS and $FFFF);
End;

FreeMem(VerInfo, VerInfoSize);
end;

[lord_viper]

نمایش نوع اتصال به اینترنت

کد:

uses
WinInet;

function GetConnectionKind(var strKind: string): Boolean;
var
  flags: DWORD;
begin
  strKind := '';
  Result := InternetGetConnectedState(@flags, 0);
  if Result then
  begin
    if (flags and MODEM) = MODEM then strKind := 'Modem';
    if (flags and LAN) = LAN then strKind := 'LAN';
    if (flags and prxoy) = prxoy then strKind := 'prxoy';
    if (flags and BUSY) = BUSY then strKind := 'Modem Busy';
  end;
end;


procedure TForm1.Button1Click(Sender: TObject);
var
  strKind: string;
begin
  if GetConnectionKind(strKind) then
    ShowMessage(strKind);
end;

[lord_viper]

بدست اوردن لیست درایوها در لدفی 2010 به بالا

کد:

uses
System.IOUtils;

procedure TForm1.Button1Click(Sender: TObject);
var
drive:string;
begin
for drive in TDirectory.GetLogicalDrives do
ListBox1.Items.Add(drive);
end;

---

لیست تمتم پوشه ها و زیر پوشه های یک ادرس در دلفی 2010 به بالا

کد:

uses
System.IOUtils;

procedure TForm1.Button1Click(Sender: TObject);
var
dir:string;
begin
for dir in TDirectory.GetDirectories('d:\','*',TSearchOption.soAllDirectories) do
ListBox1.Items.Add(dir);
end;

[lord_viper]

base64 با استفاده از توابع api فقط در ویندوز7

کد:

unit XPBase64;
// Author: snowy, dumb.
interface

uses Windows;

const
  crypt32 = 'Crypt32.dll';

  // Flags:
  CRYPT_STRING_BASE64HEADER = 0;
  // Base64, with certificate Beginning and ending headers
  CRYPT_STRING_BASE64 = 1;
  // Base64, without headers
  CRYPT_STRING_BINARY = 2;
  // pure binary copy
  CRYPT_STRING_BASE64REQUESTHEADER = 3;
  // Base64, with request Beginning and ending headers
  CRYPT_STRING_HEX = 4;
  // Hexadecimal Only
  CRYPT_STRING_HEXASCII = 5;
  // Hexadecimal, with ASCII character display
  CRYPT_STRING_BASE64X509CRLHEADER = 9;
  // Base64, with X.509 CRL Beginning and ending headers
  CRYPT_STRING_HEXADDR = 10;
  // Hexadecimal, with Address display
  CRYPT_STRING_HEXASCIIADDR = 11;
  // Hexadecimal, with ASCII character display and Address
  CRYPT_STRING_HEXRAW = 12;
  // A raw hex string.

function ToBase64(s: string; Flags: dword = CRYPT_STRING_BASE64REQUESTHEADER): string;
function FromBase64(s: string; Flags: dword = CRYPT_STRING_BASE64REQUESTHEADER): string;

function CryptStringToBinary(pszString: PChar; cchString: dword; dwFlags: dword; pbBinary: pointer; var pcbBinary: dword; var pdwSkip: dword;
         var pdwFlags: dword): Boolean; stdcall;

function CryptBinaryToString(pbBinary: pointer; cbBinary: dword; dwFlags: dword; pszString: PChar; var pcchString: dword): Boolean; stdcall;

function CryptStringToBinaryA(pszString: PChar; cchString: dword; dwFlags: dword; pbBinary: pointer; var pcbBinary: dword; var pdwSkip: dword;
         var pdwFlags: dword): Boolean; stdcall;

function CryptBinaryToStringA(pbBinary: pointer; cbBinary: dword; dwFlags: dword; pszString: PChar; var pcchString : dword): Boolean; stdcall;

function CryptStringToBinaryW(pszString: PWideChar; cchString: dword; dwFlags: dword; pbBinary: pointer; var pcbBinary: dword; var pdwSkip: dword;
         var pdwFlags: dword): Boolean; stdcall;

function CryptBinaryToStringW(pbBinary: pointer; cbBinary: dword; dwFlags: dword; pszString: PWideChar; var pcchString: dword): Boolean; stdcall;

Implementation

function CryptStringToBinary; external crypt32 name 'CryptStringToBinaryA';
function CryptBinaryToString; external crypt32 name 'CryptBinaryToStringA';
function CryptStringToBinaryA; crypt32 external name 'CryptStringToBinaryA';
function CryptBinaryToStringA; external crypt32 name 'CryptBinaryToStringA';
function CryptStringToBinaryW; external crypt32 name 'CryptStringToBinaryW';
function CryptBinaryToStringW; external crypt32 name 'CryptBinaryToStringW';

function ToBase64(s: string; Flags: dword = CRYPT_STRING_BASE64REQUESTHEADER): string;
var sz: dword;
begin
  CryptBinaryToString(pointer(s), Length(s), Flags, nil, sz);
  SetLength(result, sz);
  CryptBinaryToString(pointer(s), Length(s), Flags, pointer(result), sz);
end;

function FromBase64(s: string; Flags: dword = CRYPT_STRING_BASE64REQUESTHEADER): string;
var sz, Skip: dword;
begin
  CryptStringToBinary(pointer(s), Length(s), Flags, nil, sz , Skip, Flags);
  SetLength(result, sz);
  CryptStringToBinary(pointer(s), Length(s), Flags, pointer(result), sz, Skip, Flags);
end;

end.

روش استفاده از یونیت فوق

کد:

uses XPBase64;
// Author: snowy, dumb.
procedure TForm1.Button1Click(Sender: TObject);
begin
  MEMO2 include.Text : = ToBase64(Memo1.Text);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  Memo3.Text : = FromBase64(MEMO2 include.Text);
end;

[lord_viper]

گرفتن ورژن و نام سیستم عامل ویندوز تا ویندوز 8

کد:

function WindowsVersion: String;
begin
Result := 'Unknown';
if Win32Platform = VER_PLATFORM_WIN32_NT then
case Win32MajorVersion of
  4: Result := 'Windows NT';
  5: case Win32MinorVersion of
      0: Result := 'Windows 2000';
      1: Result := 'Windows XP';
      2: Result := 'Windows 2003 Server';
     end;
  6: case Win32MinorVersion of
      0: Result := 'Windows Vista';
      1: Result := 'Windows 7';
      2: Result := 'Windows 8';
     end;
end else
case Win32MinorVersion of
  00: Result := 'Windows 95';
  10: if Trim(Win32CSDVersion) = 'A' then Result := 'Windows 98 SE'
      else Result := 'Windows 98';
  90: Result := 'Windows ME';
end;
if Win32BuildNumber >0 then
result:=result+' '+inttostr(Win32BuildNumber)+ ' ' +Win32CSDVersion;
end;

استفاده

کد:

ShowMessage(WindowsVersion);

[veyskarami]

تشخیص برنامه های 32/64 بیتی بدون اجرا کردن

کد:

// Detect 32 / 64 Applications
// Coded By Arash Veyskarami
//////////////////////////////

function Get_32_64(Filename:string):string;
var
Mch:Dword;
dos_header: IMAGE_DOS_HEADER;
pe_header: IMAGE_FILE_HEADER;
opt_header: IMAGE_OPTIONAL_HEADER;
fs:TFilestream;
signature: DWORD;
function DumpPEHeader(const h: IMAGE_FILE_HEADER):dword;
begin
Result:=h.Machine;
end;
begin
fs := TFilestream.Create(FileName, $0000 or $0040);
try
fs.read(dos_header, SizeOf(dos_header));
if dos_header.e_magic <> IMAGE_DOS_SIGNATURE then
Exit;
fs.seek(dos_header._lfanew, soFromBeginning);
fs.read(signature, SizeOf(signature));
finally
fs.read(pe_header, SizeOf(pe_header));
Mch:=DumpPEHeader(pe_header);
fs.Free;
end;
if Mch = $14C then Result:='32 Bit' ;
if Mch = $8664 then Result:='64 Bit';
end;
///////////////////////////////////////

[lord_viper]

تبدیل ادرس اینترنتی به ip

کد:

uses
  Winsock;


function IAddrToHostName(const IP: string): string;
var
  i: Integer;
  p: PHostEnt;
begin
  Result := '';
  i      := inet_addr(PChar(IP));
  if i <> u_long(INADDR_NONE) then
  begin
    p := GetHostByAddr(@i, SizeOf(Integer), PF_INET);
    if p <> nil then Result := p^.h_name;
  end
  else
    Result := 'Invalid IP address';
end;

---

گرفتن فرمت درایو fat32 یا ntfs

کد:

function GetHardDiskPartitionType(const DriveLetter: Char): string;
var
  NotUsed: DWORD;
  VolumeFlags: DWORD;
  VolumeInfo: array[0..MAX_PATH] of Char;
  VolumeSerialNumber: DWORD;
  PartitionType: array[0..32] of Char;
begin
  GetVolumeInformation(PChar(DriveLetter + ':\'),
    nil, SizeOf(VolumeInfo), @VolumeSerialNumber, NotUsed,
    VolumeFlags, PartitionType, 32);
  Result := PartitionType;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage(GetHardDiskPartitionType('c'));
  ShowMessage(GetHardDiskPartitionType('a'));
end;

[lord_viper]

حذف فایل با استفاده از توابع ntdll

کد:

function NtDeleteFile(ObjectAttributes:POBJECT_ATTRIBUTES):DWORD; stdcall; external 'ntdll;

function _DeleteFile(fileName:string):DWORD;
var
   oa:OBJECT_ATTRIBUTES;
   ws1, ws2:WideString;
   us:UNICODE_STRING;
begin
   Result := $C0000001; // STATUS_UNSUCCESSFUL, "generic" error
   ws1 := fileName; // automatic String -> WideString conversion
   SetLength(ws2, MAX_PATH);
   us.Length := MAX_PATH;
   us.MaximumLength := MAX_PATH;
   us.Buffer := @ws2[1];
   if not RtlDosPathNameToNtPathName_U(@ws1[1], us, nil, nil)
      then Exit;
   oa.Length := SizeOf(OBJECT_ATTRIBUTES);
   oa.RootDirectory := 0;
   oa.ObjectName := @us;
   oa.Attributes := $40; // case insensitive
   oa.SecurityDescriptor := nil;
   oa.SecurityQualityOfService := nil;
   Result := NtDeleteFile(@oa); // pass on the NTSTATUS
end;

[lord_viper]

نمایش format dialog

کد:

uses
shellapi

procedure TForm1.Button1Click(Sender: TObject);
begin
  ShellExecute(Application.Handle,
               PChar('Open'),
               PChar('C:\Windows\Rundll32.exe'),
               PChar('Shell32.dll,SHFormatDrive'),
               PChar('C:\Windows'),
               SW_SHOWNORMAL);
end;

[veyskarami]

ارسال PM به یاهو مسنجر 11.5 (فقط جنبه داشته باشید )

کد:

+ uses tlhelp32,shellapi

کد:

function PidToPath(dwProcessID: DWord): string;
var FSnapshotHandle: THandle;
FModuleEntry32 : TModuleEntry32;
begin
Result := '';
if (dwProcessID <> 0) then
begin
FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPMODULE,dwProcessID);
FModuleEntry32.dwSize := Sizeof(FModuleEntry32);
Module32First(FSnapshotHandle,FModuleEntry32);
result := FModuleEntry32.szExePath;
CloseHandle(FSnapshotHandle);
end;
end;

function IsYahooConnected(Wnd: HWND): Boolean;
begin;
Result := (GetMenuItemCount(GetMenu(Wnd)) > 3);
end;


function SendPM(YHandle:hwnd;ToUser,PM:Pchar):boolean;
var
y:hwnd;
Wnd,Ins,New,F:Hwnd;
pd,pa:cardinal;
begin
Result:=False;
if YHandle = 0 then exit;
if not IsYahooConnected(YHandle) then Exit;
SetForeGroundWindow(YHandle);
GetWindowThreadProcessId(YHandle,pd);
Ins:=FindWindowEx(YHandle,0,'#32770',nil);
ShellExecute(Ins,'',Pchar(PidToPath(Pd)),Pchar('ymsgr:sendim?'+ToUser+'&m='+PM ),'',0);
SetForeGroundWindow(YHandle);

while true do
begin
New:=FindWindow('CTabbedIMHost',nil);
Wnd:=FindWindowEx(New,0,'CConvWndBase',nil);
Wnd:=FindWindowEx(Wnd,0,'Button','Send');
GetWindowThreadProcessId(Wnd,pa);

SetForeGroundWindow(YHandle);
if Wnd > 0 then
begin
if pd = pa then SetParent(New,Ins) else exit;
PostMessage(Wnd, WM_KEYDOWN, VK_RETURN, 0);
Sleep(100);
break;
end;
end;
Sleep(1000);
SendMessage(New,WM_CLOSE,0,0);
end;

:use

کد:

var
YHandle:hwnd;
begin
YHandle:=FindWindow('YahooBuddyMain',nil);
SendPm(YHandle,Pchar('YahooId'),Pchar('Salam'));
end;