صفحه 3 از 3 اولاول 123
نمایش نتایج 81 تا 120 از 120

نام تاپیک: مرجع توابع دلفی

  1. #81

    بدست آوردن اطلاعت RAM


    procedure TForm1.Button1Click(Sender: TObject);
    var
    MemorysStatus: TMemoryStatus;
    begin
    Memo1.Lines.Clear;
    MemorysStatus.dwLength := SizeOf(MemorysStatus);
    GlobalMemoryStatus(MemorysStatus);
    with MemorysStatus do
    begin
    Memo1.Lines.Add(IntToStr(dwLength) + ' Size of Memory Status record');
    Memo1.Lines.Add(IntToStr(dwMemoryLoad) + '% Memory in use');
    Memo1.Lines.Add(IntToStr(dwTotalPhys) + ' Total Physical Memory in Bytes');
    Memo1.Lines.Add(IntToStr(dwAvailPhys) + ' Available Physical Memory in Bytes');
    Memo1.Lines.Add(IntToStr(dwTotalPageFile) + ' Total Bytes of Paging File');
    Memo1.Lines.Add(IntToStr(dwAvailPageFile) + ' Available Bytes in Paging File');
    Memo1.Lines.Add(IntToStr(dwTotalVirtual) + ' User Bytes of Address Space');
    Memo1.Lines.Add(IntToStr(dwAvailVirtual) + ' Available User Bytes of Address Space');
    end;
    end
    Everything that has a beginning has an end. ... The End?



  2. #82

    غیرفعال کردن دکمه Close


    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?



  3. #83

    به حرکت در آوردن عنوان فرم


    .
    .
    .
    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?



  4. #84

    حذف کپشن فرم


    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?



  5. #85

    پیدا کردن نام پورتی که پرینتر استفاده می کند


    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?



  6. #86

    نقل قوپیدا کردن روز در سال


    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?



  7. #87

    حذف یک فایل


    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?



  8. #88

    مخفی کردن دکمه Start


    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?



  9. #89

    خالی کردن recycle bin



    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?



  10. #90
    منتظر تایید آدرس ایمیل
    تاریخ عضویت
    آذر 1390
    پست
    560

    نقل قول: مرجع توابع دلفی

    عکس گرفتن از پنجره ها

    یه متد 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;

  11. #91

    مخلوط کردن دو تصویر (پردازش تصویر)

    درود به همه.
    تابعی که الان معرفی می کنم ،شما رو قادر به ترکیب دو عکس میکنه .
    امید وارم مفید باشه.
    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?



  12. #92

    رسم هیستوگرام تصویر (پردازش تصویر)


    ...

    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?



  13. #93

    سیاه و سفید کردن عکس (پردازش تصویر)

    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?



  14. #94

    بدست آوردن لیست Adapterهای اتصال به شبکه

      { .. .. }
    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?



  15. #95

    تبدیل String به PAnsiChar

    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?



  16. #96

    584 تابع و قطعه کد در زمینه های مختلف به زبان دلفی

    درود به همه
    امید وارم محتوای این پست تکراری نباشه ()
    و اینکه برای شما هم مفید واقع بشه.
    موفق باشید.

    (هر دو پارت رو دانلود کنید؛ بعد اکستراک کنید)
    فایل های ضمیمه فایل های ضمیمه
    Everything that has a beginning has an end. ... The End?



  17. #97

    InputBox سفارشی

    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;


  18. #98
    کاربر دائمی آواتار firststep
    تاریخ عضویت
    مهر 1387
    محل زندگی
    ایران-خواستم از جنبه تفاهم باهم بگم
    پست
    502

    نقل قول: مرجع توابع دلفی

    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]


  19. #99

    Lock or eject USB drive

    درود به همه
    اینم تابعی برای قفل کردن یک درایو 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?



  20. #100

    دانلود فایل با Inline ASM

    درود به همه

    با این تابع می تونید از اینترنت یک فایلو دانلود کنید
    شرمنده تکراری
    اما این کمی فرق داره چون با 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?



  21. #101

    غیر فعال کردن TerminateProcess در Task Manager

    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?



  22. #102

    یونیت Anti Debug برای تشخیص دیباگر ها

    اینم یک یونیت برای تشخیص باز شدن برنامه ها در دیباگر ها (جلوگیری از کرک برنامه)
    تشکر ویژه از 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?



  23. #103
    کاربر دائمی آواتار SayeyeZohor
    تاریخ عضویت
    اسفند 1387
    محل زندگی
    ا-ص-ف-ه-ا-ن
    پست
    631

    نقل قول: مرجع توابع دلفی

    جستجو در يك پوشه و يافتن تمام پوشه و فايل هاي موجود در آن

    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;

  24. #104
    کاربر دائمی آواتار SayeyeZohor
    تاریخ عضویت
    اسفند 1387
    محل زندگی
    ا-ص-ف-ه-ا-ن
    پست
    631

    Empty and Null


    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;

  25. #105

    آشتی با Assembly !

    درود به همه

    مدتی هست دارم توی دلفی اسمبلی کار میکنم ، یه چیز منو اذیت میکرد اونم استفاده از توابع 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?



  26. #106

    Thumbs up ‍Compact and Repair in Access database



    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 صبح

  27. #107
    کاربر دائمی آواتار SayeyeZohor
    تاریخ عضویت
    اسفند 1387
    محل زندگی
    ا-ص-ف-ه-ا-ن
    پست
    631

    نقل قول: مرجع توابع دلفی


    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;

  28. #108

    مشخصات کامل درایوها (HDD,USB,...)

    درود
    شاید شما به هر دلیلی نیاز داشته باشید اطلاعات خاص _مثلاً_ یک فلش را بدست بیارید ،اطلاعاتی مثل شماره سریال منحصر به فرد اون (سخت افزاری) برای ساخت یک برنامه امنیتی که یک فلش خاص نقش کلید رو در اون ایفا میکنه.

    برای اینکار کامپوننت و 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?



  29. #109

    Patch کردن یک فایل

    سلام
    بعضی وقتها لازمه که در یک فایل باینری به دنبال یک کلمه خاص بگردیم و اون رو با یک مقدار دیگه جایگزین کنیم و نتیجه رو در یک فایل دیگه ذخیره کنیم. امروز تابعی نوشتم که میتونه این کار رو به راحتی انجام بده. البته من در این سناریو با فایلهای کم حجم (کمتر از 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;

    موفق باشید...

  30. #110

    Load کردن Driver ها با کد نویسی !


    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?



  31. #111

    نقل قول: مرجع توابع دلفی

    این تابع بهینه تره
    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?



  32. #112
    کاربر دائمی آواتار gholami146
    تاریخ عضویت
    آبان 1388
    محل زندگی
    مشهد مقدس
    پست
    374

    نقل قول: مرجع توابع دلفی

    من هم یک کامپوننت میزارم که اوپن سورس هست و تا حالا هیچ جا ندیدمش حتما انلود کنید و استفاده کنید
    این کامپوننت برای ایجاد تمامی سیستم های رمز نگاری هست مثل MD5-BloFish -SHA1-SHA128-SHA512 و هرچیز دیگه فکرش رو بکنید
    فایل های ضمیمه فایل های ضمیمه

  33. #113
    کاربر دائمی آواتار SayeyeZohor
    تاریخ عضویت
    اسفند 1387
    محل زندگی
    ا-ص-ف-ه-ا-ن
    پست
    631

    نقل قول: مرجع توابع دلفی

    تعیین وضعیت datasource


    // Gloabal variables section
    GlobalVarArray : Array [0..12] of string =
    ('حالت غیرفعال', 'dsBrowse', 'حالت ویرایش رکورد قبلی', 'حالت ثبت رکورد جدید', 'dsSetKey', 'dsCalcFields', 'dsFilter',
    'dsNewValue', 'dsOldValue', 'dsCurValue', 'dsBlockRead', 'dsInternalCalc', 'dsOpening');



    GlobalVarArray[ord(DataSource1.State)];

  34. #114
    توابع تبدیل تاریخ با دقت 5000 سال
    پذیرش پروژه، کامپوننت، آموزش برنامه نویسی (دلفی، اس کیو ال، ..) -> 09123780840

    دوستای گلم حمایت کنید : https://cafebazaar.ir/app/com.nikanmehr.marmarxword/


    نرم افزار پخش مویرگی

  35. #115
    کاربر تازه وارد
    تاریخ عضویت
    خرداد 1391
    محل زندگی
    تهران - تهرانپارس
    پست
    79

    نقل قول: بدست آوردن اطلاعت RAM

    این تابع حافظه در دسترس کمتر از 2 گیگ رو فقط گزارش می ده

  36. #116

    Thumbs up تابعي براي بستن برنامه هاي در حال اجرا مثل explorer.exe

    تابعي براي بستن برنامه هاي در حال اجرا مثل 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;

  37. #117

    Talking به دست آوردن لیست پورتهای com در ویندوز با استفاده از دلفی

    با سلام.
    توجه داشته باشید که برای این کار باید مجموعه 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;

  38. #118

    Thumbs up Get Host Name and IP Address


    uses Winsock;


    function GetPCName : string;
    var UName : PChar;
    USize : DWORD;
    begin
    USize := 100;
    UName := StrAlloc(USize);
    GetComputerName(UName,USize);
    Result := string(UName);
    StrDispose(UName);
    end;


    function GetLocalIP: string;
    type
    TaPInAddr = array [0..10] of PInAddr;
    PaPInAddr = ^TaPInAddr;
    var
    phe :PHostEnt;
    pptr :PaPInAddr;
    Buffer :PAnsichar;
    i :integer;
    GInitData :TWSADATA;
    begin
    wsastartup($101,GInitData);
    result:='';
    GetHostName(Buffer,SizeOf(Buffer));
    phe:=GetHostByName(PAnsiChar(AnsiString(GetPCName) ));
    if not assigned(phe) then
    exit;
    pptr:=PaPInAddr(Phe^.h_addr_list);
    i:=0;
    while pptr^[I]<>nil do begin
    result:=StrPas(inet_ntoa(pptr^[I]^));
    inc(i);
    end;
    wsacleanup;
    end;


    procedure TForm1.Button1Click(Sender: TObject);
    begin
    Edit1.Text := GetPCName;
    Edit2.Text := GetLocalIP;
    end;

  39. #119

    Post نقل قول: Get Host Name and IP Address

    نرم افزار راهنمای توابع و رویه های زبان برنامه نویسی دلفی (FPDelphi v1.10.17)

    https://barnamenevis.org/showthread....lphi-v1-10-17)



  40. #120

    Lightbulb چت با هوش مصنوعی

    نمونه کد ارتباط با چت هوش مصنوعی در دلفی:


    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;

صفحه 3 از 3 اولاول 123

قوانین ایجاد تاپیک در تالار

  • شما نمی توانید تاپیک جدید ایجاد کنید
  • شما نمی توانید به تاپیک ها پاسخ دهید
  • شما نمی توانید ضمیمه ارسال کنید
  • شما نمی توانید پاسخ هایتان را ویرایش کنید
  •