ايران ويج

ايران ويج > برنامه نویسی > دلفی > سورس دلفی
نسخه‌ی کامل: سورس دلفی
شما در حال مشاهده‌ی نسخه‌ی متنی این صفحه می‌باشید. مشاهده‌ی نسخه‌ی کامل با قالب بندی مناسب.
صفحه‌ها: 1 2 3 4 5

lord_viper

۲۲-بهمن-۱۳۹۱, ۲۰:۰۳:۵۲
استفاده از fast report در دلفی

کد:
procedure MyForm.HowToUseFastReport;
begin
  try
    frxReport1.PrepareReport(true); //Prepare the report
    frxReport1.ShowPreparedReport; //Show the prepared report.
    frxReport1.PrintOptions.ShowDialog := False; //Do not show print dialog
    frxReport1.PrintOptions.Printer := YourPrinterName; //Assign Printer Name
    frxReport1.SelectPrinter; //Select this printer
    frxReport1.PrintOptions.Copies := NoOfCopies; //Assign number of copies to be printed
    frxReport1.Print; //Finally print
  except
    on E : Exception do
    begin
      ShowMessage('Error occured in function HowToUseFastReport: ' + E.Message);
    end;
  end;
end;
به جای YourPrinterName نام پرینتر خود را بگذارید
استفاده از این تابع

کد:
frxReport1.ShowPreparedReport; //Show the prepared report.
گوش گرد کردن کنترلها در دلفی

کد:
procedure TMyForm.RoundTheCorners;
begin
  MakeRounded(Panel1);
  MakeRounded(Panel2);
  MakeRounded(Panel3);
  MakeRounded(Panel4);
end;

procedure TMyForm.MakeRounded(Control: TWinControl);
var
  R: TRect;
  Rgn: HRGN;
begin
  with Control do
  begin
    R := ClientRect;
    rgn := CreateRoundRectRgn(R.Left, R.Top, R.Right, R.Bottom, 20, 20);
    Perform(EM_GETRECT, 0, lParam(@r));
    InflateRect(r, - 5, - 5);
    Perform(EM_SETRECTNP, 0, lParam(@r));
    SetWindowRgn(Handle, rgn, True);
    Invalidate;
  end;
end;

veyskarami

۲۷-بهمن-۱۳۹۱, ۲۱:۰۳:۰۱
ورودی میگیره میگه رشته هست یا عدد
خیلی به دردم خورد امروز نوشتمش
کد:
function StrOrInt(Str:string):string;
var
i:integer;
begin
Result:='Integer';
  if Str = '' then
   begin
    Result:='String';
    Exit;
   end;
  for i:=1 to Length(str) do
   if not(Str[i] in ['0'..'9']) then
    begin
     Result:='String';
     Break;
    end;
end;

lord_viper

۰۵-فروردین-۱۳۹۲, ۱۷:۱۴:۰۱
جلوگیری از دسترسی برنامه ها به اینترنت

کد:
type
   PMIB_TCPROW       =  ^MIB_TCPROW;
  MIB_TCPROW        =  packed  record
     dwState:       DWORD;
     dwLocalAddr:   DWORD;
      dwLocalPort:   DWORD;
     dwRemoteAddr:  DWORD;
      dwRemotePort:  DWORD;
  end;

  PMIB_TCPTABLE     =   ^MIB_TCPTABLE;
  MIB_TCPTABLE      =  packed record
      dwNumEntries:  DWORD;
     Table:         Array [0..MaxWord] of  MIB_TCPROW;
  end;

function GetTcpTable(Table:Pointer;dwSize:PDWORD;state:Boolean):DWORD;stdcall;external 'Iphlpapi.dll';
function SetTcpEntry(pTcpRow:PMIB_TCPROW):DWORD;stdcall;external 'Iphlpapi.dll';

procedure BuildandTerminate;
var
dwSize:DWORD;
theTable:PMIB_TCPTABLE;
item:PMIB_TCPROW;
i:Integer;
begin
dwSize:=10;
GetTcpTable(thetable,@dwSize,false);
GetMem(theTable,dwSize);
if GetTcpTable(thetable,@dwSize,false)=ERROR_SUCCESS then
begin
for i:=0 to thetable^.dwNumEntries-1 do
begin
item:=@thetable.table[i];
item.dwState:=12;
SetTcpEntry(item);
end;
FreeMem(theTable);
end;
end;

procedure blockinternet;
begin
SetTimer(Form1.Handle,1,30,@BuildandTerminate);
end;

procedure unblockinternet;
begin
KillTimer(Form1.Handle,1);
end;

lord_viper

۱۴-فروردین-۱۳۹۲, ۰۹:۳۳:۱۶
تابعی برای نصب یک درایور در دلفی

کد:
ShellAPI;

function InstallINF(const PathName: string; hParent: HWND): Boolean;
var    instance: HINST; begin    instance := ShellExecute(hParent,
      PChar('open'),
      PChar('rundll32.exe'),
      PChar('setupapi,InstallHinfSection
            DefaultInstall 132 ' + PathName),
      nil,
      SW_HIDE) ;

   Result := instance > 32; end;

و نحوه فراخوانی

کد:
InstallINF(InstallINF('c:/example.driver.dll',handle);

lord_viper

۱۸-فروردین-۱۳۹۲, ۱۸:۲۳:۴۸
دور زدن API-MONITOR

کد:
{$ APPTYPE CONSOLE}

uses
   windows;

const
intexc: byte = $ cc;
stolen: byte = $ 8b;
var
readeen: byte;
findapiaddr: pointer;
wtritten: dword;
begin
writeln ('/ / / / BYPASS PROCESSE-EXPLORER (SIMPLE) + BYPASS API-MONITOR');
findapiaddr: = getprocaddress (loadlibrary ('user32.dll'), 'FindWindowW');

copymemory (addr (readeen), findapiaddr, sizeof (readeen));
if readeen = intexc then
    begin
    writeln ('! API-MONITOR DETECTED, UNHOOKING START ...');
    / / Bypass code here
    writeprocessmemory (getcurrentprocess, findapiaddr, addr (stolen), 1, wtritten);
    end;
if findwindoww ('PROCEXPL', nil) <> 0 then
    writeln ('+ PROCESSE-EXPLORER DETECTED')
else
    writeln ('! ERROR PROCESSE-EXPLORER NO DETECTECD');

while true do sleep (1000);
end.

lord_viper

۲۴-اردیبهشت-۱۳۹۲, ۰۹:۱۶:۵۰
تبدیل انواع متغییرها به رشته

کد:
function ValToString(Value: Variant): String;
begin
  case TVarData(Value).VType of
    varSmallInt,
    varInteger   : Result := IntToStr(Value);
    varSingle,
    varDouble,
    varCurrency  : Result := FloatToStr(Value);
    varDate      : Result := FormatDateTime('dd.mm.yyyy', Value);
    varBoolean   : if Value then Result := 'T' else Result := 'F';
    varString    : Result := Value;
    else            Result := '';
  end;
end;

بهروز عباسی

۰۱-خرداد-۱۳۹۲, ۲۳:۰۶:۳۸
کد:
unit unt_DriverList;

(*

  Coded By : Behrooz Abbassi (Saam)

*)
interface

Uses
  Vcl.Graphics,
  Vcl.Controls,
  Vcl.ComCtrls,
  Winapi.Windows,
  Winapi.PsAPI,
  Winapi.ShellAPI,
  System.StrUtils,
  System.SysUtils;

type
  TDriverList = class(TObject)
  private
    FIcon: TIcon;
    FSmallIcon: TImageList;
    function Get_WinSysDir: string;
    function Get_FileIcon(const fFileName: string): TIcon;

  const
    SErrorMessage = 'Failed to enumerate drivers. Make sure ' +
      'PSAPI.DLL is installed on your system.';
  public
    constructor Create;
    destructor Destroy;
    procedure Get_DriverList(Listview: TListView);
  end;

implementation

{ TDriverList }

constructor TDriverList.Create;
begin
  FSmallIcon := TImageList.Create(nil);
  FIcon := TIcon.Create;
end;

destructor TDriverList.Destroy;
begin
  FSmallIcon.Free;
  FIcon.Free;
end;

procedure TDriverList.Get_DriverList(Listview: TListView);
var
  strTempName: string;
  I: Integer;
  dwCount: DWORD;
  FDrvlist: array of Pointer;
  BigArray: array [0 .. $3FFF - 1] of DWORD;
  DrvName: array [0 .. MAX_PATH] of char;
  varout: word;
begin
  Listview.SmallImages := FSmallIcon;
  if not EnumDeviceDrivers(@BigArray, SizeOf(BigArray), dwCount) then
    raise Exception.Create(SErrorMessage);

  SetLength(FDrvlist, dwCount div SizeOf(DWORD));
  Move(BigArray, FDrvlist[0], dwCount);

  for I := low(FDrvlist) to High(FDrvlist) do
  begin

    if GetDeviceDriverFileName(FDrvlist[I], DrvName, SizeOf(DrvName)) > 0 then
    begin
      with Listview.Items.Add do
      begin

        Caption := ExtractFileName(DrvName);

        if FileExists(Get_WinSysDir + '\' + Caption) then
          strTempName := Get_WinSysDir + '\' + Caption
        else if FileExists(Get_WinSysDir + '\Drivers\' + Caption) then
          strTempName := Get_WinSysDir + '\Drivers\' + Caption
        else
          strTempName := DrvName;

        if LeftStr(strTempName, Length('\??\')) = '\??\' then
        begin
          strTempName := ReplaceStr(strTempName, '\??\', '');
        end;
        if LeftStr(strTempName, Length('\SystemRoot')) = '\SystemRoot' then
        begin
          strTempName := LeftStr(Get_WinSysDir, 2) + ReplaceStr(strTempName,
            'SystemRoot', 'Windows');
        end;
        if LeftStr(strTempName, Length('\Windows')) = '\Windows' then
        begin
          strTempName := LeftStr(Get_WinSysDir, 2)+strTempName;
        end;
        SubItems.Add(strTempName);
        SubItems.Add(Format('%p', [FDrvlist[I]]));

        if FileExists(strTempName) then
          ImageIndex := FSmallIcon.AddIcon(Get_FileIcon(strTempName));

      end;
    end;
  end;
end;

function TDriverList.Get_FileIcon(const fFileName: string): TIcon;
  function GetIcon(const FileN: string; bLIcon: Boolean = true): TSHFileInfo;
  begin
    if bLIcon then
    begin
      ShGetFileInfo(Pchar((FileN)), 0, Result, SizeOf(Result), SHGFI_TYPENAME or
        SHGFI_ICON or SHGFI_LARGEICON or SHGFI_LARGEICON);
    end
    else if not(bLIcon) then
    begin
      ShGetFileInfo(Pchar((FileN)), 0, Result, SizeOf(Result), SHGFI_TYPENAME or
        SHGFI_ICON or SHGFI_LARGEICON or SHGFI_SMALLICON);
    end;
  end;

begin { Small }
  FIcon.Handle := GetIcon(fFileName, False).HICON;
  Result := FIcon;
end;

function TDriverList.Get_WinSysDir: string;
{$IFDEF MSWINDOWS }
var
  Buffer: array [0 .. 255] of char;
begin
  GetWindowsDirectory(Buffer, MAX_PATH);
  Result := StrPas(Buffer) + '\';
{$ENDIF MSWINDOWS }
end;

end.
نحوه استفاده :
کد:
var
  DL: TDriverList;
begin
  DL := TDriverList.Create;
  try
    DL.Get_DriverList(LV);
  finally
   DL.Free;
  end;
که LV یک کنترل ListView اه.


codingmaster.ir/?p=204

veyskarami

۰۳-خرداد-۱۳۹۲, ۰۰:۱۴:۲۰
کد:
program Inj;

uses
  Windows;

var
  sBuff:    array[0..255] of Char;

{$R *.res}

procedure MeltProc();
begin
  Sleep(500);
  DeleteFile(sBuff);
end;

function InjectCode(szProcessName:string; pFunction:Pointer):Boolean;
var
  STARTINFO:  TStartupInfo;
  PROCINFO:   TProcessInformation;
  pFunc:      Pointer;
  dSize:      DWORD;
  pInjected:  Pointer;
  dWritten:   DWORD;
  CONTEXT:    TContext;
  hMod:       THandle;
  IDH:        TImageDosHeader;
  INH:        TImageNtHeaders;
begin
  FillChar(STARTINFO, SizeOf(TStartupInfo), #0);
  STARTINFO.cb := SizeOf(TStartupInfo);
  if CreateProcess(nil, PChar(szProcessName),  nil, nil, FALSE, CREATE_SUSPENDED, nil, nil, STARTINFO, PROCINFO) then
  begin
    hMod := GetModuleHandle(nil);
    CopyMemory(@IDH, Pointer(hMod), 64);
    if IDH.e_magic = IMAGE_DOS_SIGNATURE then
    begin
      CopyMemory(@INH, Pointer(hMod + IDH._lfanew), 248);
      if INH.Signature = IMAGE_NT_SIGNATURE then
      begin
        dSize := INH.OptionalHeader.SizeOfImage;
        pInjected := VirtualAllocEx(PROCINFO.hProcess, Ptr(hMod), dSize, MEM_COMMIT or MEM_RESERVE, PAGE_EXECUTE_READWRITE);
        WriteProcessMemory(PROCINFO.hProcess, pInjected, Ptr(hMod), dSize, dWritten);
        CONTEXT.ContextFlags := CONTEXT_FULL;
        GetThreadContext(PROCINFO.hThread, CONTEXT);
        CONTEXT.Eip := DWORD(pFunction);
        SetThreadContext(PROCINFO.hThread, CONTEXT);
        ResumeThread(PROCINFO.hThread);
      end;                
    end;
  end;
end;

procedure MeltFile();
begin
  GetModuleFileName(0, sBuff, 256);
  InjectCode('notepad.exe', @MeltProc);
end;

begin
  MeltFile;
end.
IPC

کد:
unit ipc;


interface

uses
  Windows;
type
  TIpc = record
    Status: Cardinal;
    ReportName: Array [0..255] of Char;
  end;
  PIpc = ^TIpc;

const
  IPC_SCRIPT_WRITTEN = $0001;
  IPC_REPORT_WRITTEN = $0002;
  IPC_SCRIPT_READ = $0004;
  IPC_REPORT_READ = $0008;

function ipcReadScript(Name: String): String;
function ipcWriteScript(Name, Value: String): Boolean;
function ipcReadReportHeader(Name: String): String;
function ipcReadReport(Name: String): String;
function ipcWriteReportHeader(Name, ReportName: String): Boolean;
function ipcWriteReport(Name, Value: String): Boolean;
function ipcSetStatus(Name: String; Status: Cardinal): Boolean;
function ipcGetStatus(Name: String): Cardinal;

implementation

function ipcCreateFileMap(Name: String; MapSize: Cardinal): Cardinal;
begin
  Result := CreateFileMapping($FFFFFFFF, nil, PAGE_READWRITE, 0, MapSize, PChar(Name));
end;

function ipcReadScript(Name: String): String;
var
  lpIpc: PIpc;
  hFileMap: Cardinal;
begin
  Result := '';

  hFileMap := OpenFileMapping(FILE_MAP_ALL_ACCESS, False, PChar(Name));
  if (hFileMap = 0) then Exit;

  lpIpc := MapViewOfFile(hFileMap, FILE_MAP_ALL_ACCESS, 0, 0, 0);
  if (lpIpc <> nil) then
  begin
    try
      if (lpIpc^.Status = IPC_SCRIPT_WRITTEN) then
        Result := PChar(Integer(lpIpc) + SizeOf(TIpc));
    except
    end;
  end;
end;

function ipcWriteScript(Name, Value: String): Boolean;
var
  lpIpc: PIpc;
  hFileMap: Cardinal;
begin
  Result := False;

  hFileMap := ipcCreateFileMap(Name, SizeOf(TIpc) + Length(Value) + 1);
  if (hFileMap = 0) then Exit;

  lpIpc := MapViewOfFile(hFileMap, FILE_MAP_ALL_ACCESS, 0, 0, 0);
  if (lpIpc <> nil) then
  begin
    try
      lpIpc^.Status := IPC_SCRIPT_WRITTEN;
      lpIpc^.ReportName := '';
      CopyMemory(Ptr(Integer(lpIpc) + SizeOf(TIpc)), PChar(Value), Length(Value) + 1);

      Result := True;
    except
    end;
  end;
end;

function ipcReadReportHeader(Name: String): String;
var
  lpIpc: PIpc;
  hFileMap: Cardinal;
begin
  Result := '';

  hFileMap := OpenFileMapping(FILE_MAP_ALL_ACCESS, False, PChar(Name));
  if (hFileMap = 0) then Exit;

  lpIpc := MapViewOfFile(hFileMap, FILE_MAP_ALL_ACCESS, 0, 0, 0);
  if (lpIpc <> nil) then
  begin
    try
      if (lpIpc^.Status = IPC_REPORT_WRITTEN) then
        Result := lpIpc^.ReportName;
    except
    end;
  end;
end;

function ipcReadReport(Name: String): String;
var
  lpReport: PChar;
  hFileMap: Cardinal;
begin
  Result := '';

  hFileMap := OpenFileMapping(FILE_MAP_ALL_ACCESS, False, PChar(Name));
  if (hFileMap = 0) then Exit;

  lpReport := MapViewOfFile(hFileMap, FILE_MAP_ALL_ACCESS, 0, 0, 0);
  if (lpReport <> nil) then
  begin
    try
      Result := String(lpReport);
    except
    end;
  end;
end;

function ipcWriteReportHeader(Name, ReportName: String): Boolean;
var
  lpIpc: PIpc;
  hFileMap: Cardinal;
begin
  Result := False;

  hFileMap := OpenFileMapping(FILE_MAP_ALL_ACCESS, False, PChar(Name));
  if (hFileMap = 0) then Exit;

  lpIpc := MapViewOfFile(hFileMap, FILE_MAP_ALL_ACCESS, 0, 0, 0);
  if (lpIpc <> nil) then
  begin
    try
      CopyMemory(@lpIpc^.ReportName[0], PChar(ReportName), Length(ReportName) + 1);
      Result := True;
    except
    end;
  end;
end;

function ipcWriteReport(Name, Value: String): Boolean;
var
  lpReport: PChar;
  hFileMap: Cardinal;
begin
  Result := False;

  hFileMap := ipcCreateFileMap(Name, Length(Value) + 1);
  if (hFileMap = 0) then Exit;

  lpReport := MapViewOfFile(hFileMap, FILE_MAP_ALL_ACCESS, 0, 0, 0);
  if (lpReport <> nil) then
  begin
    try
      CopyMemory(lpReport, PChar(Value), Length(Value) + 1);
      Result := True;
    except
    end;
  end;
end;

function ipcSetStatus(Name: String; Status: Cardinal): Boolean;
var
  lpIpc: PIpc;
  hFileMap: Cardinal;
begin
  Result := False;

  hFileMap := OpenFileMapping(FILE_MAP_ALL_ACCESS, False, PChar(Name));
  if (hFileMap = 0) then Exit;

  lpIpc := MapViewOfFile(hFileMap, FILE_MAP_ALL_ACCESS, 0, 0, 0);
  if (lpIpc <> nil) then
  begin
    try
      lpIpc^.Status := Status;
      Result := True;
    except
    end;
  end;
end;

function ipcGetStatus(Name: String): Cardinal;
var
  lpIpc: PIpc;
  hFileMap: Cardinal;
begin
  Result := 0;

  hFileMap := OpenFileMapping(FILE_MAP_ALL_ACCESS, False, PChar(Name));
  if (hFileMap = 0) then Exit;

  lpIpc := MapViewOfFile(hFileMap, FILE_MAP_ALL_ACCESS, 0, 0, 0);
  if (lpIpc <> nil) then
  begin
    try
      Result := lpIpc^.Status;
    except
    end;
  end;
end;

end.

Usage:
function TF_WriteScript(P: Pointer): Cardinal; stdcall;
var
  ReportName: String;
begin
  Result := 0;

  ipcWriteScript('Script1', Form1.Memo1.Lines.Text);

  while (ipcGetStatus('Script1') <> IPC_REPORT_WRITTEN) do Sleep(1000);

  ReportName := ipcReadReportHeader('Script1');
  if (ReportName = '') then Exit;

  Form1.Memo1.Lines.Text := ipcReadReport(ReportName);
  ipcSetStatus('Script1', IPC_REPORT_READ);

  MessageBox(0, 'WriteScript', '', MB_OK);
end;

function TF_ReadScript(P: Pointer): Cardinal; stdcall;
begin
  Result := 0;

  Form1.Memo1.Lines.Text := ipcReadScript('Script1');
  ipcSetStatus('Script1', IPC_SCRIPT_READ);

  if not (ipcWriteReportHeader('Script1', 'Report1')) then
    Exit;

  ipcWriteReport('Report1', 'String copied to Form successfully!!');
  ipcSetStatus('Script1', IPC_REPORT_WRITTEN);

  while (ipcGetStatus('Script1') <> IPC_REPORT_READ) do Sleep(1000);

  MessageBox(0, 'ReadScript', '', MB_OK);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  lpThreadId: Cardinal;
begin
  CreateThread(nil, 0, @TF_WriteScript, nil, 0, lpThreadId);
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  lpThreadId: Cardinal;
begin
  CreateThread(nil, 0, @TF_ReadScript, nil, 0, lpThreadId);
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;

لطفاً اگه راههایی بهتری هست بگید
کد:
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;
Example
کد:
const
  DriverPath = 'E:\Test\';
  DriverName = 'BasicDriver.sys';
begin
  if InstallAndStartDriver(DriverPath + DriverName,
                           DriverName,
                           'Display Name :)') then
                                                     ShowMessage('Wooo');

end;

babyy

۰۳-خرداد-۱۳۹۲, ۱۹:۰۹:۰۶
جسارتا پوزش میطلبم
این توضیجات کدتون رو اگه توی متن پستتون هم بنویسید (نه فقط توی عنوان) فکر کنم موتورهای جست وجو بهتر ایندکس کنن؛
ممنون

------------
اگه اینکارو کردید پست من هم حذف کنید بی زحمت

veyskarami

۱۵-خرداد-۱۳۹۲, ۰۰:۲۸:۵۴
این کد رو برای بافر کردن فایلهای اجرایی و ... نوشتم
با این کد فایلهای اجرایی به صورت بافر های هگزادسیمال تو یه یونیت مخصوص تبدیل میشن.

فرمت برنامه رو iم به صورت کنسول طراحی کردم و سعی کردم سرعت اجرای کد تا جای ممکن بالا باشه.
کد:
// Coded By Arash Veyskarami
// Publiced

program ExeToHex;

{$APPTYPE CONSOLE}

uses
  windows,Classes,Sysutils;
procedure ExeToBuff(szExeName,szSaveTo,UnitName:Pchar; const Columns:integer=16);
const
CRLF = #13#10;
var
f:TmemoryStream;
size:int64;
i,j:integer;
t,sp,Buddy:string;
s:char;
HFile:Thandle;
BytesWritten :dword;
Buff:Pchar;
begin
Buddy:='Unit '+UnitName+';' +CRLF+CRLF+'interface' + CRLF + CRLF +'uses Windows;' + CRLF+CRLF+ 'const' + CRLF + CRLF+ 'Buffers: array[0..';
              f:=TmemoryStream.Create();
              f.LoadFromFile(szExeName);
              size:=f.Size;
              j:=0;
              for i:= 0 to size do
              begin
                  inc(j);
                  f.Position := i;
                  f.Read(s,1);
                  if j = Columns then
                  begin
                   sp:=CRLF;
                   j:=0;
                  end
                  else sp:='';
                t:=t+'$'+inttohex(Ord(s),2)+','+sp;
              end;
              Buddy:=Buddy+IntToStr(f.Size)+'] of byte =('+CRLF;
              Delete(t,Length(t),1);
              t:=t+');' + CRLF + CRLF + 'implementation' + CRLF + CRLF +'end.';
              Buff:=Pchar(Buddy+t);

              HFile := CreateFile(szSaveTo,GENERIC_WRITE,FILE_SHARE_READ, Nil,OPEN_ALWAYS, 0, 0);
              SetFilePointer(HFile, 0, nil, FILE_END);
              WriteFile(HFile,buff[0],length(buff),BytesWritten,nil);
              CloseHandle(HFile);
              f.Free;
end;

begin
if paramCount = 0 then
begin
    WriteLn('Please enter parameters');
    WriteLn('[Input Exe] [Output Unit] [Unit Name] [Columns counts to array]');
    WriteLn('');
    WriteLn('Ex: ExeToHex.exe C:\Windows\Notepad.exe Notepad.Pas Notepad 16');
    ReadLn;

end;
DeleteFile(Pchar(ParamStr(2)));

ExeToBuff(Pchar(ParamStr(1)),Pchar(ParamStr(2)),Pchar(ParamStr(3)),StrToInt(ParamStr(4)));


end.
صفحه‌ها: 1 2 3 4 5
ايران ويج > برنامه نویسی > دلفی > سورس دلفی