این تابع حافظه در دسترس کمتر از 2 گیگ رو فقط گزارش می ده
این تابع حافظه در دسترس کمتر از 2 گیگ رو فقط گزارش می ده
تابعي براي بستن برنامه هاي در حال اجرا مثل explorer.exe
uses
Tlhelp32;
function KillTask(ExeFileName: string): Integer;
const
PROCESS_TERMINATE = $0001;
var
ContinueLoop: BOOL;
FSnapshotHandle: THandle;
FProcessEntry32: TProcessEntry32;
begin
Result := 0;
FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
FProcessEntry32.dwSize := SizeOf(FProcessEntry32);
ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);
while Integer(ContinueLoop) <> 0 do
begin
if ((UpperCase(ExtractFileName(FProcessEntry32.szExeF ile)) =
UpperCase(ExeFileName)) or (UpperCase(FProcessEntry32.szExeFile) =
UpperCase(ExeFileName))) then
Result := Integer(TerminateProcess(
OpenProcess(PROCESS_TERMINATE,
BOOL(0),
FProcessEntry32.th32ProcessID),
0));
ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
end;
CloseHandle(FSnapshotHandle);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
KillTask('explorer.exe');
end;
procedure TFMain.FormCreate(Sender: TObject);
var
hMenuHandle: Integer;
begin
hMenuHandle := GetSystemMenu(Handle, False);
if (hMenuHandle > 0) then
DeleteMenu(hMenuHandle, SC_CLOSE, MF_BYCOMMAND);
end;
Everything that has a beginning has an end. ... The End?
.
.
.
var
Form1: TForm1;
a:string;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
a:='www.jgkgkhg-co.com';
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var
i: Integer;
begin
Application.Title := a;
Form1.Caption := a;
for i := 1 to (Length(a) - 1) do
a[i] := Application.Title[i + 1];
a[Length(a)] := Application.Title[1];
end;
آخرین ویرایش به وسیله بهروز عباسی : سه شنبه 07 اردیبهشت 1395 در 20:31 عصر
Everything that has a beginning has an end. ... The End?
procedure TForm1.HideTitlebar;
var
Style: Longint;
begin
if BorderStyle = bsNone then Exit;
Style := GetWindowLong(Handle, GWL_STYLE);
if (Style and WS_CAPTION) = WS_CAPTION then
begin
case BorderStyle of
bsSingle,
bsSizeable: SetWindowLong(Handle, GWL_STYLE, Style and
(not (WS_CAPTION)) or WS_BORDER);
bsDialog: SetWindowLong(Handle, GWL_STYLE, Style and
(not (WS_CAPTION)) or DS_MODALFRAME or WS_DLGFRAME);
end;
Height := Height - GetSystemMetrics(SM_CYCAPTION);
Refresh;
end;
end;
procedure TForm1.ShowTitlebar;
var
Style: Longint;
begin
if BorderStyle = bsNone then Exit;
Style := GetWindowLong(Handle, GWL_STYLE);
if (Style and WS_CAPTION) <> WS_CAPTION then
begin
case BorderStyle of
bsSingle,
bsSizeable: SetWindowLong(Handle, GWL_STYLE, Style or WS_CAPTION or
WS_BORDER);
bsDialog: SetWindowLong(Handle, GWL_STYLE,
Style or WS_CAPTION or DS_MODALFRAME or WS_DLGFRAME);
end;
Height := Height + GetSystemMetrics(SM_CYCAPTION);
Refresh;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
HideTitlebar;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
ShowTitlebar;
end
Everything that has a beginning has an end. ... The End?
uses registry;
function Get_Printerport(Printername: String): string;
var
Reg: TRegistry;
begin
Reg := TRegistry.Create;
with Reg do
begin
RootKey := HKEY_LOCAL_MACHINE;
if OpenKey('\System\CurrentControlSet\Control\Print\p rinters\' + Printername + '\', True) then
if ValueExists('port') then
Result := Readstring('port');
CloseKey;
end;
end;
Everything that has a beginning has an end. ... The End?
function GetDays(ADate: TDate): Extended;
var
FirstOfYear: TDateTime;
begin
FirstOfYear := EncodeDate(StrToInt(FormatDateTime('yyyy', now)) - 1, 12, 31);
Result := ADate - FirstOfYear;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
label1.Caption := 'Today is the ' + FloatToStr(GetDays(Date)) + '. day of the year';
end;
Everything that has a beginning has an end. ... The End?
uses ShellAPI;
function DeleteFileWithUndo(sFileName: string): Boolean;
var
fos: TSHFileOpStruct;
begin
FillChar(fos, SizeOf(fos), 0);
with fos do
begin
wFunc := FO_DELETE;
pFrom := PChar(sFileName);
fFlags := FOF_ALLOWUNDO or FOF_NOCONFIRMATION or FOF_SILENT;
end;
Result := (0 = ShFileOperation(fos));
end;
Everything that has a beginning has an end. ... The End?
procedure ShowStartButton(bValue: 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) = 'BUTTON' then
begin
// IsWindowVisible(Child)
if bValue = True then ShowWindow(Child, 1)
else
ShowWindow(Child, 0);
end;
end;
Child := GetWindow(Child, GW_HWNDNEXT);
end;
end;
Everything that has a beginning has an end. ... The End?
procedure EmptyRecycleBin;
const
SHERB_NOCONFIRMATION = $00000001;
SHERB_NOPROGRESSUI = $00000002;
SHERB_NOSOUND = $00000004;
type
TSHEmptyRecycleBin = function(Wnd: HWND;
pszRootPath: PChar;
dwFlags: DWORD): HRESULT; stdcall;
var
SHEmptyRecycleBin: TSHEmptyRecycleBin;
LibHandle: THandle;
begin { EmptyRecycleBin }
LibHandle := LoadLibrary(PChar('Shell32.dll'));
if LibHandle <> 0 then @SHEmptyRecycleBin :=
GetProcAddress(LibHandle, 'SHEmptyRecycleBinA')
else
begin
MessageDlg('Failed to load Shell32.dll.', mtError, [mbOK], 0);
Exit;
end;
if @SHEmptyRecycleBin <> nil then
SHEmptyRecycleBin(Application.Handle,
nil,
SHERB_NOCONFIRMATION or SHERB_NOPROGRESSUI or SHERB_NOSOUND);
FreeLibrary(LibHandle); @SHEmptyRecycleBin := nil;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
EmptyRecycleBin;
end;
Everything that has a beginning has an end. ... The End?
عکس گرفتن از پنجره ها
یه متد C# در این آدرس بود که تبدیلش کردم به دلفی
function CaptureWindow(handle:IntPtr;beginof:TPoint;endof:T point):TBitmap ;
var
hBitmap:IntPtr ;
hdcDest:IntPtr;
hdcSrc :IntPtr;
hOld:intptr;
windowRect:TRect;
bmp:TBitmap;
width:integer ;
height:integer;
begin
hdcSrc := GetWindowDC(handle);
windowRect :=TRect.Create(beginof,endof);
hdcDest:= CreateCompatibleDC(hdcSrc);
width:=windowRect.Right-windowRect.Left;
height:=windowRect.Bottom-windowRect.Top;
hBitmap := CreateCompatibleBitmap(hdcSrc,width,height);
hOld := SelectObject(hdcDest,hBitmap);
BitBlt(hdcDest,0,0,width,height,hdcSrc,0,0,SRCCOPY );
SelectObject(hdcDest,hOld);
DeleteDC(hdcDest);
ReleaseDC(handle,hdcSrc);
bmp:=TBitmap.Create;
bmp.Handle:=hBitmap;
result:= bmp;
end;
درود به همه.
تابعی که الان معرفی می کنم ،شما رو قادر به ترکیب دو عکس میکنه .
امید وارم مفید باشه.
procedure MeltImages(aImage1, aImage2: TBitmap; OutPut: TImage;
aiH, aiW: Integer);
var
X, Y: Integer; // Holds coordinates.
P, M: PByteArray; // For faster (than Pixels[]) access.
iHeight, iWidth: Integer;
begin
// Image
with OutPut do
begin
Picture.Bitmap := aImage1;
// Convert our images to true colour:
Picture.Bitmap.HandleType := bmDIB;
Picture.Bitmap.PixelFormat := pf24Bit;
Picture.Bitmap.HandleType := bmDIB;
Picture.Bitmap.PixelFormat := pf24Bit;
if aiH <= 0 then
iHeight := Height
else
iHeight := aiH;
if aiW <= 0 then
iWidth := Width
else
iWidth := aiW;
// Process the pixels:
For Y := 0 to iHeight - 1 do
begin
P := Picture.Bitmap.ScanLine[Y];
M := aImage2.ScanLine[Y];
For X := 0 to (iWidth) * 3 - 1 do
P[X] := (P[X] * (256 - M[X]) + (M[X])) div 256; // GOED!!
end;
end;
end;
اینم نمونه استفاده .
procedure TForm1.btn_ExampleClick(Sender: TObject);
begin
MeltImages(img_1.Picture.Bitmap, img_2.Picture.Bitmap,img_out, img_1.Height,
img_1.Width);
end;
موفق باشید
Everything that has a beginning has an end. ... The End?
...
var
MaxCount: Integer;
HGray: Array [0 .. 255] of Integer;
HRed: Array [0 .. 255] of Integer;
HGreen: Array [0 .. 255] of Integer;
HBlue: Array [0 .. 255] of Integer;
procedure ShowHistogram(imgSource, imgHistogram: TImage);
var
i, j: Integer;
pixelPointer: PByteArray;
begin
try
begin
for i := 0 to 255 do
begin
HGray[i] := 0;
HRed[i] := 0;
HGreen[i] := 0;
HBlue[i] := 0;
end;
if imgSource.Picture.Bitmap.PixelFormat = pf8bit then
begin
for i := 0 to imgSource.Height - 1 do
begin
pixelPointer := imgSource.Picture.Bitmap.ScanLine[i];
for j := 0 to imgSource.Width - 1 do
begin
Inc(HGray[pixelPointer[j]]);
end;
end;
MaxCount := 0;
for i := 0 to 255 do
if HGray[i] > MaxCount then
MaxCount := HGray[i];
end;
if imgSource.Picture.Bitmap.PixelFormat = pf24Bit then
begin
for i := 0 to imgSource.Height - 1 do
begin
pixelPointer := imgSource.Picture.Bitmap.ScanLine[i];
for j := 0 to imgSource.Width - 1 do
begin
Inc(HBlue[pixelPointer[3 * j]]);
Inc(HGreen[pixelPointer[3 * j + 1]]);
Inc(HRed[pixelPointer[3 * j + 2]]);
end;
end;
for i := 0 to 255 do
begin
if HRed[i] > MaxCount then
MaxCount := HRed[i];
if HGreen[i] > MaxCount then
MaxCount := HGreen[i];
if HBlue[i] > MaxCount then
MaxCount := HBlue[i];
end;
end;
with imgHistogram do
begin
Canvas.MoveTo(10, 160);
Canvas.Pen.Color := clBlack;
for i := 0 to 255 do
Canvas.LineTo(10 + i, 160 - round(150 * HGray[i] / MaxCount));
Canvas.Pen.Color := clRed;
Canvas.MoveTo(10, 160);
for i := 0 to 255 do
Canvas.LineTo(10 + i, 160 - (round(150 * HRed[i] / MaxCount)));
Canvas.Pen.Color := clGreen;
Canvas.MoveTo(10, 160);
for i := 0 to 255 do
Canvas.LineTo(10 + i, 160 - (round(150 * HGreen[i] / MaxCount)));
Canvas.Pen.Color := clBlue;
Canvas.MoveTo(10, 160);
for i := 0 to 255 do
Canvas.LineTo(10 + i, 160 - (round(150 * HBlue[i] / MaxCount)));
end;
end;
except
ShowMessage('Operation is not completed');
end;
end;
اینم طرض استفاده
procedure THistogramForm.btn_ExampleClick(Sender: TObject);
begin
ShowHistogram(img_In, img_out);
end;
اینم نتیجه کار روی یک عکس
موفق باشید.
آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 29 آبان 1392 در 23:08 عصر
Everything that has a beginning has an end. ... The End?
procedure ConverttoGray(imgSource: TImage);
var
Col, Row: Integer;
ptr: PByteArray;
begin
try
for Col := 0 to (imgSource.Height - 1) do
begin
ptr := imgSource.Picture.Bitmap.ScanLine[Col];
for Row := 0 to (imgSource.Width - 1) do
begin
if imgSource.Picture.Bitmap.PixelFormat = pf24Bit then
begin
ptr[3 * Row] := round(0.114 * ptr[3 * Row] + 0.587 * ptr[3 * Row + 1]
+ 0.299 * ptr[3 * Row + 2]);
ptr[3 * Row + 1] := ptr[3 * Row];
ptr[3 * Row + 2] := ptr[3 * Row];
end;
end;
imgSource.Refresh;
end;
except
on E: Exception do
MessageBox(0, pChar(E.Message), pChar(E.HelpContext), MB_OK);
end;
end;
procedure THistogramForm.btn_ExampleClick(Sender: TObject);
begin
ConverttoGray(img_In)
end;
Everything that has a beginning has an end. ... The End?
{ .. .. }
implementation
uses Winapi.IpHlpApi, Winapi.IpTypes;
{$R *.dfm}
procedure TForm1.ReadLanInterfaces;
var
InterfaceInfo, TmpPointer: PIP_ADAPTER_INFO;
IP: PIP_ADDR_STRING;
len: ULONG;
begin
if GetAdaptersInfo(nil, len) = ERROR_BUFFER_OVERFLOW then
begin
GetMem(InterfaceInfo, len);
try
if GetAdaptersInfo(InterfaceInfo, len) = ERROR_SUCCESS then
begin
TmpPointer := InterfaceInfo;
repeat
IP := @TmpPointer.IpAddressList;
repeat
lst1.Items.Add(Format('%s - [%s]', [IP^.IpAddress.S,
TmpPointer.Description]));
// lst1 IS a ListBox Control (TListBox)
IP := IP.Next;
until IP = nil;
TmpPointer := TmpPointer.Next;
until TmpPointer = nil;
end;
finally
FreeMem(InterfaceInfo);
end;
end;
end;
// the following is an example how to use the procedure
procedure TForm1.FormCreate(Sender: TObject);
begin
ReadLanInterfaces;
end;
Everything that has a beginning has an end. ... The End?
function StringToPAnsiChar(stringVar : string) : PAnsiChar;
Var
AnsString : AnsiString;
InternalError : Boolean;
begin
InternalError := false;
Result := '';
try
if stringVar <> '' Then
begin
AnsString := AnsiString(StringVar);
Result := PAnsiChar(PAnsiString(AnsString));
end;
Except
InternalError := true;
end;
if InternalError or (String(Result) <> stringVar) then
begin
Raise Exception.Create('Conversion from string to PAnsiChar failed!');
end;
end;
Everything that has a beginning has an end. ... The End?
درود به همه
امید وارم محتوای این پست تکراری نباشه ()
و اینکه برای شما هم مفید واقع بشه.
موفق باشید.
(هر دو پارت رو دانلود کنید؛ بعد اکستراک کنید)
Everything that has a beginning has an end. ... The End?
Function InputBoxCustom(ACaptionForm,ACaptionButton, APrompt, Value: string;
NumOnly,CloseButton:Boolean): String;
var
Form: TForm;
Prompt: TLabel;
Edit: TEdit;
begin
Form := TForm.Create(Application);
with Form do
try
Canvas.Font := Font;
BorderStyle := bsDialog;
Caption := ACaptionForm;
Position := poScreenCenter;
Width := 230;
Height := 100;
if CloseButton then
BorderIcons:=[biSystemMenu]
else
BorderIcons:=[];
Prompt := TLabel.Create(Form);
with Prompt do
begin
Parent := Form;
Caption := APrompt;
Left := 10;
Top := 10;
WordWrap := True;
end;
Edit := TEdit.Create(Form);
with Edit do
begin
Parent := Form;
Left := Prompt.Left;
Top := Prompt.Top + Prompt.Height + 5;
MaxLength := 255;
Text := Value;
SelectAll;
NumbersOnly := NumOnly;
end;
with TButton.Create(Form) do
begin
Parent := Form;
Left := 140;
Top := 25;
Caption := ACaptionButton;
ModalResult := mrOk;
Default := True;
end;
if ShowModal = mrOk then
begin
Result := Edit.Text;
end;
finally
Form.Free;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Edit1.Text := InputBoxCustom('cap','but','matn','salam', True,true);
end;
EXPORT DATASET(DBGRIDE ,TABLE , QURY) TO EXCEL
با سلام مطلب جالبی بود گذاشتم بقیه هم لذت ببرن
لینک منبع
[DELPHI]USES ExcelXP;
.................................................. .................................................. ..................
Function ExportToExcel(oDataSet : TDataSet; sFile : String): Boolean;
var
iCol,iRow : Integer;
oExcel : TExcelApplication;
oWorkbook : TExcelWorkbook;
oSheet : TExcelWorksheet;
begin
iCol := 0;
iRow := 0;
result := True;
oExcel := TExcelApplication.Create(Application);
oWorkbook := TExcelWorkbook.Create(Application);
oSheet := TExcelWorksheet.Create(Application);
try
oExcel.Visible[0] := False;
oExcel.Connect;
except
result := False;
MessageDlg('Excel may not be installed', mtError, [mbOk], 0);
exit;
end;
oExcel.Visible[0] := True;
oExcel.Caption := 'Sawami Export Engine';
oExcel.Workbooks.Add(Null,0);
oWorkbook.ConnectTo(oExcel.Workbooks[1]);
oSheet.ConnectTo(oWorkbook.Worksheets[1] as _Worksheet);
// iRow := 1;
for iCol:=1 to oDataSet.FieldCount do begin
// oSheet.Cells.Item[iRow,iCol] := oDataSet.FieldDefs.Items[iCol].Name;
// oSheet.Cells.Item[iRow,iCol] := oDataSet.Fields[iCol-1].FieldName;
end;
// iRow := 2;
oDataSet.Open;
while NOT oDataSet.Eof do begin
Inc(iRow);
for iCol:=1 to oDataSet.FieldCount do begin
oSheet.Cells.Item[iRow,iCol] := oDataSet.Fields[iCol-1].AsString;
end;
oDataSet.Next;
end;
//Change the wprksheet name.
oSheet.Name := 'List of Accounts';
//Change the font properties of all columns.
oSheet.Columns.Font.Color := clPurple;
oSheet.Columns.Font.FontStyle := fsBold;
oSheet.Columns.Font.Size := 10;
//Change the font properties of a row.
oSheet.Range['A1','A1'].EntireRow.Font.Color := clNavy;
oSheet.Range['A1','A1'].EntireRow.Font.Size := 16;
oSheet.Range['A1','A1'].EntireRow.Font.FontStyle := fsBold;
oSheet.Range['A1','A1'].EntireRow.Font.Name := 'Arabic Transparent';
//Change the font properties of a row.
oSheet.Range['A2','A2'].EntireRow.Font.Color := clBlue;
oSheet.Range['A2','A2'].EntireRow.Font.Size := 12;
oSheet.Range['A2','A2'].EntireRow.Font.FontStyle := fsBold;
oSheet.Range['A2','A2'].EntireRow.Font.Name := 'Arabic Transparent';
oSheet.Range['A2','H2'].HorizontalAlignment := xlHAlignCenter;
{
//Change the font properties of a column.
oSheet.Range['A1','C1'].EntireColumn.Font.Color := clBlue;
//Change Cells color of a row.
oSheet.Range['A1', 'A1'].EntireRow.Interior.Color := clNavy;
//Change Cells color of a column.
oSheet.Range['C1', 'C1'].EntireColumn.Interior.Color := clYellow;
//Align a column.
oSheet.Range['A1','A1'].HorizontalAlignment := xlHAlignLeft;
//Set a column with manually.
// oSheet.Columns.Range['A1','A1'].ColumnWidth := 16;
}
//Auto fit all columns.
oSheet.Columns.AutoFit;
DeleteFile(sFile);
Sleep(2000);
oSheet.SaveAs(sFile);
oSheet.Disconnect;
oSheet.Free;
oWorkbook.Disconnect;
oWorkbook.Free;
oExcel.Quit;
oExcel.Disconnect;
oExcel.Free;
end;
Examples:
//Export a DBGrid to Excel:
ExportToExcel(DBGrid1.DataSource.DataSet,'C:\MyDat a.XLS');
//Export a Table to Excel:
ExportToExcel(Table1,'C:\MyData.XLS');
//Export a Query to Excel:
ExportToExcel(Query1,'C:\MyData.XLS');[/DELPHI]
درود به همه
اینم تابعی برای قفل کردن یک درایو USB
(با کمی خلاقیت شاید بشه یک برنامه محافظتی!)
procedure RestrictUsbDrive(drive: Char; eject: Boolean);
var
hDevice: THandle;
bytesReturned: DWORD;
const
FSCTL_LOCK_VOLUME = (9 shl 16) or (0 shl 14) or (6 shl 2) or 0;
IOCTL_STORAGE_EJECT_MEDIA = ($2D shl 16) or (1 shl 14) or ($202 shl 2) or 0;
begin
hDevice := CreateFile(Pchar(Format('\\.\%s:', [drive])), GENERIC_READ or
GENERIC_WRITE, FILE_SHARE_READ or FILE_SHARE_WRITE, nil,
OPEN_EXISTING, 0, 0);
if hDevice <> INVALID_HANDLE_VALUE then
begin
if eject then
begin
DeviceIoControl(hDevice, IOCTL_STORAGE_EJECT_MEDIA, nil, 0, nil, 0,
bytesReturned, nil);
CloseHandle(hDevice);
end
else
DeviceIoControl(hDevice, FSCTL_LOCK_VOLUME, nil, 0, nil, 0,
bytesReturned, nil);
end;
end;
تا زمانی که برنامه شما در حال اجرا باشد درایو مورد نظر قفل می شود و بعد از بسته شدن برنامه به حالت عادی باز می گردد
USAGE:
// RestrictUsbDrive('h', False); // lock
RestrictUsbDrive('h', True); // eject
موفق باشید.
Everything that has a beginning has an end. ... The End?
درود به همه
با این تابع می تونید از اینترنت یک فایلو دانلود کنید
شرمنده تکراری
اما این کمی فرق داره چون با Inline Assembly نوشتمش ، هنوز داغه !
procedure File_Downloader(const AUrl, ASaveto: AnsiString);
const
UrlMonLib = 'URLMON.DLL';
Var
pURLDownloadToFileA: Pointer;
begin
pURLDownloadToFileA := GetProcAddress(LoadLibrary(UrlMonLib), 'URLDownloadToFileA');
if pURLDownloadToFileA <> nil then
begin
asm
push ebx
XOR EBX, EBX
PUSH 0
PUSH 0
PUSH ASaveto
PUSH AUrl
PUSH 0
MOV EAX, pURLDownloadToFileA
CALL EAX
PUSH EBX
POP EAX
pop ebx
end;
end
else
ShowMessage('Oops !');
end;
مثال :
File_Downloader ('http://hghghghghg.ir/wp-content/uploads/Camera.rar',
'C:\Camera.rar');
موفق باشید.
آخرین ویرایش به وسیله بهروز عباسی : سه شنبه 07 اردیبهشت 1395 در 20:33 عصر
Everything that has a beginning has an end. ... The End?
uses tlhelp32;
function gettaskmgr: DWORD;
var
PE32: TProcessEntry32;
snap: THandle;
begin
Result := 0;
snap := CreateToolHelp32SnapShot(TH32CS_SNAPPROCESS, 0);
PE32.dwSize := SizeOF(PE32);
process32first(snap, PE32);
repeat
if UpperCase(PE32.szExeFile) = 'TASKMGR.EXE' then
Result := PE32.th32ProcessID;
until Process32Next(snap, PE32) = FALSE;
end;
procedure ****TerminateProcess;
var
modl, task: THandle;
term: Pointer;
retn: array [0 .. 7] of byte;
btwn: NativeUInt;
begin
retn[0] := 89;
retn[1] := 88;
retn[2] := 88;
retn[3] := 51;
retn[4] := 192;
retn[5] := 81;
retn[6] := 195;
retn[7] := 90;
task := OpenProcess(PROCESS_VM_OPERATION or PROCESS_VM_WRITE or
PROCESS_VM_READ, FALSE, gettaskmgr);
if task <> 0 then
begin
modl := GetModuleHandle('kernel32.dll');
term := GetProcAddress(modl, 'TerminateProcess');
if term <> nil then
begin
ShowMessage('push ok to patch taskmgr!');
WriteProcessMemory(task, term, @retn, SizeOF(retn), btwn);
CloseHandle(task);
if btwn > 0 then
ShowMessage('succes')
else
ShowMessage('fail');
end;
end;
end;
نحوه استفاده :
procedure TForm1.FormCreate(Sender: TObject);
begin
****TerminateProcess
end;
به گفته نویسنده تابع این تابع در ویندوز های XP و 7 (نسخه 32 بیتی تست شده)
من ویندوزم 32 بیت نیست که تست کنم
منبع
Everything that has a beginning has an end. ... The End?
اینم یک یونیت برای تشخیص باز شدن برنامه ها در دیباگر ها (جلوگیری از کرک برنامه)
تشکر ویژه از Magic_h2001 .
unit AntiDbg;
{
very simple AntiDebug Unit for Delphi
can detect most debuggers:
OllyDBG,Immunity Debugger,WinDbg,W32DAsm,IDA,....
SoftICE,Syser,TRW,TWX
Tested on Win9x-Me-2k-XP-2k3-Vista
Coded by: Magic_h2001
magic_h2001@yahoo.com
http://magic.shabgard.org
just for fun ;)
}
interface
uses Windows,SysUtils,TlHelp32;
function IsDBG:Boolean;
implementation
var
Found:Boolean=False;
hSnapmod: THANDLE;
ModInfo: MODULEENTRY32;
hSnap: THANDLE;
ProcessInfo: PROCESSENTRY32;
ProcID:DWORD;
Tm1,Tm2:Int64;
function IsDebuggerPresent():BOOL; stdcall;external 'kernel32.dll' name 'IsDebuggerPresent';
function GetSys:string;
var
Gsys : array[0..MAX_PATH] of Char;
begin
GetSystemDirectory(Gsys,MAX_PATH);
Result:=Gsys;
if length(Result)>0 then
if Result[length(Result)]<>'\' then Result:=Result+'\';
end;
function UpCaseStr(S:string):String;
var i:integer;
begin
Result:=s;
if s='' then exit;
for i:=1 to length(s) do
Result[i]:=upcase(Result[i]);
end;
function RDTSC: Int64; assembler;
asm
PUSH EDI
PUSH EDI
PUSH EDI
PUSH EDI
DB 0fh ,031h
POP EDI
POP EDI
POP EDI
POP EDI
end;
function IsRing0DBG(S:string): boolean;
var hFile: Thandle;
begin
Result := False;
hFile := CreateFileA(Pchar(S), GENERIC_READ or GENERIC_WRITE,
0, nil, OPEN_EXISTING,FILE_ATTRIBUTE_NORMAL, 0);
if( hFile <> INVALID_HANDLE_VALUE ) then begin
CloseHandle(hFile);
Result := TRUE;
end;
end;
function IsDBG:Boolean;
var i: Integer;
begin
Tm1:=RDTSC;
for i:=0 to 255 do
OutputDebugStringA('kernel32.dll');
Tm2:=RDTSC-Tm1;
if Tm2<9999 then Found:=True;
if Tm2>299999999 then Found:=True;
hSnap:=CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS ,0);
ProcessInfo.dwSize:=sizeof(PROCESSENTRY32);
Process32First(hSnap,ProcessInfo);
repeat
if Pos('OLLYDBG',UpCaseStr(ProcessInfo.szExeFile))<>0 then Found:=True;
if Pos('DBG',UpCaseStr(ProcessInfo.szExeFile))<>0 then Found:=True;
if Pos('DEBUG',UpCaseStr(ProcessInfo.szExeFile))<>0 then Found:=True;
if Pos('IDAG',UpCaseStr(ProcessInfo.szExeFile))<>0 then Found:=True;
if Pos('W32DSM',UpCaseStr(ProcessInfo.szExeFile))<>0 then Found:=True;
ProcID:=ProcessInfo.th32ProcessID;
hSnapMod:=CreateToolhelp32Snapshot(TH32CS_SNAPMODU LE,ProcID);
ModInfo.dwSize:=sizeof(MODULEENTRY32);
Module32First(hSnapMod,ModInfo);
repeat
if Pos('OLLYDBG',UpCaseStr(ModInfo.szExePath))<>0 then Found:=True;
if Pos('W32DSM',UpCaseStr(ModInfo.szExePath))<>0 then Found:=True;
until (not Module32Next(hSnapMod,ModInfo));
CloseHandle(hSnapMod);
until (not Process32Next(hSnap,ProcessInfo));
CloseHandle(hSnap);
if FileExists(GetSys+'drivers\sice.sys') then Found:=True;
if FileExists(GetSys+'drivers\ntice.sys') then Found:=True;
if FileExists(GetSys+'drivers\syser.sys') then Found:=True;
if FileExists(GetSys+'drivers\winice.sys') then Found:=True;
if FileExists(GetSys+'drivers\sice.vxd') then Found:=True;
if FileExists(GetSys+'drivers\winice.vxd') then Found:=True;
if FileExists(GetSys+'winice.vxd') then Found:=True;
if FileExists(GetSys+'vmm32\winice.vxd') then Found:=True;
if FileExists(GetSys+'sice.vxd') then Found:=True;
if FileExists(GetSys+'vmm32\sice.vxd') then Found:=True;
if IsDebuggerPresent then Found:=True;
if IsRing0DBG('\\.\SICE') then Found:=True;
if IsRing0DBG('\\.\SIWVID') then Found:=True;
if IsRing0DBG('\\.\NTICE') then Found:=True;
if IsRing0DBG('\\.\TRW') then Found:=True;
if IsRing0DBG('\\.\TWX') then Found:=True;
if IsRing0DBG('\\.\ICEEXT') then Found:=True;
if IsRing0DBG('\\.\SYSER') then Found:=True;
Result:=Found;
end;
end.
Everything that has a beginning has an end. ... The End?
جستجو در يك پوشه و يافتن تمام پوشه و فايل هاي موجود در آن
PROCEDURE Sto_SearchDirectory(List: TStrings; const Directory: String; const Mask: String = '*.*'; Recursive: Boolean = True; Append: Boolean = False);
procedure _SearchDirectory(List: TStrings; const DelimitedDirectory: String; Masks: TStrings; Recursive: Boolean);
var
iMaskIndex: Integer;
bFoundFile: Boolean;
mySearchRec: TSearchRec;
sFile, sDirectory: String;
begin
// list files and directories
for iMaskIndex := 0 to Masks.Count - 1 do
begin
bFoundFile := FindFirst(DelimitedDirectory + Masks[iMaskIndex],
faAnyFile, mySearchRec) = 0;
while (bFoundFile) do
begin
// skip "." and ".."
if (mySearchRec.Name <> '.') and (mySearchRec.Name <> '..') then
begin
sFile := DelimitedDirectory + mySearchRec.Name;
// add delimiter to directories
if ((mySearchRec.Attr and faDirectory) <> 0) then
sFile := IncludeTrailingPathDelimiter(sFile);
// add to list
List.Add(sFile);
end;
// find next file
bFoundFile := FindNext(mySearchRec) = 0;
end;
FindClose(mySearchRec);
end;
// recursive call for directories
if (Recursive) then
begin
bFoundFile := FindFirst(DelimitedDirectory + '*', faDirectory,
mySearchRec) = 0;
while (bFoundFile) do
begin
// skip "." and ".."
if (mySearchRec.Name <> '.') and (mySearchRec.Name <> '..') then
begin
sDirectory := IncludeTrailingPathDelimiter(DelimitedDirectory +
mySearchRec.Name);
_SearchDirectory(List, sDirectory, Masks, Recursive);
end;
// find next directory
bFoundFile := FindNext(mySearchRec) = 0;
end;
FindClose(mySearchRec);
end;
end;
var
slMasks: TStringList;
BEGIN
// prepare list
if (not Append) then
List.Clear;
List.BeginUpdate;
slMasks := TStringList.Create;
try
// prepare masks
if (Mask = '') then
slMasks.Add('*')
else
begin
slMasks.Delimiter := ';';
slMasks.DelimitedText := Mask;
end;
// start recursive loop
_SearchDirectory(List, IncludeTrailingPathDelimiter(Directory),
slMasks, Recursive);
finally
slMasks.Free;
List.EndUpdate;
end;
END;
procedure TForm1.Button1Click(Sender: TObject);
begin
Sto_SearchDirectory(ListBox1.Items, Trim(Edit1.Text), '*.*', False, True);
end;
uses Variants;
procedure VariantDemo;
var
vDemo: Variant;
bTest: Boolean;
begin
// EMPTY
vDemo := Unassigned; // assign EMPTY to variant
bTest := VarIsEmpty(vDemo); // check if variant is EMPTY
// NULL
vDemo := NULL; // assign NULL to variant
bTest := VarIsNull(vDemo); // check if variant is NULL
// numeric
vDemo := 8.8; // assign a float to variant
bTest := VarIsNumeric(vDemo); // check if variant is numeric
// text
vDemo := 'demo'; // assign a string to variant
bTest := VarIsStr(vDemo); // check if variant contains text
// COM methods can define obtional parameters. if you are
// working with typelibraries you have to pass a parameter
// nevertheless, then you can pass "EmptyParam"
vDemo := EmptyParam;
bTest := VarIsEmptyParam(vDemo);
end;
درود به همه
مدتی هست دارم توی دلفی اسمبلی کار میکنم ، یه چیز منو اذیت میکرد اونم استفاده از توابع API توی اسمبلی بود (ارسال دونه به دونه پارامترها و ...)که با تابع زیر مشکلم حل شد
خدا کنه برای شما هم مفید باشه.
اول یه مثال از انجام کار بدون تابعی که نوشتم و بعد هم یک مثال با استفاده از تابعی که نوشتم :
function ASM_MessageBox(const AText, ACaption: AnsiString): DWORD;
const
user32 = 'user32.dll';
Var
pASM_MessageBox: Pointer;
begin
pASM_MessageBox := GetProcAddress(LoadLibrary(user32), 'MessageBoxA');
if pASM_MessageBox <> nil then
begin
asm
{ ;push parameter N
;push parameter2
;push parameter1
;call procedure
}
PUSH EAX
PUSH EBX
XOR EBX, EBX // EBX = 0
PUSH 4+64 // ;uType: UINT --> 4 = MB_YESNO and 46 = MB_ICONINFORMATION
PUSH ACaption // ;lpCaption: PAnsiChar -->ACaption;
PUSH AText // ;lpText: PAnsiChar --> AText
PUSH 0 // ;hWnd: HWND -->0 = Application.Handle
MOV EAX, pASM_MessageBox
CALL EAX // Run MessageBoxA
MOV Result,eax // Result --> 6=Yes | 7=NO
POP EBX
POP EAX
end;
end
else
ShowMessage('Oops !');
end;
اینم نحوه استفاده :
procedure Test_ASM_MSG();
var
Ret: Integer;
begin
Ret := ASM_MessageBox('Like ??', 'MessageBox by Inline Assembly');
if Ret = 6 then
ShowMessage('Yes')
else if Ret = 7 then
ShowMessage('NO');
end;
اینم تابع :
function ASM_Invoke(AFunction: Pointer; const AArguments: array of const)
: Cardinal; stdcall;
var
iIndex, iCurrentArgument: Integer;
begin
Result := 0;
for iIndex := High(AArguments) downto Low(AArguments) do
begin
iCurrentArgument := AArguments[iIndex].VInteger;
asm
push iCurrentArgument
end;
end;
asm
call AFunction
mov Result, eax
end;
end;
اینم همون مثال اول با تابعی که نوشتم:
procedure Test_ASM_MSG();
var
Text: AnsiString;
Caption: AnsiString;
ret: Integer;
begin
Text := 'Hello World ';
Caption := 'Test Invoke';
ret := ASM_Invoke(@Winapi.Windows.MessageBoxA,
[0, Text, Caption, MB_YESNO or MB_ICONINFORMATION]);
if ret = 6 then
ShowMessage('Yes')
else if ret = 7 then
ShowMessage('NO');
end;
موفق باشید
آخرین ویرایش به وسیله بهروز عباسی : یک شنبه 04 فروردین 1392 در 10:23 صبح
Everything that has a beginning has an end. ... The End?
uses ComObj;
function CompactAndRepair(DB: string): Boolean; {DB = Path to Access Database}
var
v: OLEvariant;
begin
Result := True;
try
v := CreateOLEObject('JRO.JetEngine');
try
V.CompactDatabase('Provider=Microsoft.Jet.OLEDB.4. 0;Data Source='+DB, 'Provider=Microsoft.Jet.OLEDB.4.0;Data Source='+DB+'x;Jet OLEDB:Engine Type=5');
DeleteFile(DB);
RenameFile(DB+'x',DB);
finally
V := Unassigned;
end;
except
Result := False;
end;
end;
آخرین ویرایش به وسیله دلفــي : سه شنبه 06 فروردین 1392 در 10:18 صبح
uses ComObj;
function CompactAndRepair(DB: string): Boolean; {DB = Path to Access Database}
var
v: OLEvariant;
begin
Result := True;
try
v := CreateOLEObject('JRO.JetEngine');
try
V.CompactDatabase('Provider=Microsoft.Jet.OLEDB.4. 0;Data Source='+DB, 'Provider=Microsoft.Jet.OLEDB.4.0;Data Source='+DB+'x;Jet OLEDB:Engine Type=5');
DeleteFile(DB);
RenameFile(DB+'x',DB);
finally
V := Unassigned;
end;
except
Result := False;
end;
end;
درود
شاید شما به هر دلیلی نیاز داشته باشید اطلاعات خاص _مثلاً_ یک فلش را بدست بیارید ،اطلاعاتی مثل شماره سریال منحصر به فرد اون (سخت افزاری) برای ساخت یک برنامه امنیتی که یک فلش خاص نقش کلید رو در اون ایفا میکنه.
برای اینکار کامپوننت و Dll و... هست ولی خیلی درهم برهم ،شما باچند خط ساده میتونید این اطلاعات رو بدست بیارید.
{ ........ }
var
query: array [0 .. 11] of byte = (
00,
00,
00,
00,
00,
00,
00,
00,
00,
08,
00,
00
);
type
TStorage_Bus_Type = (BusTypeUnknown, BusTypeScsi, BusTypeAtapi, BusTypeAta,
BusType1394, BusTypeSsa, BusTypeFibre, BusTypeUsb, BusTypeRAID);
type
TSTORAGE_DEVICE_DESCRIPTOR = record
Version: dword;
Size: dword;
DeviceType: UCHAR;
DeviceTypeModifier: UCHAR;
RemovableMedia: BOOLEAN;
CommandQueueing: BOOLEAN;
VendorIdOffset: dword;
ProductIdOffset: dword;
ProductRevisionOffset: dword;
SerialNumberOffset: dword;
BusType: TStorage_Bus_Type;
RawPropertiesLength: dword;
RawDeviceProperties: array [1 .. 500] of AnsiChar;
end;
{ -------------------------------------------------------------------------------
+ Procedure : Get_Value
+ Author : ...
+ DateTime : 2013.03.26
+ Arguments : buf: PSTORAGE_DEVICE_DESCRIPTOR; offs: dword
+ Result : string
------------------------------------------------------------------------------- }
function Translate_Value(buf: TSTORAGE_DEVICE_DESCRIPTOR; offs: dword): string;
var
_Result: array [0 .. 255] of AnsiChar;
begin
if offs = 0 then
exit;
asm
pusha
pushf
xor edi,edi
xor esi,esi
mov esi,offs
lea edx,buf
lea ebx,_Result
@m1:
mov al,[edx+esi]
mov [ebx+edi],al
inc edi
inc esi
cmp al,0
jne @m1
popf
popa
end;
Result := string(_Result);
end;
اصل کار اینه که حوصله نداشتم یه تابع درستو حسابی براش بنویسم(چون خودم فقط با دوسه موردش کار دارم)
var
hDevice: NativeInt;
Status: BOOLEAN;
ReturnedLength: ULONG;
DevDesc: TSTORAGE_DEVICE_DESCRIPTOR;
begin
hDevice := CreateFile(PChar('\\.\H:'), GENERIC_READ + GENERIC_WRITE,
FILE_SHARE_READ + FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0);
Status := DeviceIoControl(hDevice, $002D1400, @query, sizeof(query), @DevDesc,
512, cardinal(ReturnedLength), nil);
if Status then
begin
with lst_1.Items do
begin
Add(Translate_Value(DevDesc, DevDesc.VendorIdOffset));
Add(Translate_Value(DevDesc, DevDesc.ProductIdOffset));
Add(Translate_Value(DevDesc, DevDesc.SerialNumberOffset));
end;
end;
end;
که نام درایو من "H"است (یه فلش)
و با اجرای کد اطلاعات مورد نظرم توی یک ListBox نمایش داده میشن.
موفق باشید
Everything that has a beginning has an end. ... The End?
سلام
بعضی وقتها لازمه که در یک فایل باینری به دنبال یک کلمه خاص بگردیم و اون رو با یک مقدار دیگه جایگزین کنیم و نتیجه رو در یک فایل دیگه ذخیره کنیم. امروز تابعی نوشتم که میتونه این کار رو به راحتی انجام بده. البته من در این سناریو با فایلهای کم حجم (کمتر از 20 مگابایت) سر و کار دارم و این کد رو بر روی فایلهای با حجم بالا تست نکرده ام، چون عملاً نیازی به این کار نداشتم.
function PatchFile(OldString: AnsiString; NewString: AnsiString;
SourceFile, DestFile: String): Boolean;
var
SourceStream, DestStream: TFileStream;
temp: AnsiString;
idx: Cardinal;
begin
Result := False;
SourceStream := TFileStream.Create(SourceFile, fmOpenRead);
DestStream := TFileStream.Create(DestFile, fmOpenWrite or fmCreate);
try
SetLength(temp, SourceStream.Size);
SourceStream.ReadBuffer(Pointer(temp)^, Length(temp));
idx := Pos(OldString, temp);
if (idx > 0) then
begin
Result := True;
temp := StringReplace(temp, OldString, NewString, []);
DestStream.WriteBuffer(Pointer(temp)^, Length(temp));
end;
finally
SourceStream.Free;
DestStream.Free;
if (Result = False) then
DeleteFile(DestFile);
end;
end;
نحوه استفاده:
procedure TForm4.Button1Click(Sender: TObject);
var
Success: Boolean;
srcFileName, DestFileName: string;
begin
srcFileName := 'c:\test\recovery54.img';
DestFileName := 'c:\test\recovery.img';
Success := PatchFile('android', 'hello', srcFileName, DestFileName);
if (Success) then
ShowMessage('File Patched.')
else
ShowMessage('File NOT Patched');
end;
موفق باشید...
uses Winapi.WinSvc;
function LoadDriver(const cpDriverPath: PChar; const cpDriverName: PChar): BOOL;
var
hSCService: SC_HANDLE;
hSCManager: SC_HANDLE;
lpServiceArgVectors: PWideChar;
begin
Result := True;
lpServiceArgVectors := nil;
try
hSCManager := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
if (hSCManager = 0) then
Result := False;
hSCService := CreateService(hSCManager, cpDriverName, cpDriverName,
SERVICE_ALL_ACCESS, SERVICE_KERNEL_DRIVER, SERVICE_DEMAND_START,
SERVICE_ERROR_NORMAL, cpDriverPath, nil, nil, nil, nil, nil);
if (hSCService = 0) And (GetLastError = ERROR_SERVICE_EXISTS) then
hSCService := OpenService(hSCManager, cpDriverName, SERVICE_ALL_ACCESS);
if (hSCService = 0) then
Result := False;
if Not(StartService(hSCService, 0, lpServiceArgVectors)) then
begin
if (GetLastError() <> ERROR_SERVICE_ALREADY_RUNNING) then
Result := False;
end;
finally
CloseServiceHandle(hSCManager);
CloseServiceHandle(hSCService);
end;
end;
const
DriverPath = 'E:\Test\';
DriverName = 'BasicDriver.sys';
begin
if LoadDriver(DriverPath + DriverName, 'Test !!!!') then
ShowMessage('Wooo');
end;
موفق باشید.
آخرین ویرایش به وسیله بهروز عباسی : جمعه 03 خرداد 1392 در 18:49 عصر
Everything that has a beginning has an end. ... The End?
این تابع بهینه تره
uses Winapi.WinSvc;
function InstallAndStartDriver(const ADriverPath: PChar;
const ADriverName: PChar; const ADisplayName: PChar): Boolean;
var
hSCManager, hService: SC_HANDLE;
lpServiceArgVectors: PChar;
begin
Result := True;
hSCManager := 0;
hSCManager := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
if (hSCManager <> INVALID_HANDLE_VALUE) then
begin
try
hService := 0;
hService := CreateService(
hSCManager,
ADriverName,
ADisplayName,
SERVICE_ALL_ACCESS,
SERVICE_KERNEL_DRIVER,
SERVICE_DEMAND_START,
SERVICE_ERROR_NORMAL,
PChar(ADriverPath),
nil,
nil,
nil,
nil,
nil
);
if (hService=0) then
MessageBox(0, PChar(SysErrorMessage(GetLastError)),
'CreateService', MB_OK+MB_ICONINFORMATION);
hService := 0;
lpServiceArgVectors := nil;
hService := OpenService(
hSCManager,
ADriverName,
SERVICE_ALL_ACCESS
);
if (hService=0) then
MessageBox(0, PChar(SysErrorMessage(GetLastError)),
'OpenService', MB_OK+MB_ICONINFORMATION);
if (hService <> INVALID_HANDLE_VALUE) then
begin
try
if not (StartService(hService, 0, PChar(lpServiceArgVectors))) then
begin
Result := False;
if (hService=0) then
MessageBox(0, PChar(SysErrorMessage(GetLastError)),
'StartService', MB_OK+MB_ICONINFORMATION);
end;
finally
CloseServiceHandle(hService);
end;
end;
finally
CloseServiceHandle(hSCManager);
end;
end
else
begin
Result := False;
end;
if (GetLastError<>0) then
MessageBox(0, PChar(SysErrorMessage(GetLastError)),
'Last Error', MB_OK+MB_ICONINFORMATION);
end;
const
DriverPath = 'E:\Test\';
DriverName = 'BasicDriver.sys';
begin
if InstallAndStartDriver(DriverPath + DriverName,
DriverName,
'Display Name :)') then
ShowMessage('Wooo');
end;
آخرین ویرایش به وسیله بهروز عباسی : جمعه 03 خرداد 1392 در 16:24 عصر
Everything that has a beginning has an end. ... The End?
من هم یک کامپوننت میزارم که اوپن سورس هست و تا حالا هیچ جا ندیدمش حتما انلود کنید و استفاده کنید
این کامپوننت برای ایجاد تمامی سیستم های رمز نگاری هست مثل MD5-BloFish -SHA1-SHA128-SHA512 و هرچیز دیگه فکرش رو بکنید
تعیین وضعیت datasource
// Gloabal variables section
GlobalVarArray : Array [0..12] of string =
('حالت غیرفعال', 'dsBrowse', 'حالت ویرایش رکورد قبلی', 'حالت ثبت رکورد جدید', 'dsSetKey', 'dsCalcFields', 'dsFilter',
'dsNewValue', 'dsOldValue', 'dsCurValue', 'dsBlockRead', 'dsInternalCalc', 'dsOpening');
GlobalVarArray[ord(DataSource1.State)];
توابع تبدیل تاریخ با دقت 5000 سال
پذیرش پروژه، کامپوننت، آموزش برنامه نویسی (دلفی، اس کیو ال، ..) -> 09123780840
پایگاه داده، تیونینگ، طراحی و پیاده سازی ..
با سلام.
توجه داشته باشید که برای این کار باید مجموعه jvcl را نصب کرده باشید. ابتدا یونیتهای Registry و JvSetupApi را به بخش uses اضافه کنید و سپس تابع زیر را بنویسید:
function GetAvailableComPorts: TStringList;var
RequiredSize: Cardinal;
GUIDSize: DWORD;
Guid: TGUID;
DevInfoHandle: HDEVINFO;
DeviceInfoData: TSPDevInfoData;
MemberIndex: Cardinal;
PropertyRegDataType: DWORD;
RegProperty: Cardinal;
RegTyp: Cardinal;
Key: Hkey;
Info: TRegKeyInfo;
S1, S2: string;
hc: THandle;
begin
Result := Nil;
// If we cannot access the setupapi.dll then we return a nil pointer.
if not LoadsetupAPI then
Exit;
try
// get 'Ports' class guid from name
GUIDSize := 1;
// missing from original code - need to tell function that the Guid structure contains a single GUID
if SetupDiClassGuidsFromName('Ports', @Guid, GUIDSize, RequiredSize) then
begin
// get object handle of 'Ports' class to interate all devices
DevInfoHandle := SetupDiGetClassDevs(@Guid, Nil, 0, DIGCF_PRESENT);
if Cardinal(DevInfoHandle) <> Invalid_Handle_Value then
begin
try
MemberIndex := 0;
Result := TStringList.Create;
// iterate device list
repeat
FillChar(DeviceInfoData, SizeOf(DeviceInfoData), 0);
DeviceInfoData.cbSize := SizeOf(DeviceInfoData);
// get device info that corresponds to the next memberindex
if Not SetupDiEnumDeviceInfo(DevInfoHandle, MemberIndex,
DeviceInfoData) then
Break;
// query friendly device name LIKE 'BlueTooth Communication Port (COM8)' etc
RegProperty := SPDRP_FriendlyName;
{ SPDRP_Driver, SPDRP_SERVICE, SPDRP_ENUMERATOR_NAME,SPDRP_PHYSICAL_DEVICE_OBJECT _NAME,SPDRP_FRIENDLYNAME, }
SetupDiGetDeviceRegistryProperty(DevInfoHandle, DeviceInfoData,
RegProperty, PropertyRegDataType, NIL, 0, RequiredSize);
SetLength(S1, RequiredSize);
if SetupDiGetDeviceRegistryProperty(DevInfoHandle,
DeviceInfoData, RegProperty, PropertyRegDataType, @S1[1],
RequiredSize, RequiredSize) then
begin
Key := SetupDiOpenDevRegKey(DevInfoHandle, DeviceInfoData,
DICS_FLAG_GLOBAL, 0, DIREG_DEV, KEY_READ);
if Key <> Invalid_Handle_Value then
begin
FillChar(Info, SizeOf(Info), 0);
// query the real port name from the registry value 'PortName'
if RegQueryInfoKey(Key, nil, nil, nil, @Info.NumSubKeys,
@Info.MaxSubKeyLen, nil, @Info.NumValues,
@Info.MaxValueLen, @Info.MaxDataLen, nil,
@Info.FileTime) = ERROR_SUCCESS then
begin
RequiredSize := Info.MaxValueLen + 1;
SetLength(S2, RequiredSize);
if RegQueryValueEx(Key, 'PortName', Nil, @RegTyp,
@S2[1], @RequiredSize) = ERROR_SUCCESS then
begin
If (Pos('COM', S2) <> 0) then
begin
// Test if the device can be used
hc := CreateFile(pchar('\\.\' + S2 + #0),
GENERIC_READ or GENERIC_WRITE, 0, nil,
OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
if hc <> Invalid_Handle_Value then
begin
Result.Add(Strpas(pchar(S2)) + ': = ' +
Strpas(pchar(S1)));
CloseHandle(hc);
end;
end;
end;
end;
RegCloseKey(Key);
end;
end;
Inc(MemberIndex);
until False;
// If we did not found any free com. port we return a NIL pointer.
if Result.Count = 0 then
begin
Result.Free;
Result := NIL;
end
finally
SetupDiDestroyDeviceInfoList(DevInfoHandle);
end;
end;
end;
finally
UnloadSetupApi;
end;
end;
حال برای نمایش لیست پورتهای com می توانید از کدی شبیه به این استفاده کنید:
procedure TForm1.Button1Click(Sender: TObject);var
ComPortList: TStringList;
begin
ComPortList := GetAvailableComPorts;
try
ShowMessage(ComPortList.Text);
finally
ComPortList.Free;
end;
end;
نمونه کد ارتباط با چت هوش مصنوعی در دلفی:
function ChatWithDeepAI(question: string): string;
var
http: TIdHTTP;
begin
http := TIdHTTP.Create;
try
http.Request.ContentType := 'application/json';
http.Request.CustomHeaders.AddValue('api-key', 'Your API Key');
Result := http.Get('https://api.deepai.org/api/chat/?text=' + TIDURI.ParamsEncode(question));
finally
http.Free;
end;
end;
نحوه ی فراخوانی:
procedure TForm1.Button1Click(Sender: TObject);
begin
Memo1.Lines.Add(ChatWithDeepAI(Edit1.Text));
end;