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

[پسر خاک]

تغییر مقیاس یک تصویر

[code]

.... /}

 

  private

    function ScalePercentBmp(bitmp: TBitmap; iPercent: Integer): Boolean;

      

{/ .... /}

 

function TForm1.ScalePercentBmp(bitmp: TBitmap;

  iPercent: Integer): Boolean;

var

  TmpBmp: TBitmap;

  ARect: TRect;

  h, w: Real;

  hi, wi: Integer;

begin

  Result := False;

  try

    TmpBmp := TBitmap.Create;

    try

      h := bitmp.Height * (iPercent / 100);

      w := bitmp.Width * (iPercent / 100);

      hi := StrToInt(FormatFloat('#', h)) + bitmp.Height;

      wi := StrToInt(FormatFloat('#', w)) + bitmp.Width;

      TmpBmp.Width := wi;

      TmpBmp.Height := hi;

      ARect := Rect(0, 0, wi, hi);

      TmpBmp.Canvas.StretchDraw(ARect, Bitmp);

      bitmp.Assign(TmpBmp);

    finally

      TmpBmp.Free;

    end;

    Result := True;

  except

    Result := False;

  end;

end;

 

 

// Example:

procedure TForm1.Button1Click(Sender: TObject);

begin

  ScalePercentBmp(Image1.Picture.Bitmap, 33);

end; 

[پسر خاک]

رندر متن یک TrichEdit در یک Canvas

procedure RichEditToCanvas(RichEdit: TRichEdit; Canvas: TCanvas; PixelsPerInch: Integer);

var

  ImageCanvas: TCanvas;

  fmt: TFormatRange;

begin

  ImageCanvas := Canvas;

  with fmt do

  begin

    hdc:= ImageCanvas.Handle;

    hdcTarget:= hdc;

    // rect needs to be specified in twips (1/1440 inch) as unit

    rc:=  Rect(0, 0,

                ImageCanvas.ClipRect.Right * 1440 div PixelsPerInch,

                ImageCanvas.ClipRect.Bottom * 1440 div PixelsPerInch

              );

    rcPage:= rc;

    chrg.cpMin := 0;

    chrg.cpMax := RichEdit.GetTextLen;

  end;

  SetBkMode(ImageCanvas.Handle, TRANSPARENT);

  RichEdit.Perform(EM_FORMATRANGE, 1, Integer(@fmt));

  // next call frees some cached data

  RichEdit.Perform(EM_FORMATRANGE, 0, 0);

end;

 

procedure TForm1.Button1Click(Sender: TObject);

begin

   RichEditToCanvas(RichEdit1, Image1.Canvas, Self.PixelsPerInch);

   Image1.Refresh;

end; 

[پسر خاک]

تغییر وضوح یک Jpg

procedure GetResJpg(JPGFile: string);

const

  BufferSize = 50;

var

  Buffer: string;

  Index: integer;

  FileStream: TFileStream;

  HorzRes, VertRes: Word;

  DP: Byte;

  Measure: string;

begin

  FileStream := TFileStream.Create(JPGFile,

    fmOpenReadWrite);

  try

    SetLength(Buffer, BufferSize);

    FileStream.Read(buffer[1], BufferSize);

    Index := Pos('JFIF' + #$00, buffer);

    if Index > 0 then

    begin

      FileStream.Seek(Index + 6, soFromBeginning);

      FileStream.Read(DP, 1);

      case DP of

        1: Measure := 'DPI'; //Dots Per Inch

        2: Measure := 'DPC'; //Dots Per Cm.

      end;

      FileStream.Read(HorzRes, 2); // x axis

      HorzRes := Swap(HorzRes);

      FileStream.Read(VertRes, 2); // y axis

      VertRes := Swap(VertRes);

    end

  finally

    FileStream.Free;

  end;

end;

 

procedure SetResJpg(name: string; dpix, dpiy: Integer);

const

  BufferSize = 50;

  DPI = 1; //inch

  DPC = 2; //cm

var

  Buffer: string;

  index: INTEGER;

  FileStream: TFileStream;

  xResolution: WORD;

  yResolution: WORD;

  _type: Byte;

begin

  FileStream := TFileStream.Create(name,

    fmOpenReadWrite);

  try

    SetLength(Buffer, BufferSize);

    FileStream.Read(buffer[1], BufferSize);

    index := POS('JFIF' + #$00, buffer);

    if index > 0

      then begin

      FileStream.Seek(index + 6, soFromBeginning);

      _type := DPI;

      FileStream.write(_type, 1);

      xresolution := swap(dpix);

      FileStream.write(xresolution, 2);

      yresolution := swap(dpiy);

      FileStream.write(yresolution, 2);

    end

  finally

    FileStream.Free;

  end;

end; 

[پسر خاک]

اعمال فیلتر Emboss روی یک تصویر

procedure Emboss(ABitmap : TBitmap; AMount : Integer);

var

  x, y, i : integer;

  p1, p2: PByteArray;

begin

  for i := 0 to AMount do

  begin

    for y := 0 to ABitmap.Height-2 do

    begin

      p1 := ABitmap.ScanLine[y];

      p2 := ABitmap.ScanLine[y+1];

      for x := 0 to ABitmap.Width do

      begin

        p1[x*3] := (p1[x*3]+(p2[(x+3)*3&#  93; xor $FF)) shr 1;

        p1[x*3+1] := (p1[x*3+1]+(p2[(x+3)*3  +1] xor $FF)) shr 1;

        p1[x*3+2] := (p1[x*3+1]+(p2[(x+3)*3  +1] xor $FF)) shr 1;

      end;

    end;

  end;

end; 

[پسر خاک]

highlight کردن متن درون Twebbrowser

{/..../}

 

private

  procedure SearchAndHighlightText(aText: string);

      

{/..../}

 

uses mshtml;

 

{/ .... /}

 

 

procedure TForm1.SearchAndHighlightText(aText: string);

var

  tr: IHTMLTxtRange; //TextRange Object

begin

  if not WebBrowser1.Busy then

  begin

    tr := ((WebBrowser1.Document as IHTMLDocument2).body as IHTMLBodyElement).createTextRange;

    //Get a body with IHTMLDocument2 Interface and then a TextRang obj. with IHTMLBodyElement Intf.

 

    while tr.findText(aText, 1, 0) do //while we have result

    begin

      tr.pasteHTML('<span style="background-color: Lime; font-weight: bolder;">' +

        tr.htmlText + '</span>');

      //Set the highlight, now background color will be Lime

      tr.scrollIntoView(True);

      //When IE find a match, we ask to scroll the window... you dont need this...

    end;

  end;

end;

 

// Example:

procedure TForm1.Button1Click(Sender: TObject);

begin

  SearchAndHighlightText('delphi');

end; 

[پسر خاک]

بدست آوردن پروسسهای فعال شبکه

unit PerfInfo;

 

interface

 

uses

  Windows, SysUtils, Classes;

 

type

  TPerfCounter = record

    Counter: Integer;

    Value: TLargeInteger;

  end;

 

  TPerfCounters = Array of TPerfCounter;

 

  TPerfInstance = class

  private

    FName: string;

    FCounters: TPerfCounters;

  public

    property Name: string read FName;

    property Counters: TPerfCounters read FCounters;

  end;

 

  TPerfObject = class

  private

    FList: TList;

    FObjectID: DWORD;

    FMachine: string;

    function GetCount: Integer;

    function GetInstance(Index: Integer): TPerfInstance;

    procedure ReadInstances;

  public

    property ObjectID: DWORD read FObjectID;

    property Item[Index: Integer]: TPerfInstance

      read GetInstance; default;

    property Count: Integer read GetCount;

    constructor Create(const AMachine: string; AObjectID: DWORD);

    destructor Destroy; override;

  end;

 

procedure GetProcesses(const Machine: string; List: TStrings);

 

implementation

 

type

  PPerfDataBlock = ^TPerfDataBlock;

  TPerfDataBlock = record

    Signature: array[0..3] of WCHAR;

    LittleEndian: DWORD;

    Version: DWORD;

    Revision: DWORD;

    TotalByteLength: DWORD;

    HeaderLength: DWORD;

    NumObjectTypes: DWORD;

    DefaultObject: Longint;

    SystemTime: TSystemTime;

    PerfTime: TLargeInteger;

    PerfFreq: TLargeInteger;

    PerfTime100nSec: TLargeInteger;

    SystemNameLength: DWORD;

    SystemNameOffset: DWORD;

  end;

 

  PPerfObjectType = ^TPerfObjectType;

  TPerfObjectType = record

    TotalByteLength: DWORD;

    DefinitionLength: DWORD;

    HeaderLength: DWORD;

    ObjectNameTitleIndex: DWORD;

    ObjectNameTitle: LPWSTR;

    ObjectHelpTitleIndex: DWORD;

    ObjectHelpTitle: LPWSTR;

    DetailLevel: DWORD;

    NumCounters: DWORD;

    DefaultCounter: Longint;

    NumInstances: Longint;

    CodePage: DWORD;

    PerfTime: TLargeInteger;

    PerfFreq: TLargeInteger;

  end;

 

  PPerfCounterDefinition = ^TPerfCounterDefinition;

  TPerfCounterDefinition = record

    ByteLength: DWORD;

    CounterNameTitleIndex: DWORD;

    CounterNameTitle: LPWSTR;

    CounterHelpTitleIndex: DWORD;

    CounterHelpTitle: LPWSTR;

    DefaultScale: Longint;

    DetailLevel: DWORD;

    CounterType: DWORD;

    CounterSize: DWORD;

    CounterOffset: DWORD;

  end;

 

  PPerfInstanceDefinition = ^TPerfInstanceDefinition;

  TPerfInstanceDefinition = record

    ByteLength: DWORD;

    ParentObjectTitleIndex: DWORD;

    ParentObjectInstance: DWORD;

    UniqueID: Longint;

    NameOffset: DWORD;

    NameLength: DWORD;

  end;

 

  PPerfCounterBlock = ^TPerfCounterBlock;

  TPerfCounterBlock = record

    ByteLength: DWORD;

  end;

 

 

{/Navigation helpers/}

 

function FirstObject(PerfData: PPerfDataBlock): PPerfObjectType;

begin

  Result := PPerfObjectType(DWORD(PerfData) + PerfData.HeaderLength);

end;

 

 

function NextObject(PerfObj: PPerfObjectType): PPerfObjectType;

begin

  Result := PPerfObjectType(DWORD(PerfObj) + PerfObj.TotalByteLength);

end;

 

 

function FirstInstance(PerfObj: PPerfObjectType): PPerfInstanceDefinition;

begin

  Result := PPerfInstanceDefinition(DWORD(PerfObj) + PerfObj.DefinitionLength);

end;

 

 

function NextInstance(PerfInst: PPerfInstanceDefinition): PPerfInstanceDefinition;

var

  PerfCntrBlk: PPerfCounterBlock;

begin

  PerfCntrBlk := PPerfCounterBlock(DWORD(PerfInst) + PerfInst.ByteLength);

  Result := PPerfInstanceDefinition(DWORD(PerfCntrBlk&  #41; + PerfCntrBlk.ByteLength);

end;

 

 

function FirstCounter(PerfObj: PPerfObjectType): PPerfCounterDefinition;

begin

  Result := PPerfCounterDefinition(DWORD(PerfObj) + PerfObj.HeaderLength);

end;

 

 

function NextCounter(PerfCntr: PPerfCounterDefinition): PPerfCounterDefinition;

begin

  Result := PPerfCounterDefinition(DWORD(PerfCntr) + PerfCntr.ByteLength);

end;

 

 

{/Registry helpers/}

 

function GetPerformanceKey(const Machine: string): HKey;

var

  s: string;

begin

  Result := 0;

  if Length(Machine) = 0 then

    Result := HKEY_PERFORMANCE_DATA

  else

  begin

    s := Machine;

    if Pos('\\', s) <> 1 then

      s := '\\' + s;

    if RegConnectRegistry(PChar(s), HKEY_PERFORMANCE_DATA, Result) <> ERROR_SUCCESS then

      Result := 0;

  end;

end;

 

 

{/TPerfObject/}

 

constructor TPerfObject.Create(const AMachine: string; AObjectID: DWORD);

begin

  inherited Create;

  FList := TList.Create;

  FMachine := AMachine;

  FObjectID := AObjectID;

  ReadInstances;

end;

 

 

destructor TPerfObject.Destroy;

var

  i: Integer;

begin

  for i := 0 to FList.Count - 1 do

    TPerfInstance(FList[i]).Free;

  FList.Free;

  inherited Destroy;

end;

 

 

function TPerfObject.GetCount: Integer;

begin

  Result := FList.Count;

end;

 

 

function TPerfObject.GetInstance(Index: Integer): TPerfInstance;

begin

  Result := FList[Index];

end;

 

 

procedure TPerfObject.ReadInstances;

var

  PerfData: PPerfDataBlock;

  PerfObj: PPerfObjectType;

  PerfInst: PPerfInstanceDefinition;

  PerfCntr, CurCntr: PPerfCounterDefinition;

  PtrToCntr: PPerfCounterBlock;

  BufferSize: Integer;

  i, j, k: Integer;

  pData: PLargeInteger;

  Key: HKey;

  CurInstance: TPerfInstance;

begin

  for i := 0 to FList.Count - 1 do

    TPerfInstance(FList[i]).Free;

  FList.Clear;

  Key := GetPerformanceKey(FMachine);

  if Key = 0 then Exit;

  PerfData := nil;

  try

    {/Allocate initial buffer for object information/}

    BufferSize := 65536;

    GetMem(PerfData, BufferSize);

    {/retrieve data/}

    while RegQueryValueEx(Key,

      PChar(IntToStr(FObjectID)),  {/Object name/}

      nil, nil, Pointer(PerfData), @BufferSize) = ERROR_MORE_DATA do

    begin

      {/buffer is too small/}

      Inc(BufferSize, 1024);

      ReallocMem(PerfData, BufferSize);

    end;

    RegCloseKey(HKEY_PERFORMANCE_DATA);

    {/Get the first object type/}

    PerfObj := FirstObject(PerfData);

    {/Process all objects/}

    for i := 0 to PerfData.NumObjectTypes - 1 do

    begin

      {/Check for requested object/}

      if PerfObj.ObjectNameTitleIndex = FObjectID then

      begin

        {/Get the first counter/}

        PerfCntr := FirstCounter(PerfObj);

        if PerfObj.NumInstances > 0  then

        begin

          {/Get the first instance/}

          PerfInst := FirstInstance(PerfObj);

          {/Retrieve all instances/}

          for k := 0 to PerfObj.NumInstances - 1 do

          begin

            {/Create entry for instance/}

            CurInstance := TPerfInstance.Create;

            CurInstance.FName := WideCharToString(PWideChar(DWORD(PerfI  nst) +

                                                      PerfInst.NameOffset));

            FList.Add(CurInstance);

            CurCntr := PerfCntr;

            {/Retrieve all counters/}

            SetLength(CurInstance.FCounters, PerfObj.NumCounters);

            for j := 0 to PerfObj.NumCounters - 1 do

            begin

              PtrToCntr := PPerfCounterBlock(DWORD(PerfInst) + PerfInst.ByteLength);

              pData := Pointer(DWORD(PtrToCntr) + CurCntr.CounterOffset);

              {/Add counter to array/}

              CurInstance.FCounters[j].Counter := CurCntr.CounterNameTitleIndex;

              CurInstance.FCounters[j].Value := pData^;

              {/Get the next counter/}

              CurCntr := NextCounter(CurCntr);

            end;

            {/Get the next instance./}

            PerfInst := NextInstance(PerfInst);

          end;

        end;

      end;

      {/Get the next object type/}

      PerfObj := NextObject(PerfObj);

    end;

  finally

    {/Release buffer/}

    FreeMem(PerfData);

    {/Close remote registry handle/}

    if Key <> HKEY_PERFORMANCE_DATA then

      RegCloseKey(Key);

  end;

end;

 

 

procedure GetProcesses(const Machine: string; List: TStrings);

var

  Processes: TPerfObject;

  i, j: Integer;

  ProcessID: DWORD;

begin

  Processes := nil;

  List.Clear;

  try

    Processes := TPerfObject.Create(Machine, 230);  {/230 = Process/}

    for i := 0 to Processes.Count - 1 do

      {/Find process ID/}

      for j := 0 to Length(Processes[i].Counters) - 1 do

        if (Processes[i].Counters[j].Coun  ter = 784) then

        begin

          ProcessID := Processes[i].Counters[j].Value;

          if ProcessID <> 0 then

            List.AddObject(Processes[i].Name, Pointer(ProcessID));

          Break;

        end;

  finally

    Processes.Free;

  end;

end;

 

end. 

[پسر خاک]

ایجاد یک TWebBrowser در RunTime

procedure TForm1.Button1Click(Sender: TObject);

var

 wb: TWebBrowser;

begin

  wb := TWebBrowser.Create(Form1);

  TWinControl(wb).Name := 'MyWebBrowser';

  TWinControl(wb).Parent := Form1;

  wb.Align := alClient;

  // TWinControl(wb).Parent := TabSheet1; ( To put it on a TabSheet )

  wb.Navigate('http://www.swissdelphicenter.ch');

end; 

[پسر خاک]

استفاده از ClientSocket و ServerSocket

unit Unit1;

 

interface

 

uses

  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

  Dialogs, StdCtrls, ComCtrls, ScktComp;

 

type

  TForm1 = class(TForm)

    Clientsocket1: TClientSocket;

    StatusBar1: TStatusBar;

    Button1: TButton;

    Button2: TButton;

    Edit1: TEdit;

    Label1: TLabel;

    Button3: TButton;

    CheckBox1: TCheckBox;

    Checkbox2: TCheckBox;

    procedure Button1Click(Sender : TObject);

    procedure Button2Click(Sender : TObject);

    procedure Clientsocket1Error(Sender : TObject; Socket : TCustomWinSocket;

      ErrorEvent : TErrorEvent; var ErrorCode : integer);

    procedure Clientsocket1Disconnect(Sender : TObject;

      Socket : TCustomWinSocket);

    procedure Clientsocket1Connect(Sender : TObject;

      Socket : TCustomWinSocket);

    procedure Button3Click(Sender : TObject);

    procedure FormClose(Sender : TObject; var Action : TCloseAction);

    procedure FormDestroy(Sender : TObject);

  private

    {/ Private declarations /}

  public

    {/ Public declarations /}

  end;

 

var

  Form1 : TForm1;

 

implementation

 

{/$R *.dfm/}

 

procedure TForm1.Button1Click(Sender : TObject);

begin

  Clientsocket1.Active := True;

end;

 

procedure TForm1.Button2Click(Sender : TObject);

begin

  Clientsocket1.Active := False;

end;

 

procedure TForm1.Clientsocket1Error(Sender : TObject;

  Socket : TCustomWinSocket; ErrorEvent : TErrorEvent;

  var ErrorCode : integer);

begin

  errorcode := 0;

  StatusBar1.SimpleText := 'Error';

end;

 

procedure TForm1.Clientsocket1Disconnect(Sender : TObject;

  Socket : TCustomWinSocket);

begin

  StatusBar1.SimpleText := 'Disconnect';

end;

 

procedure TForm1.Clientsocket1Connect(Sender : TObject;

  Socket : TCustomWinSocket);

begin

  StatusBar1.SimpleText := Clientsocket1.Address;

end;

 

procedure TForm1.Button3Click(Sender : TObject);

var

  ukaz : string;

  orders : string;

  Text : string;

  box : string;

begin

  ukaz := edit1.Text;

  Clientsocket1.Socket.SendText(ukaz);

  if checkbox1.Checked = True then

  begin

    orders := 'power';

    Clientsocket1.Socket.SendText(orders);

  end;

  if Checkbox2.Checked = True then

  begin

    Text := 'reset';

    Clientsocket1.Socket.SendText(Text);

  end;

end;

 

procedure TForm1.FormClose(Sender : TObject; var Action : TCloseAction);

begin

  Clientsocket1.Active := False;

end;

 

procedure TForm1.FormDestroy(Sender : TObject);

begin

  Clientsocket1.Active := False;

end;

 

end.

 

 

// Client Program

 

unit Unit1;

 

interface

 

uses

  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

  Dialogs, ScktComp, StdCtrls, ShellApi;

 

type

  TForm1 = class(TForm)

    Label1: TLabel;

    Serversocket1: TServerSocket;

    procedure FormClose(Sender : TObject; var Action : TCloseAction);

    procedure FormDestroy(Sender : TObject);

    procedure FormCreate(Sender : TObject);

    procedure Serversocket1ClientError(Sender : TObject;

      Socket : TCustomWinSocket; ErrorEvent : TErrorEvent;

      var ErrorCode : integer);

    procedure Serversocket1ClientRead(Sender : TObject;

      Socket : TCustomWinSocket);

  private

    {/ Private declarations /}

  public

    {/ Public declarations /}

  end;

 

var

  Form1 : TForm1;

 

implementation

 

{/$R *.dfm/}

 

procedure TForm1.FormClose(Sender : TObject; var Action : TCloseAction);

begin

  Serversocket1.Active := False;

end;

 

procedure TForm1.FormDestroy(Sender : TObject);

begin

  Serversocket1.Active := False;

end;

 

procedure TForm1.FormCreate(Sender : TObject);

begin

  Serversocket1.Active := True;

end;

 

procedure TForm1.Serversocket1ClientError(Sender : TObject;

  Socket : TCustomWinSocket; ErrorEvent : TErrorEvent;

  var ErrorCode : integer);

begin

  errorcode := 0;

end;

 

procedure TForm1.Serversocket1ClientRead(Sender : TObject;

  Socket : TCustomWinSocket);

var

  ukaz : string;

  orders : string;

  Text : string;

  box : string;

begin

  ukaz := socket.ReceiveText;

  label1.Caption := 'reciving...';

  ShellExecute(Handle, 'open', PChar(ukaz), PChar(''), nil, sw_show);

  Text := socket.ReceiveText;

  orders := socket.ReceiveText;

  if orders = 'power' then

  begin

    ShellExecute(Handle, 'open', PChar('shutdown.exe'), PChar('-s'), nil, sw_show);

    Application.MessageBox('You will be turned off', 'Warning', mb_iconexclamation);

    Serversocket1.Active := False;

    Form1.Close;

  end;

  if Text = 'reset' then

  begin

    ShellExecute(Handle, 'open', PChar('shutdown.exe'), PChar('-r'), nil, sw_show);

    Application.MessageBox('You will be reset', 'Warning', mb_iconexclamation);

    Serversocket1.Active := False;

    Form1.Close;

  end;

end;

 

 

end. 

[پسر خاک]

بدست آوردن لیست کاربران موجود در شبکه Remote

unit GetUser;

 

interface

 

uses

  Windows

    , Messages

    , SysUtils

    , Dialogs;

 

type

  TServerBrowseDialogA0 = function(hwnd: HWND; pchBuffer: Pointer;

    cchBufSize: DWORD): bool;

  stdcall;

  ATStrings = array of string;

 

 

procedure Server(const ServerName: string);

function ShowServerDialog(AHandle: THandle): string;

 

 

implementation

 

uses Client, ClientSkin;

 

procedure Server(const ServerName: string);

const

  MAX_NAME_STRING = 1024;

var 

  userName, domainName: array[0..MAX_NAME_STRING] of Char;

  subKeyName: array[0..MAX_PATH] of Char;

  NIL_HANDLE: Integer absolute 0;

  Result: ATStrings;

  subKeyNameSize: DWORD;

  Index: DWORD;

  userNameSize: DWORD;

  domainNameSize: DWORD;

  lastWriteTime: FILETIME;

  usersKey: HKEY;

  sid: PSID;

  sidType: SID_NAME_USE;

  authority: SID_IDENTIFIER_AUTHORITY;

  subAuthorityCount: BYTE;

  authorityVal: DWORD;

  revision: DWORD;

  subAuthorityVal: array[0..7] of DWORD;

 

 

  function getvals(s: string): Integer;

  var 

    i, j, k, l: integer;

    tmp: string;

  begin

    Delete(s, 1, 2);

    j   := Pos('-', s);

    tmp := Copy(s, 1, j - 1);

    val(tmp, revision, k);

    Delete(s, 1, j);

    j := Pos('-', s);

    tmp := Copy(s, 1, j - 1);

    val('$' + tmp, authorityVal, k);

    Delete(s, 1, j);

    i := 2;

    s := s + '-';

    for l := 0 to 7 do 

    begin

      j := Pos('-', s);

      if j > 0 then 

      begin

        tmp := Copy(s, 1, j - 1);

        val(tmp, subAuthorityVal[l], k);

        Delete(s, 1, j);

        Inc(i);

      end 

      else 

        break;

    end;

    Result := i;

  end;

begin

  setlength(Result, 0);

  revision     := 0;

  authorityVal := 0;

  FillChar(subAuthorityVal, SizeOf(subAuthorityVal), #0);

  FillChar(userName, SizeOf(userName), #0);

  FillChar(domainName, SizeOf(domainName), #0);

  FillChar(subKeyName, SizeOf(subKeyName), #0);

  if ServerName <> '' then 

  begin

    usersKey := 0;

    if (RegConnectRegistry(PChar(ServerName&#  41;, HKEY_USERS, usersKey) <> 0) then

      Exit;

  end 

  else 

  begin

    if (RegOpenKey(HKEY_USERS, nil, usersKey) <> ERROR_SUCCESS) then

      Exit;

  end;

  Index          := 0;

  subKeyNameSize := SizeOf(subKeyName);

  while (RegEnumKeyEx(usersKey, Index, subKeyName, subKeyNameSize,

    nil, nil, nil, @lastWriteTime) = ERROR_SUCCESS) do 

  begin

    if (lstrcmpi(subKeyName, '.default') <> 0) and (Pos('Classes', string(subKeyName)) = 0) then 

    begin

      subAuthorityCount := getvals(subKeyName);

      if (subAuthorityCount >= 3) then 

      begin

        subAuthorityCount := subAuthorityCount - 2;

        if (subAuthorityCount < 2) then subAuthorityCount := 2;

        authority.Value[5] := PByte(@authorityVal)^;

        authority.Value[4] := PByte(DWORD(@authorityVal) + 1)^;

        authority.Value[3] := PByte(DWORD(@authorityVal) + 2)^;

        authority.Value[2] := PByte(DWORD(@authorityVal) + 3)^;

        authority.Value[1] := 0;

        authority.Value[0] := 0;

        sid := nil;

        userNameSize := MAX_NAME_STRING;

        domainNameSize := MAX_NAME_STRING;

        if AllocateAndInitializeSid(authority, subAuthorityCount,

          subAuthorityVal[0], subAuthorityVal[1], subAuthorityVal[2],

          subAuthorityVal[3], subAuthorityVal[4], subAuthorityVal[5],

          subAuthorityVal[6], subAuthorityVal[7], sid) then 

        begin

          if LookupAccountSid(PChar(ServerName), sid, userName, userNameSize,

            domainName, domainNameSize, sidType) then 

          begin

            setlength(Result, Length(Result) + 1);

            Result[Length(Result) - 1] := string(domainName) + '\' + string(userName);

 

            // Hier kann das Ziel eingetragen werden

            Form1.label2.Caption := string(userName);

            form2.label1.Caption := string(userName);

          end;

        end;

        if Assigned(sid) then FreeSid(sid);

      end;

    end;

    subKeyNameSize := SizeOf(subKeyName);

    Inc(Index);

  end;

  RegCloseKey(usersKey);

end;

 

function ShowServerDialog(AHandle: THandle): string;

var

  ServerBrowseDialogA0: TServerBrowseDialogA0;

  LANMAN_DLL: DWORD;

  buffer: array[0..1024] of char;

  bLoadLib: Boolean;

begin

  bLoadLib := False;

  LANMAN_DLL := GetModuleHandle('NTLANMAN.DLL');

  if LANMAN_DLL = 0 then

  begin

    LANMAN_DLL := LoadLibrary('NTLANMAN.DLL');

    bLoadLib := True;

  end;

  if LANMAN_DLL <> 0 then

  begin @ServerBrowseDialogA0 := GetProcAddress(LANMAN_DLL, 'ServerBrowseDialogA0');

    DialogBox(HInstance, MAKEINTRESOURCE(101), AHandle, nil);

    ServerBrowseDialogA0(AHandle, @buffer, 1024);

    if buffer[0] = '\' then

    begin

      Result := buffer;

    end;

    if bLoadLib = True then

      FreeLibrary(LANMAN_DLL);

  end;

end;

 

 

end. 

[پسر خاک]

چاپ یک صفحه در TwebBrowser

procedure TForm1.Button1Click(Sender: TObject);

begin

  WebBrowser1.Navigate('http://www.SwissDelphiCenter.com');

end;

 

// Print without Printer Dialog

// Drucken ohne Druckerauswahldialog

 

procedure TForm1.Button2Click(Sender: TObject);

var

  vaIn, vaOut: OleVariant;

begin

  WebBrowser1.ControlInterface.ExecWB(OLECMDID_P  RINT, OLECMDEXECOPT_DONTPROMPTUSER,

    vaIn, vaOut);

end;

 

// Print with Printer Dialog

// Drucken mit Druckerauswahldialog

 

procedure TForm1.Button3Click(Sender: TObject);

var

  vaIn, vaOut: OleVariant;

begin

  WebBrowser1.ControlInterface.ExecWB(OLECMDID_P  RINT, OLECMDEXECOPT_PROMPTUSER,

    vaIn, vaOut);

end;

 

// Print Preview

// Druckvorschau

 

procedure TForm1.Button4Click(Sender: TObject);

var

  vaIn, vaOut: OleVariant;

begin

  WebBrowser1.ControlInterface.ExecWB(OLECMDID_P  RINTPREVIEW,

    OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);

end;

 

// Page Setup Dialog

// Seite einrichten Dialog

 

procedure TForm1.Button5Click(Sender: TObject);

var

  vaIn, vaOut: OleVariant;

begin

  WebBrowser1.ControlInterface.ExecWB(OLECMDID_P  AGESETUP, OLECMDEXECOPT_PROMPTUSER,

    vaIn, vaOut);

end; 

[پسر خاک]

انتخاب یک کامپیوتر در شبکه

type

  TServerBrowseDialogA0 = function(hwnd: HWND; pchBuffer: Pointer; cchBufSize: DWORD): bool;  

  stdcall;





function ShowServerDialog(AHandle: THandle): string;

var

  ServerBrowseDialogA0: TServerBrowseDialogA0;

  LANMAN_DLL: DWORD;

  buffer: array[0..1024] of char;

  bLoadLib: Boolean;

begin

  LANMAN_DLL := GetModuleHandle('NTLANMAN.DLL');

  if LANMAN_DLL = 0 then

  begin

    LANMAN_DLL := LoadLibrary('NTLANMAN.DLL');

    bLoadLib := True;

  end;

  if LANMAN_DLL <> 0 then

  begin @ServerBrowseDialogA0 := GetProcAddress(LANMAN_DLL, 'ServerBrowseDialogA0');

    DialogBox(HInstance, MAKEINTRESOURCE(101), AHandle, nil);

    ServerBrowseDialogA0(AHandle, @buffer, 1024);

    if buffer[0] = '\' then

    begin

      Result := buffer;

    end;

    if bLoadLib then

      FreeLibrary(LANMAN_DLL);

  end;

end;



procedure TForm1.Button1Click(Sender: TObject);

begin

  label1.Caption := ShowServerDialog(Form1.Handle);

end;

[پسر خاک]

لود کردن یک کد html بصورت مستقیم در TWebBrowser

uses

  ActiveX;

 

procedure WB_LoadHTML(WebBrowser: TWebBrowser; HTMLCode: string);

var

  sl: TStringList;

  ms: TMemoryStream;

begin

  WebBrowser.Navigate('about:blank');

  while WebBrowser.ReadyState < READYSTATE_INTERACTIVE do

   Application.ProcessMessages;

 

  if Assigned(WebBrowser.Document) then

  begin

    sl := TStringList.Create;

    try

      ms := TMemoryStream.Create;

      try

        sl.Text := HTMLCode;

        sl.SaveToStream(ms);

        ms.Seek(0, 0);

        (WebBrowser.Document as IPersistStreamInit).Load(TStreamAdapter.Cr  eate(ms));

      finally

        ms.Free;

      end;

    finally

      sl.Free;

    end;

  end;

end;

 

procedure TForm1.Button1Click(Sender: TObject);

begin

  WB_LoadHTML(WebBrowser1,'SwissDelphiCenter'&#4  1;;

end; 

[پسر خاک]

ارسال پیام در ICQ

var

  Form1: TForm1;

  csend: string;

 

implementation

 

{/$R *.dfm/}

 

procedure TForm1.Button1Click(Sender: TObject);

begin

  cSend := 'POST http://wwp.icq.com/scripts/WWPMsg.dll HTTP/2.0' + chr(13) + chr(10);

  cSend := cSend + 'Referer: http://wwp.mirabilis.com' + chr(13) + chr(10);

  cSend := cSend + 'User-Agent: Mozilla/4.06 (Win95; I)' + chr(13) + chr(10);

  cSend := cSend + 'Connection: Keep-Alive' + chr(13) + chr(10);

  cSend := cSend + 'Host: wwp.mirabilis.com:80' + chr(13) + chr(10);

  cSend := cSend + 'Content-type: application/x-www-form-urlencoded' + chr(13) + chr(10);

  cSend := cSend + 'Content-length:8000' + chr(13) + chr(10);

  cSend := cSend + 'Accept: image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, */*' +

    chr(13) + chr(10) + chr(13) + chr(10);

  cSend := cSend + 'from=' + edit1.Text + ' &fromemail=' + edit2.Text +

    ' &fromicq:110206786' + ' &body=' + memo1.Text + ' &to=' + edit3.Text + '&Send=';

  clientsocket1.Active := True;

end;

 

procedure TForm1.ClientSocket1Connect(Sender: TObject;

  Socket: TCustomWinSocket);

begin

  clientsocket1.Socket.SendText(csend);

  clientsocket1.Active := False;

end; 

[پسر خاک]

تبدیل یک فایل CSV به XML

procedure CSVToXML(const csvfilename, xmlfilename: string;

  const aSeparator: Char;

  const aRootNodeName: string;

  const columnnames: TStrings = nil;

  const onProgress: TProgressNotification = nil);

 

  function DoProgress(currentline, totallines: Integer): Boolean;

  begin

    if Assigned(onProgress) then

      Result := onProgress(currentline, totallines)

    else

      Result := true;

  end;

 

  procedure WriteDataline(const line: string; header: TStringlist; xml: TXMLGenerator);

  var

    elements: TStringlist;

    i, max: Integer;

  begin

    elements := TStringlist.Create;

    try

      elements.Delimiter := aSeparator;

      elements.Delimitedtext := line;

      if elements.count > header.count then

        max := header.count

      else

        max := elements.count;

      for i := 0 to max - 1 do begin

        xml.StartTag(header[i]);

        xml.AddData(elements[i]);

        xml.StopTag;

      end; {/ For /}

    finally

      elements.Free;

    end;

  end;

 

  procedure WriteData(data: TStringlist; xml: TXMLGenerator);

  var

    header: TStringlist;

    firstline: Integer;

    i: Integer;

  begin

    header := Tstringlist.Create;

    try

      firstline := 0;

      if assigned(columnnames) then

        header.Assign(columnnames)

      else begin

        header.Delimiter := aSeparator;

        header.DelimitedText := data[0];

        firstline := 1;

      end; {/ Else /}

      for i := firstline to data.count - 1 do begin

        WriteDataline(data[i], header, xml);

        if not DoProgress(i, data.count) then

          Break;

      end; {/ For /}

    finally

      header.Free;

    end;

  end;

 

  procedure SaveStringToFile(const S, filename: string);

  var

    fs: TFilestream;

  begin

    fs := TFileStream.Create(filename, fmCreate);

    try

      if Length(S) > 0 then

        fs.WriteBuffer(S[1], Length(S));

    finally

      fs.free

    end;

  end; {/ SaveStringToFile /}

 

 

var

  xml: TXMLGenerator; // from xml_generator unit by Berend de Boers

  datafile: Tstringlist;

begin {/ CSVToXML /}

  if not FileExists(csvfilename) then

    raise Exception.CreateFmt('Input file %s not found', [csvfilename]);

  datafile := Tstringlist.Create;

  try

    datafile.LoadfromFile(csvfilename);

    xml := TXMLGenerator.CreateWithEncoding(16 * 1024, ebarnamenevisO_8859_1);

    try

      xml.StartTag(aRootNodeName);

      if datafile.count > 0 then

        WriteData(datafile, xml);

      xml.StopTag;

      SaveStringToFile(xml.AsLatin1, xmlfilename);

    finally

      xml.Free;

    end;

  finally

    datafile.free;

  end;

end; {/ CSVToXML /} 

[پسر خاک]

لیست تمام فایلهای موجود در یک دایرکتوری

procedure ListFileDir(Path: string; FileList: TStrings);

var

  SR: TSearchRec;

begin

  if FindFirst(Path + '*.*', faAnyFile, SR) = 0 then

  begin

    repeat

      if (SR.Attr <> faDirectory) then

      begin

        FileList.Add(SR.Name);

      end;

    until FindNext(SR) <> 0;

    FindClose(SR);

  end;

end;

 

procedure TForm1.Button1Click(Sender: TObject);

begin

  ListFileDir('C:\WINDOWS\', ListBox1.Items);

end; 

[پسر خاک]

نصب یک فایل INF در دلفی

uses

  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 /}

 

// Example:

 

procedure TForm1.Button1Click(Sender: TObject);

begin

  InstallINF('C:\XYZ.inf', 0);

end; 

[پسر خاک]

دسترسی به ListBox از طریق API

function LB_GetItemCount(hListBox: THandle): Integer;

begin

  Result := SendMessage(hListBox, LB_GETCOUNT, 0, 0);

end;

 

// Delete a string in a ListBox

// Einen String in einer ListBox löschen

 

procedure LB_DeleteItem(hListBox: THandle; Index: Integer);

begin

  SendMessage(hListBox, LB_DELETESTRING, Index, 0);

end;

 

// Retrieve the selected item from a ListBox

// Gibt den Text des markiertes Items einer ListBox zurück

 

function LB_GetSelectedItem(hListBox: THandle): string;

var

  Index, len: Integer;

  s: string;

  buffer: PChar;

begin

  Index := SendMessage(hListBox, LB_GETCURSEL, 0, 0);

  len := SendMessage(hListBox, LB_GETTEXTLEN, wParam(Index), 0);

  GetMem(buffer, len + 1);

  SendMessage(hListBox, LB_GETTEXT, wParam(Index), lParam(buffer));

  SetString(s, buffer, len);

  FreeMem(buffer);

  Result := IntToStr(Index) + ' : ' + s;

end;

 

// Example, Beispiel:

 

procedure TForm1.Button1Click(Sender: TObject);

var

  hListBox: THandle;

begin

  hListBox := {/.../}; // listbox handle

  ListBox1.Items.Text := LB_GetSelectedItem(hListBox);

end;

 

// Retrieve a string from a ListBox

// Gibt den Text eines bestimmten Items einer ListBox zurück

 

function LB_GetListBoxItem(hWnd: Hwnd; LbItem: Integer): string;

var

  l: Integer;

  buffer: PChar;

begin

  l := SendMessage(hWnd, LB_GETTEXTLEN, LbItem, 0);

  GetMem(buffer, l + 1);

  SendMessage(hWnd, LB_GETTEXT, LbItem, Integer(buffer));

  Result := StrPas(buffer);

  FreeMem(buffer);

end;

 

// Example, Beispiel:

 

procedure TForm1.Button2Click(Sender: TObject);

var

  hListBox: THandle;

begin

  hListBox := {/.../}; // listbox handle

  ListBox1.Items.Text := LB_GetListBoxItem(hListBox, 2);

end;

 

// Gibt den gesamten Text einer ListBox zurück

// Retrieve all listbox items

 

function LB_GetAllItems(hWnd: Hwnd; sl: TStrings): string;

var

  RetBuffer: string;

  i, x, y: Integer;

begin

  x := SendMessage(hWnd, LB_GETCOUNT, 0, 0);

  for i := 0 to x - 1 do

  begin

    y := SendMessage(hWnd, LB_GETTEXTLEN, i, 0);

    SetLength(RetBuffer, y);

    SendMessage(hWnd, LB_GETTEXT, i, lParam(PChar(RetBuffer)));

    sl.Add(RetBuffer);

  end;

end;

 

// Example, Beispiel:

 

procedure TForm1.Button3Click(Sender: TObject);

var

  sl: TStringList;

  ListBox_Handle: THandle;

begin

  hListBox := {/.../}; // listbox handle

  sl := TStringList.Create;

  try

    LB_GetAllItems(ListBox_Handle, sl);

  finally

    ListBox1.Items.Text := sl.Text;

    sl.Free;

  end;

end; 

[پسر خاک]

لیست تمام زیرپوشه های یک پوشه اصلی

procedure GetSubDirs(const sRootDir: string; slt: TStrings);

var

  srSearch: TSearchRec;

  sSearchPath: string;

  sltSub: TStrings;

  i: Integer;

begin

  sltSub := TStringList.Create;

  slt.BeginUpdate;

  try

    sSearchPath := AddDirSeparator(sRootDir);

    if FindFirst(sSearchPath + '*', faDirectory, srSearch) = 0 then

      repeat

        if ((srSearch.Attr and faDirectory) = faDirectory) and

          (srSearch.Name <> '.') and

          (srSearch.Name <> '..') then

        begin

          slt.Add(sSearchPath + srSearch.Name);

          sltSub.Add(sSearchPath + srSearch.Name);

        end;

      until (FindNext(srSearch) <> 0);

 

    FindClose(srSearch);

 

    for i := 0 to sltSub.Count - 1 do

      GetSubDirs(sltSub.Strings[i], slt);

  finally

    slt.EndUpdate;

    FreeAndNil(sltSub);

  end;

end; 

[پسر خاک]

جایگزینی یک متن درون TextFile

procedure FileReplaceString(const FileName, searchstring, replacestring: string);

var

  fs: TFileStream;

  S: string;

begin

  fs := TFileStream.Create(FileName, fmOpenread or fmShareDenyNone);

  try

    SetLength(S, fs.Size);

    fs.ReadBuffer(S[1], fs.Size);

  finally

    fs.Free;

  end;

  S  := StringReplace(S, SearchString, replaceString, [rfReplaceAll, rfIgnoreCase]);

  fs := TFileStream.Create(FileName, fmCreate);

  try

    fs.WriteBuffer(S[1], Length(S));

  finally

    fs.Free;

  end;

end; 

[پسر خاک]

تغییر نام یک دایرکتوری

uses

  ShellApi;

 

procedure RenameDir(DirFrom, DirTo: string);

var

  shellinfo: TSHFileOpStruct;

begin

  with shellinfo do

  begin

    Wnd    := 0;

    wFunc  := FO_RENAME;

    pFrom  := PChar(DirFrom);

    pTo    := PChar(DirTo);

    fFlags := FOF_FILESONLY or FOF_ALLOWUNDO or

              FOF_SILENT or FOF_NOCONFIRMATION;

  end;

  SHFileOperation(shellinfo);

end;

 

 

procedure TForm1.Button1Click(Sender: TObject);

begin

  RenameDir('C:\Dir1', 'C:\Dir2');

end; 

[پسر خاک]

خواندن یک فایل table-textfile درون یک StringGrid

procedure ReadTabFile(FN: TFileName; FieldSeparator: Char; SG: TStringGrid);

var

  i: Integer;

  S: string;

  T: string;

  Colonne, ligne: Integer;

  Les_Strings: TStringList;

  CountCols: Integer;

  CountLines: Integer;

  TabPos: Integer;

  StartPos: Integer;

  InitialCol: Integer;

begin

  Les_Strings := TStringList.Create;

  try

    // Load the file, Datei laden

    Les_Strings.LoadFromFile(FN);

 

    // Get the number of rows, Anzahl der Zeilen ermitteln

    CountLines := Les_Strings.Count + SG.FixedRows;

 

    // Get the number of columns, Anzahl der Spalten ermitteln

    T := Les_Strings[0];

    for i := 0 to Length(T) - 1 do Inc(CountCols, Ord(IsDelimiter(FieldSeparator, T, i)));

    Inc(CountCols, 1 + SG.FixedCols);

 

    // Adjust Grid dimensions, Anpassung der Grid-Größe

    if CountLines > SG.RowCount then SG.RowCount := CountLines;

    if CountCols > SG.ColCount then SG.ColCount := CountCols;

 

    // Initialisierung

    InitialCol := SG.FixedCols - 1;

    Ligne := SG.FixedRows - 1;

 

    // Iterate through all rows of the table

    // Schleife durch allen Zeilen der Tabelle

    for i := 0 to Les_Strings.Count - 1 do

    begin

      Colonne := InitialCol;

      Inc(Ligne);

      StartPos := 1;

      S := Les_Strings[i];

      TabPos := Pos(FieldSeparator, S);

      repeat

        Inc(Colonne);

        SG.Cells[Colonne, Ligne] := Copy(S, StartPos, TabPos - 1);

        S := Copy(S, TabPos + 1, 999);

        TabPos := Pos(FieldSeparator, S);

      until TabPos = 0;

    end;

  finally

    Les_Strings.Free;

  end;

end;

 

// Example, Beispiel:

 

procedure TForm1.Button1Click(Sender: TObject);

begin

  Screen.Cursor := crHourGlass;

  // Open tab-delimited files

  ReadTabFile('C:\TEST.TXT', #9, StringGrid1);

  Screen.Cursor := crDefault;

end; 

[پسر خاک]

استفاده از توابع shell برای copy/move یک فایل

uses

  ShellApi;

 

procedure ShellFileOperation(fromFile: string; toFile: string; Flags: Integer);

var

  shellinfo: TSHFileOpStructA;

begin

  with shellinfo do

  begin

    wnd   := Application.Handle;

    wFunc := Flags;

    pFrom := PChar(fromFile);

    pTo   := PChar(toFile);

  end;

  SHFileOperation(shellinfo);

end;

 

 

 

 

procedure TForm1.Button1Click(Sender: TObject);

begin

  ShellFileOperation('c:\afile.txt', 'd:\afile2.txt', FO_COPY);

  // To Move a file: FO_MOVE

end; 

[پسر خاک]

اضافه کردن اطلاعات به یک فایل EXE

function AttachToFile(const AFileName: string; MemoryStream: TMemoryStream): Boolean;

var

  aStream: TFileStream;

  iSize: Integer;

begin

  Result := False;

  if not FileExists(AFileName) then

    Exit;

  try

    aStream := TFileStream.Create(AFileName, fmOpenWrite or fmShareDenyWrite);

    MemoryStream.Seek(0, soFromBeginning);

    // seek to end of File

    // ans Ende der Datei Seeken

    aStream.Seek(0, soFromEnd);

    // copy data from MemoryStream

    // Daten vom MemoryStream kopieren

    aStream.CopyFrom(MemoryStream, 0);

    // save Stream-Size

    // die Streamgröße speichern

    iSize := MemoryStream.Size + SizeOf(Integer);

    aStream.Write(iSize, SizeOf(iSize));

  finally

    aStream.Free;

  end;

  Result := True;

end;

 

function LoadFromFile(const AFileName: string; MemoryStream: TMemoryStream): Boolean;

var

  aStream: TFileStream;

  iSize: Integer;

begin

  Result := False;

  if not FileExists(AFileName) then

    Exit;

 

  try

    aStream := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyWrite);

    // seek to position where Stream-Size is saved

    // zur Position seeken wo Streamgröße gespeichert

    aStream.Seek(-SizeOf(Integer), soFromEnd);

    aStream.Read(iSize, SizeOf(iSize));

    if iSize > aStream.Size then

    begin

      aStream.Free;

      Exit;

    end;

    // seek to position where data is saved

    // zur Position seeken an der die Daten abgelegt sind

    aStream.Seek(-iSize, soFromEnd);

    MemoryStream.SetSize(iSize - SizeOf(Integer));

    MemoryStream.CopyFrom(aStream, iSize - SizeOf(iSize));

    MemoryStream.Seek(0, soFromBeginning);

  finally

    aStream.Free;

  end;

  Result := True;

end;

 

procedure TForm1.SaveClick(Sender: TObject);

var

  aStream: TMemoryStream;

begin

  aStream := TMemoryStream.Create;

  Memo1.Lines.SaveToStream(aStream);

  AttachToFile('Test.exe', aStream);

  aStream.Free;

end;

 

procedure TForm1.LoadClick(Sender: TObject);

var

  aStream: TMemoryStream;

begin

  aStream := TMemoryStream.Create;

  LoadFromFile('Test.exe', aStream);

  Memo1.Lines.LoadFromStream(aStream);

  aStream.Free;

end; 

[پسر خاک]

پاک کردن یک فایل درون پوشه Document

uses

  ShlObj;

 

procedure TForm1.Button1Click(Sender: TObject);

begin

  SHAddToRecentDocs(0, nil);

end; 

[پسر خاک]

توابع مفید جهت کار با Stream

unit ClassUtils;

 

interface

 

uses

  SysUtils,

  Classes;

 

{/: Write a string to the stream

   @param Stream is the TStream to write to.

   @param s is the string to write

   @returns the number of bytes written. /}

function Writestring(_Stream: TStream; const _s: string): Integer;

 

{/: Write a string to the stream appending CRLF

   @param Stream is the TStream to write to.

   @param s is the string to write

   @returns the number of bytes written. /}

function WritestringLn(_Stream: TStream; const _s: string): Integer;

 

{/: Write formatted data to the stream appending CRLF

   @param Stream is the TStream to write to.

   @param Format is a format string as used in sysutils.format

   @param Args is an array of const as used in sysutils.format

   @returns the number of bytes written. /}

function WriteFmtLn(_Stream: TStream; const _Format: string;

  _Args: array of const): Integer;

 

implementation

 

function Writestring(_Stream: TStream; const _s: string): Integer;

begin

  Result := _Stream.Write(PChar(_s)^, Length(_s));

end;

 

function WritestringLn(_Stream: TStream; const _s: string): Integer;

begin

  Result := Writestring(_Stream, _s);

  Result := Result + Writestring(_Stream, #13#10);

end;

 

function WriteFmtLn(_Stream: TStream; const _Format: string;

  _Args: array of const): Integer;

begin

  Result := WritestringLn(_Stream, Format(_Format, _Args));

end; 

[پسر خاک]

تبدیل OEM به ANSI

procedure ConvertFile(const FileName: string; fromCodepage: Integer);

var

  ms: TMemoryStream;

begin

  if getOEMCP <> fromCodepage then

    raise Exception.Create('ConvertFile: Codepage doesn't match!');

  ms := TMemoryStream.Create;

  try

    ms.LoadFromFile(FileName);

    // make backup

    ms.Position := 0;

    ms.SaveToFile(ChangeFileExt(FileName, '.BAK'));

    // convert text

    OEMToCharBuff(ms.Memory, ms.Memory, ms.Size);

    // save back to original file

    ms.Position := 0;

    ms.SaveToFile(FileName);

  finally

    ms.Free;

  end;

end;

[پسر خاک]

ثبت خروجی یک برنامه DOS

function CreateDOSProcessRedirected(const CommandLine, InputFile, OutputFile,

  ErrMsg: string): Boolean;

const

  ROUTINE_ID = '[function: CreateDOSProcessRedirected ]';

var

  OldCursor: TCursor;

  pCommandLine: array[0..MAX_PATH] of Char;

  pInputFile, pOutPutFile: array[0..MAX_PATH] of Char;

  StartupInfo: TStartupInfo;

  ProcessInfo: TProcessInformation;

  SecAtrrs: TSecurityAttributes;

  hAppProcess, hAppThread, hInputFile, hOutputFile: THandle;

begin

  Result := False;

 

  {/ check for InputFile existence /}

  if not FileExists(InputFile) then

    raise Exception.CreateFmt(ROUTINE_ID + #10 + #10 +

      'Input file * %s *' + #10 +

      'does not exist' + #10 + #10 +

      ErrMsg, [InputFile]);

 

  {/ save the cursor /}

  OldCursor     := Screen.Cursor;

  Screen.Cursor := crHourglass;

 

  {/ copy the parameter Pascal strings to null terminated strings /}

  StrPCopy(pCommandLine, CommandLine);

  StrPCopy(pInputFile, InputFile);

  StrPCopy(pOutPutFile, OutputFile);

 

  try

 

    {/ prepare SecAtrrs structure for the CreateFile calls

      This SecAttrs structure is needed in this case because

      we want the returned handle can be inherited by child process

      This is true when running under WinNT.

      As for Win95 the documentation is quite ambiguous /}

    FillChar(SecAtrrs, SizeOf(SecAtrrs), #0);

    SecAtrrs.nLength        := SizeOf(SecAtrrs);

    SecAtrrs.lpSecurityDescriptor := nil;

    SecAtrrs.bInheritHandle := True;

 

    {/ create the appropriate handle for the input file /}

    hInputFile := CreateFile(pInputFile,

      {/ pointer to name of the file /}

      GENERIC_READ or GENERIC_WRITE,

      {/ access (read-write) mode /}

      FILE_SHARE_READ or FILE_SHARE_WRITE,

      {/ share mode /} @SecAtrrs,                             {/ pointer to security attributes /}

      OPEN_ALWAYS,                           {/ how to create /}

      FILE_ATTRIBUTE_TEMPORARY,              {/ file attributes /}

      0);                                   {/ handle to file with attributes to copy /}

 

 

    {/ is hInputFile a valid handle? /}

    if hInputFile = INVALID_HANDLE_VALUE then

      raise Exception.CreateFmt(ROUTINE_ID + #10 + #10 +

        'WinApi function CreateFile returned an invalid handle value' +

        #10 +

        'for the input file * %s *' + #10 + #10 +

        ErrMsg, [InputFile]);

 

    {/ create the appropriate handle for the output file /}

    hOutputFile := CreateFile(pOutPutFile,

      {/ pointer to name of the file /}

      GENERIC_READ or GENERIC_WRITE,

      {/ access (read-write) mode /}

      FILE_SHARE_READ or FILE_SHARE_WRITE,

      {/ share mode /} @SecAtrrs,                             {/ pointer to security attributes /}

      CREATE_ALWAYS,                         {/ how to create /}

      FILE_ATTRIBUTE_TEMPORARY,              {/ file attributes /}

      0);                                   {/ handle to file with attributes to copy /}

 

    {/ is hOutputFile a valid handle? /}

    if hOutputFile = INVALID_HANDLE_VALUE then

      raise Exception.CreateFmt(ROUTINE_ID + #10 + #10 +

        'WinApi function CreateFile returned an invalid handle value' +

        #10 +

        'for the output file * %s *' + #10 + #10 +

        ErrMsg, [OutputFile]);

 

    {/ prepare StartupInfo structure /}

    FillChar(StartupInfo, SizeOf(StartupInfo), #0);

    StartupInfo.cb          := SizeOf(StartupInfo);

    StartupInfo.dwFlags     := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;

    StartupInfo.wShowWindow := SW_HIDE;

    StartupInfo.hStdOutput  := hOutputFile;

    StartupInfo.hStdInput   := hInputFile;

 

    {/ create the app /}

    Result := CreateProcess(nil,                           {/ pointer to name of executable module /}

      pCommandLine,

      {/ pointer to command line string /}

      nil,                           {/ pointer to process security attributes /}

      nil,                           {/ pointer to thread security attributes /}

      True,                          {/ handle inheritance flag /}

      CREATE_NEW_CONSOLE or

      REALTIME_PRIORITY_CLASS,       {/ creation flags /}

      nil,                           {/ pointer to new environment block /}

      nil,                           {/ pointer to current directory name /}

      StartupInfo,                   {/ pointer to STARTUPINFO /}

      ProcessInfo);                  {/ pointer to PROCESS_INF /}

 

    {/ wait for the app to finish its job and take the handles to free them later /}

    if Result then

    begin

      WaitForSingleObject(ProcessInfo.hProcess, INFINITE);

      hAppProcess := ProcessInfo.hProcess;

      hAppThread  := ProcessInfo.hThread;

    end

    else

      raise Exception.Create(ROUTINE_ID + #10 + #10 +

        'Function failure' + #10 + #10 +

        ErrMsg);

 

  finally

    {/ close the handles

      Kernel objects, like the process and the files we created in this case,

      are maintained by a usage count.

      So, for cleaning up purposes we have to close the handles

      to inform the system that we don't need the objects anymore /}

    if hOutputFile <> 0 then CloseHandle(hOutputFile);

    if hInputFile <> 0 then CloseHandle(hInputFile);

    if hAppThread <> 0 then CloseHandle(hAppThread);

    if hAppProcess <> 0 then CloseHandle(hAppProcess);

    {/ restore the old cursor /}

    Screen.Cursor := OldCursor;

  end;

end; 

[پسر خاک]

قرار دادن یک فایل Exe درون برنامه و اجرای آن

var

  Form1: TForm1;

  NOTEPAD_FILE: string;

 

implementation

 

{/$R *.DFM/}

{/$R MYRES.RES/}

 

function GetTempDir: string;

var

  Buffer: array[0..MAX_PATH] of Char;

begin

  GetTempPath(SizeOf(Buffer) - 1, Buffer);

  Result := StrPas(Buffer);

end;

 

// Extract the Resource

function ExtractRes(ResType, ResName, ResNewName: string): Boolean;

var

  Res: TResourceStream;

begin

  Result := False;

  Res := TResourceStream.Create(Hinstance, Resname, PChar(ResType));

  try

    Res.SavetoFile(ResNewName);

    Result := True;

  finally

    Res.Free;

  end;

end;

 

// Execute the file

procedure ShellExecute_AndWait(FileName: string);

var

  exInfo: TShellExecuteInfo;

  Ph: DWORD;

begin

  FillChar(exInfo, SizeOf(exInfo), 0);

  with exInfo do

  begin

    cbSize := SizeOf(exInfo);

    fMask := SEE_MASK_NOCLOSEPROCESS or SEE_MASK_FLAG_DDEWAIT;

    Wnd := GetActiveWindow();

    ExInfo.lpVerb := 'open';

    lpFile := PChar(FileName);

    nShow := SW_SHOWNORMAL;

  end;

  if ShellExecuteEx(@exInfo) then

  begin

    Ph := exInfo.HProcess;

  end

  else

  begin

    ShowMessage(SysErrorMessage(GetLastError&#  41;);

    Exit;

  end;

  while WaitForSingleObject(ExInfo.hProcess, 50) <> WAIT_OBJECT_0 do

    Application.ProcessMessages;

  CloseHandle(Ph);

end;

 

// To Test it

procedure TForm1.Button1Click(Sender: TObject);

begin

  if ExtractRes('EXEFILE', 'TESTFILE', NOTEPAD_FILE) then

    if FileExists(NOTEPAD_FILE) then

    begin

      ShellExecute_AndWait(NOTEPAD_FILE);

      ShowMessage('Notepad finished!');

      DeleteFile(NOTEPAD_FILE);

    end;

end;

 

procedure TForm1.FormCreate(Sender: TObject);

begin

  NOTEPAD_FILE := GetTempDir + 'Notepad_FROM_RES.EXE';

end; 

[پسر خاک]

پاک کردن برنامه توسط خودش بعد از اجرای آن

procedure DeleteEXE;

 

  function GetTmpDir: string;

  var

    pc: PChar;

  begin

    pc := StrAlloc(MAX_PATH + 1);

    GetTempPath(MAX_PATH, pc);

    Result := string(pc);

    StrDispose(pc);

  end;

 

  function GetTmpFileName(ext: string): string;

  var

    pc: PChar;

  begin

    pc := StrAlloc(MAX_PATH + 1);

    GetTempFileName(PChar(GetTmpDir), 'uis', 0, pc);

    Result := string(pc);

    Result := ChangeFileExt(Result, ext);

    StrDispose(pc);

  end;

    

var

  batchfile: TStringList;

  batchname: string;

begin

  batchname := GetTmpFileName('.bat');

  FileSetAttr(ParamStr(0), 0);

  batchfile := TStringList.Create;

  with batchfile do

  begin

    try

      Add(':Label1');

      Add('del "' + ParamStr(0) + '"');

      Add('if Exist "' + ParamStr(0) + '" goto Label1');

      Add('rmdir "' + ExtractFilePath(ParamStr(0)) + '"');

      Add('del ' + batchname);

      SaveToFile(batchname);

      ChDir(GetTmpDir);

      ShowMessage('Uninstalling program...');

      WinExec(PChar(batchname), SW_HIDE);

    finally

      batchfile.Free;

    end;

    Halt;

  end;

end; 

[پسر خاک]

غیر فعال کردن دکمه 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;

[پسر خاک]

روش استفاده از TFileStream

type

 

  TPerson = record

    Name: string[50];

    vorname: string[50];

  end;

 

  TComputer = record

    Name: string[30];

    cpu: string[30];

  end;

 

var

  Form1: TForm1;

 

  Person: TPerson;

  Computer: TComputer;

 

  Stream: TFileStream;

 

implementation

 

{/$R *.DFM/}

 

//Speichern resp. Erstellen von Datei

//Save or create the file

procedure TForm1.Button1Click(Sender: TObject);

begin

  try

    Stream := TFileStream.Create('c:\test.dat', fmOpenReadWrite);

  except

    Stream := TFileStream.Create('c:\test.dat', fmCreate);

  end;

 

  //2 Einträge pro Record

  //save 2 records for TPerson and TComputer

  Person.Name    := 'Grossenbacher';

  Person.vorname := 'Simon';

  Stream.WriteBuffer(Person, SizeOf(TPerson));

 

  Person.Name    := 'Stutz';

  Person.vorname := 'Thomas';

  Stream.WriteBuffer(Person, SizeOf(TPerson));

 

  Computer.Name := 'Delphi';

  Computer.cpu  := 'Intel';

  Stream.WriteBuffer(Computer, SizeOf(TComputer));

 

  Computer.Name := 'Win';

  Computer.cpu  := 'AMD';

  Stream.WriteBuffer(Computer, SizeOf(TComputer));

 

  Stream.Free;

end;

 

//lädt alle daten von TPerson in listbox1 und

//daten von TComputer in Listbox2

 

//load records from TPerson to listbox1 and

//load records from TComputer to listbox2

procedure TForm1.Button2Click(Sender: TObject);

var

  i: Integer;

begin

  try

    // nur lesen öffnen

    //open read only

    Stream := TFileStream.Create('c:\test.dat', fmOpenRead);

  except

    ShowMessage('Datei konnte nicht geladen werden.');

    Exit;

  end;

 

  //variable i auf anzahl Einträge setzen

 

  //set variable i to the record count

 

  //Einlesen von TPerson

  //Read records TPerson

  for i := 2 downto 1 do

  begin

    Stream.ReadBuffer(Person, SizeOf(TPerson));

    Listbox1.Items.Add(Person.vorname + ' ' + Person.Name);

  end;

 

  //Einlesen von TComputer

  //Read Records TComputer

  for i := 2 downto 1 do

  begin

    Stream.ReadBuffer(Computer, SizeOf(TComputer));

    Listbox2.Items.Add(Computer.Name + ' ' + Computer.cpu);

  end;

 

  Stream.Free;

end; 

[پسر خاک]

جایگزینی یک Dll در حال استفاده از آن

function SystemErrorMessage: string;

var 

  P: PChar;

begin

  if FormatMessage(Format_Message_Allocate_Buffer + Format_Message_From_System,

                   nil,

                   GetLastError,

                   0,

                   @P,

                   0,

                   nil) <> 0 then

  begin

    Result := P;

    LocalFree(Integer(P))

  end 

  else 

    Result := '';

end;

 

 

// Path to Original File

 

procedure TForm1.Button2Click(Sender: TObject);

begin

  if Opendialog1.Execute then

    edit1.Text := OpenDialog1.FileName;

end;

 

// Path to New File

 

procedure TForm1.Button3Click(Sender: TObject);

begin

  if Opendialog2.Execute then

    edit2.Text := OpenDialog2.FileName;

end;

 

// Replace the File.

 

procedure TForm1.Button1Click(Sender: TObject);

begin

  if (Movefileex(PChar(Edit1.Text), PChar(Edit2.Text), MOVEFILE_DELAY_UNTIL_REBOOT) = False) then

    ShowMessage(SystemErrorMessage)

  else

  begin

    ShowMessage('Please Restart Windows to have these changes take effect');

    halt;

  end;

end; 

[پسر خاک]

تغییر صفات یک فایل

procedure TForm1.Button1Click(Sender: TObject);

begin

  FileSetAttr('C:\YourFile.ext', faHidden);

end;

 

{/

  Other Files Attributes:

  Andere Dateiattribute:

/}

 

{/

  faReadOnly  $00000001 Schreibgeschützte Datei

  faHidden    $00000002 Verborgene Datei

  faSysFile   $00000004 Systemdatei

  faVolumeID  $00000008 Laufwerks-ID

  faDirectory $00000010 Verzeichnis

  faArchive   $00000020 Archivdatei

  faAnyFile   $0000003F Beliebige Datei

/}

 

 

{/

  You can also set some attributes at once:

  Es kِnnen auch mehrere Attribute aufs Mal gesetzt werden:

/}

 

FileSetAttr('C:\Autoexec.bat', faReadOnly + faHidden);

 

 

{/

  To remove write protection on a file:

  Den Schreibschutz einer Datei aufheben:

/}

 

if (FileGetAttr(FileName) and faReadOnly) > 0

 then FileSetAttr(FileName, FileGetAttr(FileName) xor faReadOnly);

 

{/

  Re-Set write protection:

  Schreibschutz wieder setzen:

/}

 

FileSetAttr(FileName, FileGetAttr(FileName) or faReadOnly); 

[پسر خاک]

خواندن یک فایل متنی بصورت خط به خط و تغییر آن

procedure TForm1.Button1Click(Sender: TObject);

var

  i, z: Integer;

  f: TextFile;

  t: string;

  Data: array of string;

begin

  if OpenDialog1.Execute then

  begin

    //Read line by line in to the array data

    AssignFile(f, OpenDialog1.FileName);

    Reset(f);

    z := 0;

    SetLength(Data, 0);

    //Repeat for each line until end of file

    repeat

      Inc(z);

      readln(f, t);

      SetLength(Data, Length(Data) + Length(t));

      Data[z] := t;

    until EOF(f);

 

    SetLength(Data, Length(Data) + 3 * z);

    //Add to each line the line number

    for i := 1 to z do Data[i] := IntToStr(i) + ' ' + Data[i];

    SetLength(Data, Length(Data) + 2);

    //Add a carriage return and line feed

    Data[1] := Data[1] + #13 + #10;

    i       := Length(Data[5]);

    Data[5] := '';

    SetLength(Data, Length(Data) - i);

    //create a new textfile with the new data

    AssignFile(f, OpenDialog1.FileName + '2');

    ReWrite(f);

    //write all lines

    for i := 1 to z do writeln(f, Data[i]);

    //save file and close it

    CloseFile(f);

  end;

end; 

[پسر خاک]

تعیین فضای آزاد دیسک

procedure TForm1.Button1Click(Sender: TObject);

var

  freeSpace, totalSpace: Double;

  s: Char;

begin

  // Drive letter

  // Laufwerksbuchstabe

  s := 'D';

 

  freeSpace  := DiskFree(Ord(s) - 64);

  totalSpace := DiskSize(Ord(s) - 64);

 

  label1.Caption := Format('Free Space: %12.0n', [freeSpace]);

  Label2.Caption := Format('Total Space: %12.0n', [totalSpace]);

  Label3.Caption := IntToStr(Round((totalSpace - freeSpace) / totalSpace * 100)) +

    ' Percent used.';

end; 

[پسر خاک]

استفاده از فایلهای INI

uses

  IniFiles;

 

// Write values to a INI file

 

procedure TForm1.Button1Click(Sender: TObject);

var

  ini: TIniFile;

begin

  // Create INI Object and open or create file test.ini

  ini := TIniFile.Create('c:\MyIni.ini');

  try

    // Write a string value to the INI file.

    ini.WriteString('Section_Name', 'Key_Name', 'String Value');

    // Write a integer value to the INI file.

    ini.WriteInteger('Section_Name', 'Key_Name', 2002);

    // Write a boolean value to the INI file.

    ini.WriteBool('Section_Name', 'Key_Name', True);

  finally

    ini.Free;

  end;

end;

 

 

// Read values from an INI file

 

procedure TForm1.Button2Click(Sender: TObject);

var

  ini: TIniFile;

  res: string;

begin

  // Create INI Object and open or create file test.ini

  ini := TIniFile.Create('c:\MyIni.ini');

  try

    res := ini.ReadString('Section_Name', 'Key_Name', 'default value');

    MessageDlg('Value of Section:  ' + res, mtInformation, [mbOK], 0);

  finally

    ini.Free;

  end;

end;

 

// Read all sections

 

procedure TForm1.Button3Click(Sender: TObject);

var 

  ini: TIniFile;

begin

  ListBox1.Clear;

  ini := TIniFile.Create('MyIni.ini');

  try

    ini.ReadSections(listBox1.Items);

  finally 

    ini.Free; 

  end;

end;

 

// Read a section

 

procedure TForm1.Button4Click(Sender: TObject);

var 

  ini: TIniFile;

begin

  ini: = TIniFile.Create('WIN.INI');

  try

    ini.ReadSection('Desktop', ListBox1.Items);

  finally

    ini.Free;

  end;

end;

 

 

// Read section values

 

procedure TForm1.Button5Click(Sender: TObject);

var

  ini: TIniFile;

begin

  ini := TIniFile.Create('WIN.INI');

  try

    ini.ReadSectionValues('Desktop', ListBox1.Items);

  finally 

    ini.Free;  

  end;

end;

 

// Erase a section

 

procedure TForm1.Button6Click(Sender: TObject);

var 

  ini: TIniFile;

begin

  ini := TIniFile.Create('MyIni.ini');

  try

    ini.EraseSection('My_Section');

  finally

    ini.Free;

  end;

end; 

[پسر خاک]

سایز یک دایرکتوری

function GetDirSize(dir: string; subdir: Boolean): Longint;

var

  rec: TSearchRec;

  found: Integer;

begin

  Result := 0;

  if dir[Length(dir)] <> '\' then dir := dir + '\';

  found := FindFirst(dir + '*.*', faAnyFile, rec);

  while found = 0 do

  begin

    Inc(Result, rec.Size);

    if (rec.Attr and faDirectory > 0) and (rec.Name[1] <> '.') and (subdir = True) then

      Inc(Result, GetDirSize(dir + rec.Name, True));

    found := FindNext(rec);

  end;

  FindClose(rec);

end;

 

procedure TForm1.Button1Click(Sender: TObject);

begin

  label1.Caption := FloatToStr(GetDirSize('e:\download', False) / Sqr(1024)) + ' MBytes';

  label2.Caption := FloatToStr(GetDirSize('e:\download', True) / Sqr(1024)) + ' MBytes';

end; 

[پسر خاک]

کپی کردن یک فایل

var

  fileSource, fileDest: string;

begin

  fileSource := 'C:\SourceFile.txt';

  fileDest := 'G:\DestFile.txt';

  CopyFile(PChar(fileSource), PChar(fileDest), False);

end; 

[پسر خاک]

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

unit main;

 

interface

 

uses

  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

  StdCtrls, ExtCtrls;

 

type

  Tfrm_main = class(TForm)

    img_info: TImage;

    procedure FormShow(Sender: TObject);

  private

    {/ Private declarations /}

  public

    {/ Public declarations /}

    procedure info(s1, s2: string);

  end;

 

var

  frm_main: Tfrm_main;

  gn_speed_y: Integer;

  gn_text_y: Integer;

const

  gn_speed_x: Integer = 8;

  gn_text_x: Integer  = 15;

  gl_start: Boolean   = True;

 

implementation

 

{/$R *.DFM/}

 

procedure Tfrm_main.FormShow(Sender: TObject);

var 

  _eax, _ebx, _ecx, _edx: Longword;

  i: Integer;

  b: Byte;

  b1: Word;

  s, s1, s2, s3, s_all: string;

begin

  //Set the startup colour of the image

  img_info.Canvas.Brush.Color := clblue;

  img_info.Canvas.FillRect(rect(0, 0, img_info.Width, img_info.Height));

 

 

  gn_text_y := 5; //position of the 1st text

 

  asm                //asm call to the CPUID inst.

    mov eax,0         //sub. func call

    db $0F,$A2         //db $0F,$A2 = CPUID instruction

    mov _ebx,ebx

    mov _ecx,ecx

    mov _edx,edx

  end;

 

  for i := 0 to 3 do   //extract vendor id

  begin

    b := lo(_ebx);

    s := s + chr(b);

    b := lo(_ecx);

    s1:= s1 + chr(b);

    b := lo(_edx);

    s2:= s2 + chr(b);

    _ebx := _ebx shr 8;

    _ecx := _ecx shr 8;

    _edx := _edx shr 8;

  end;

  info('CPU', '');

  info('   - ' + 'Vendor ID: ', s + s2 + s1);

 

  asm

    mov eax,1

    db $0F,$A2

    mov _eax,eax

    mov _ebx,ebx

    mov _ecx,ecx

    mov _edx,edx

  end;

  //06B1

  //|0000| |0000 0000| |0000| |00| |00| |0110| |1011| |0001|

  b := lo(_eax) and 15;

  info('   - ' + 'Stepping ID: ', IntToStr(b));

  b := lo(_eax) shr 4;

  info('   - ' + 'Model Number: ', IntToHex(b, 1));

  b := hi(_eax) and 15;

  info('   - ' + 'Family Code: ', IntToStr(b));

  b := hi(_eax) shr 4;

  info('   - ' + 'Processor Type: ', IntToStr(b));

  //31.   28. 27.   24. 23.   20. 19.   16.

  //  0 0 0 0   0 0 0 0   0 0 0 0   0 0 0 0

  b := lo((_eax shr 16)) and 15;

  info('   - ' + 'Extended Model: ', IntToStr(b));

 

  b := lo((_eax shr 20));

  info('   - ' + 'Extended Family: ', IntToStr(b));

 

  b := lo(_ebx);

  info('   - ' + 'Brand ID: ', IntToStr(b));

  b := hi(_ebx);

  info('   - ' + 'Chunks: ', IntToStr(b));

  b := lo(_ebx shr 16);

  info('   - ' + 'Count: ', IntToStr(b));

  b := hi(_ebx shr 16);

  info('   - ' + 'APIC ID: ', IntToStr(b));

 

  //Bit 18 =? 1     //is serial number enabled?

  if (_edx and $40000) = $40000 then

    info('   - ' + 'Serial Number ', 'Enabled')

  else 

    info('   - ' + 'Serial Number ', 'Disabled');

 

  s := IntToHex(_eax, 8);

  asm                  //determine the serial number

    mov eax,3

    db $0F,$A2

    mov _ecx,ecx

    mov _edx,edx

  end;

  s1 := IntToHex(_edx, 8);

  s2 := IntToHex(_ecx, 8);

  Insert('-', s, 5);

  Insert('-', s1, 5);

  Insert('-', s2, 5);

  info('   - ' + 'Serial Number: ', s + '-' + s1 + '-' + s2);

 

  asm

    mov eax,1

    db $0F,$A2

    mov _edx,edx

  end;

  info('', '');

  //Bit 23 =? 1

  if (_edx and $800000) = $800000 then

    info('MMX ', 'Supported')

  else 

    info('MMX ', 'Not Supported');

 

  //Bit 24 =? 1

  if (_edx and $01000000) = $01000000 then

    info('FXSAVE & FXRSTOR Instructions ', 'Supported')

  else 

    info('FXSAVE & FXRSTOR Instructions Not ', 'Supported');

 

  //Bit 25 =? 1

  if (_edx and $02000000) = $02000000 then

    info('SSE ', 'Supported')

  else 

    info('SSE ', 'Not Supported');

 

  //Bit 26 =? 1

  if (_edx and $04000000) = $04000000 then

    info('SSE2 ', 'Supported')

  else 

    info('SSE2 ', 'Not Supported');

 

  info('', '');

 

  asm     //execute the extended CPUID inst.

    mov eax,$80000000   //sub. func call

    db $0F,$A2

    mov _eax,eax

  end;

 

  if _eax > $80000000 then  //any other sub. funct avail. ?

  begin

    info('Extended CPUID: ', 'Supported');

    info('   - Largest Function Supported: ', IntToStr(_eax - $80000000));

    asm     //get brand ID

      mov eax,$80000002

      db $0F

      db $A2

      mov _eax,eax

      mov _ebx,ebx

      mov _ecx,ecx

      mov _edx,edx

    end;

    s  := '';

    s1 := '';

    s2 := '';

    s3 := '';

    for i := 0 to 3 do

    begin

      b := lo(_eax);

      s3:= s3 + chr(b);

      b := lo(_ebx);

      s := s + chr(b);

      b := lo(_ecx);

      s1 := s1 + chr(b);

      b := lo(_edx);

      s2 := s2 + chr(b);

      _eax := _eax shr 8;

      _ebx := _ebx shr 8;

      _ecx := _ecx shr 8;

      _edx := _edx shr 8;

    end;

 

    s_all := s3 + s + s1 + s2;

 

    asm

      mov eax,$80000003

      db $0F

      db $A2

      mov _eax,eax

      mov _ebx,ebx

      mov _ecx,ecx

    mov _edx,edx

    end;

    s  := '';

    s1 := '';

    s2 := '';

    s3 := '';

    for i := 0 to 3 do

    begin

      b := lo(_eax);

      s3 := s3 + chr(b);

      b := lo(_ebx);

      s := s + chr(b);

      b := lo(_ecx);

      s1 := s1 + chr(b);

      b := lo(_edx);

      s2 := s2 + chr(b);

      _eax := _eax shr 8;

      _ebx := _ebx shr 8;

      _ecx := _ecx shr 8;

      _edx := _edx shr 8;

    end;

    s_all := s_all + s3 + s + s1 + s2;

 

    asm

      mov eax,$80000004

      db $0F

      db $A2

      mov _eax,eax

      mov _ebx,ebx

      mov _ecx,ecx

      mov _edx,edx

    end;

    s  := '';

    s1 := '';

    s2 := '';

    s3 := '';

    for i := 0 to 3 do

    begin

      b  := lo(_eax);

      s3 := s3 + chr(b);

      b := lo(_ebx);

      s := s + chr(b);

      b := lo(_ecx);

      s1 := s1 + chr(b);

      b  := lo(_edx);

      s2 := s2 + chr(b);

      _eax := _eax shr 8;

      _ebx := _ebx shr 8;

      _ecx := _ecx shr 8;

      _edx := _edx shr 8;

    end;

    info('Brand String: ', '');

    if s2[Length(s2)] = #0 then setlength(s2, Length(s2) - 1);

    info('', '   - ' + s_all + s3 + s + s1 + s2);

  end

  else 

    info('   - Extended CPUID ', 'Not Supported.');

end;

 

procedure Tfrm_main.info(s1, s2: string);

begin

  if s1 <> '' then

  begin

    img_info.Canvas.Brush.Color := clblue;

    img_info.Canvas.Font.Color  := clyellow;

    img_info.Canvas.TextOut(gn_text_x, gn_text_y, s1);

  end;

  if s2 <> '' then

  begin

    img_info.Canvas.Brush.Color := clblue;

    img_info.Canvas.Font.Color  := clWhite;

    img_info.Canvas.TextOut(gn_text_x + img_info.Canvas.TextWidth(s1), gn_text_y, s2);

  end;

  Inc(gn_text_y, 13);

end;

 

end. 

[پسر خاک]

مشخص کردن وجود Terminal Service ها

function IsRemoteSession: Boolean;

const

  sm_RemoteSession = $1000; {/ from WinUser.h /}

begin

  Result := (GetSystemMetrics(sm_RemoteSession) <> 0);

end; 

type

  OSVERSIONINFOEX = packed record

    dwOSVersionInfoSize: DWORD;

    dwMajorVersion: DWORD;

    dwMinorVersion: DWORD;

    dwBuildNumber: DWORD;

    dwPlatformId: DWORD;

    szCSDVersion: array[0..127] of Char;

    wServicePackMajor: WORD;

    wServicePackMinor: WORD;

    wSuiteMask: WORD;

    wProductType: BYTE;

    wReserved: BYTE;

  end;

  TOSVersionInfoEx = OSVERSIONINFOEX;

  POSVersionInfoEx = ^TOSVersionInfoEx;

 

const

  VER_SUITE_TERMINAL = $00000010;

  VER_SUITENAME = $00000040;

  VER_AND = 6;

 

function VerSetConditionMask(

  ConditionMask: int64;

  TypeMask: DWORD;

  Condition: Byte

  ): int64; stdcall; external kernel32;

 

function VerifyVersionInfo(

  var VersionInformation: OSVERSIONINFOEX;

  dwTypeMask: DWORD;

  dwlConditionMask: int64

  ): BOOL; stdcall; external kernel32 name 'VerifyVersionInfoA';

 

 

function IsTerminalServicesEnabled: Boolean;

var

  osVersionInfo: OSVERSIONINFOEX;

  dwlConditionMask: int64;

begin

  FillChar(osVersionInfo, SizeOf(osVersionInfo), 0);

  osVersionInfo.dwOSVersionInfoSize := sizeof(osVersionInfo);

  osVersionInfo.wSuiteMask := VER_SUITE_TERMINAL;

  dwlConditionMask := 0;

  dwlConditionMask :=

    VerSetConditionMask(dwlConditionMask,

    VER_SUITENAME,

    VER_AND);

  Result := VerifyVersionInfo(

    osVersionInfo,

    VER_SUITENAME,

    dwlConditionMask);

end;