注册 登陆

巨猛的TWebBrowser代码 N多

动态建立一个WebBrowser
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;

保存成图片
uses
  MSHTML_TLB, JPEG, ActiveX, ComObj;

procedure generateJPEGfromBrowser(browser: iWebBrowser2; jpegFQFilename: string;
  srcHeight: Integer; srcWidth: Integer; tarHeight: Integer; tarWidth: Integer);
var
  sourceDrawRect: TRect;
  targetDrawRect: TRect;
  sourceBitmap: TBitmap;
  targetBitmap: TBitmap;
  jpeg: TJPEGImage;
  viewObject: IViewObject;
begin
  sourceBitmap := TBitmap.Create;
  targetBitmap := TBitmap.Create;
  jpeg := TJPEGImage.Create;
  try
    try
      sourceDrawRect := Rect(0, 0, srcWidth, srcHeight);
      sourceBitmap.Width  := srcWidth;
      sourceBitmap.Height := srcHeight;

      viewObject := browser as IViewObject;

      if viewObject = nil then
        Exit;

      OleCheck(viewObject.Draw(DVASPECT_CONTENT, 1, nil, nil, Form1.Handle,
        sourceBitmap.Canvas.Handle, @sourceDrawRect, nil, nil, 0));

      // Resize the src bitmap to the target bitmap
      targetDrawRect := Rect(0, 0, tarWidth, tarHeight);
      targetBitmap.Height := tarHeight;
      targetBitmap.Width  := tarWidth;
      targetBitmap.Canvas.StretchDraw(targetDrawRect, sourceBitmap);

      // Create a JPEG from the Bitmap and save it
      jpeg.Assign(targetBitmap);

      jpeg.SaveToFile(jpegFQFilename);
    finally
      jpeg.Free;
      sourceBitmap.Free;
      targetBitmap.Free;
    end;
  except
    // Error Code
  end;
end;

procedure TForm1.btnButton1Click(Sender: TObject);
var
  IDoc1: IHTMLDocument2;
  Web: ShDocVW_TLB.IWebBrowser2;
  tmpX, tmpY: Integer;
begin
  with WebBrowser1 do
  begin
    Document.QueryInterface(IHTMLDocument2, iDoc1);
    Web := ControlInterface;
    tmpX := Height;
    tmpY := Width;
    TControl(WebBrowser1).Visible := Boolean(0);
    Height := OleObject.Document.ParentWindow.Screen.Height;
    Width := OleObject.Document.ParentWindow.Screen.Width;
    generateJPEGfromBrowser(Web,'c:\test.jpg',Height, Width, Height, Width);
    Height := tmpX;
    Width := tmpY;
    TControl(WebBrowser1).Visible := Boolean(1);
  end;
end;

保存所有图片
uses
  UrlMon;

function DownloadFile(SourceFile, DestFile: string): Boolean;
begin
  try
    Result := UrlDownloadToFile(nil, PChar(SourceFile), PChar(DestFile), 0,
      nil) = 0;
  except
    Result := False;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  k, p: Integer;
  Source, dest, ext: string;
begin
  for k := 0 to WebBrowser1.OleObject.Document.Images.Length - 1 do
  begin
    Source := WebBrowser1.OleObject.Document.Images.Item(k).Src;
    p := LastDelimiter('.', Source);
    ext := UpperCase(Copy(Source, p + 1, Length(Source)));
    if (ext = 'GIF') or (ext = 'JPG') then
    begin
      p  := LastDelimiter('/', Source);
      dest := ExtractFilePath(ParamStr(0)) + Copy(Source, p + 1,
        Length(Source));
      DownloadFile(Source, dest);
    end;
  end;
end;

隐藏IP下载网页
{ Add a button and memo }

implementation

{$R *.dfm}

uses
  Urlmon;

procedure TForm1.Button1Click(Sender : TObject);
var
  ca : iinterface;
  rls : Integer;
  stat : iBindStatusCallBack;
  rr : Cardinal;
  tag : _tagBindInfo;
  exGuid : tguid;
  noIp : Pointer;
  res : HResult;
begin
  // Make a 0.0.0.0 ip giud
  exGuid.D1 := rr;
  exGuid.D2 := word('0');
  exGuid.D3 := word('.');
  // Set Tag options
  with tag do  
  begin
    // set "0." ip guid
    iid := exGuid;
    // set needed size
    cbSize := sizeOf('www.big-x.cjb.net');
    // Add ip hiding ( not tested, but should work )
    securityAttributes.lpSecurityDescriptor := noIp;
    securityAttributes.nLength := length('0.0.0.0');
    securityAttributes.bInheritHandle := True;
  end;{
Extra: res := stat.GetBindInfo(rr, tag);}
  //Start downloading webpage
  try
    urlmon.URLDownloadToFile(ca, 'www.big-x.cjb.net', 'filename.htm', 1, stat);
  except
    ShowMessage('Could not download the webpage!');
  end;
  //Load the webpage source to a memo
  memo1.Lines.LoadFromFile('filename.htm');
end;
取得所有图片
uses
  MSHTML_TLB;

// First navigate to a page
// Zuerst eine Seite laden
procedure TForm1.Button1Click(Sender: TObject);
begin
  Webbrowser1.Navigate('www.google.ch');
end;

// Then execute the following code:
// Dann diese Routine ausführen:
procedure TForm1.Button2Click(Sender: TObject);
var
  i: Word;
  ImageWidth, ImageHeight: Integer;
  ImageHref, ImageFileSize, ImageTextAlternative: string;
  Document: IHtmlDocument2;
begin
  // Loop through all images of a TWebbrowser
  // Schleife über alle Bilder im Webbrowser
  for i := 0 to WebBrowser1.OleObject.Document.Images.Length - 1 do
  begin
    Document := WebBrowser1.Document as IHtmlDocument2;
    // Retrieves the calculated width of the image.
    ImageWidth := WebBrowser1.OleObject.Document.Images.Item(i).Width;
    // Retrieves the height of the image.
    ImageHeight := WebBrowser1.OleObject.Document.Images.Item(i).Height;
    // Retrieves the file size of the image.
    ImageFileSize := (Document.Images.Item(i, 0) as IHTMLImgElement).FileSize;
    // Retrieves the entire URL that the browser uses to locate the image
    ImageHref := (Document.Images.Item(i, 0) as IHTMLImgElement).Href;
    // Retrieves a text alternative to the graphic.
    ImageTextAlternative := (Document.Images.Item(i, 0) as IHTMLImgElement).alt;
    // Show image information in a TListbox
    ListBox1.Items.Add(Format('%s : %d x %d Pixels; %s Bytes; %s',
      [ImageHref, ImageWidth, ImageHeight, ImageFileSize, ImageTextAlternative]));
  end;
end;
在浏览器上添加一个按钮
{
This is a simple little example that allows you to add a button
to Internet Explorer 3.0 or above
Values:
ButtonText := The text you want to be displayed at the bottom of the button
MenuText := The tools option at the top of IE will now contain
a reference to your program.
MenuStatusbar := Script option we are not using this object. (Ignore)
CLSID := Your classID. I won`t explain it because its complex.
That it has to unique. You can use GUIDTOSTRING
To create a new CLSID with the unit ActiveX.

Default Visible := Display it.
Exec := Your program path to execute.
Hoticon := (Mouse Over Event) ImageIndex in shell32.dll i've picked 4
Icon := I've selected to display shell32.dll image 4.
}


procedure CreateExplorerButton(Path: string);
const
  Tagit = '\{10954C80-4F0F-11d3-B17C-00C0DFE39736}\';
var
  Reg: TRegistry;
  Path1: string;
  Merge: string;
begin
  Path := 'c:\your_program_path';
  Reg := TRegistry.Create;
  try
    with Reg do
    begin
      RootKey := HKEY_LOCAL_MACHINE;
      Path1 := 'Software\Microsoft\Internet Explorer\Extensions';
      Merge := Path1 + Tagit;
      OpenKey(Merge, True);
      WriteString('ButtonText', 'ButtonText');
      WriteString('MenuText', 'Tools Menu Item');
      WriteString('MenuStatusBar', 'Run Script');
      WriteString('ClSid', '{1FBA04EE-3024-11d2-8F1F-0000F87ABD16}');
      WriteString('Default Visible', 'Yes');
      WriteString('Exec', Path + '\ProgramName.exe');
      WriteString('HotIcon', ',4');
      WriteString('Icon', ',4');
    end
  finally
    Reg.CloseKey;
    Reg.Free;
  end;
end;
从网上下载一个文件
1.}

uses
  URLMon, ShellApi;

function DownloadFile(SourceFile, DestFile: string): Boolean;
begin
  try
    Result := UrlDownloadToFile(nil, PChar(SourceFile), PChar(DestFile), 0, nil) = 0;
  except
    Result := False;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
const
  // URL Location
  SourceFile = 'http://www.guochao.com/admin/editer/UploadFile/2004730132037734.gif';
  // Where to save the file
  DestFile = 'c:\temp\google-image.gif';
begin
  if DownloadFile(SourceFile, DestFile) then
  begin
    ShowMessage('Download succesful!');
    // Show downloaded image in your browser
    ShellExecute(Application.Handle, PChar('open'), PChar(DestFile),
      PChar(''), nil, SW_NORMAL)
  end
  else
    ShowMessage('Error while downloading ' + SourceFile)
end;

// Minimum availability: Internet Explorer 3.0
// Minimum operating systems Windows NT 4.0, Windows 95

{********************************************************}

{2.}


uses
  Wininet;

function DownloadURL(const aUrl: string): Boolean;
var
  hSession: HINTERNET;
  hService: HINTERNET;
  lpBuffer: array[0..1024 + 1] of Char;
  dwBytesRead: DWORD;
begin
  Result := False;
  // hSession := InternetOpen( 'MyApp', INTERNET_OPEN_TYPE_DIRECT, nil, nil, 0);
  hSession := InternetOpen('MyApp', INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
  try
    if Assigned(hSession) then
    begin
      hService := InternetOpenUrl(hSession, PChar(aUrl), nil, 0, 0, 0);
      if Assigned(hService) then
        try
          while True do
          begin
            dwBytesRead := 1024;
            InternetReadFile(hService, @lpBuffer, 1024, dwBytesRead);
            if dwBytesRead = 0 then break;
            lpBuffer[dwBytesRead] := #0;
            Form1.Memo1.Lines.Add(lpBuffer);
          end;
          Result := True;
        finally
          InternetCloseHandle(hService);
        end;
    end;
  finally
    InternetCloseHandle(hSession);
  end;
end;

{********************************************************}

{3. Forces a download of the requested file, object, or directory listing from the origin server,
    not from the cache
}

function DownloadURL_NOCache(const aUrl: string; var s: String): Boolean;
var
  hSession: HINTERNET;
  hService: HINTERNET;
  lpBuffer: array[0..1024 + 1] of Char;
  dwBytesRead: DWORD;
begin
  Result := False;
  s := '';
  // hSession := InternetOpen( 'MyApp', INTERNET_OPEN_TYPE_DIRECT, nil, nil, 0);
  hSession := InternetOpen('MyApp', INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
  try
    if Assigned(hSession) then
    begin
      hService := InternetOpenUrl(hSession, PChar(aUrl), nil, 0, INTERNET_FLAG_RELOAD, 0);
      if Assigned(hService) then
        try
          while True do
          begin
            dwBytesRead := 1024;
            InternetReadFile(hService, @lpBuffer, 1024, dwBytesRead);
            if dwBytesRead = 0 then break;
            lpBuffer[dwBytesRead] := #0;
            s := s + lpBuffer;
          end;
          Result := True;
        finally
          InternetCloseHandle(hService);
        end;
    end;
  finally
    InternetCloseHandle(hSession);
  end;
end;

//aufrufen
var
  s: String;
begin
if DownloadURL('http://www.swissdelphicenter.ch/', s) then
   ShowMessage(s);
end;
打开一个新的窗口
{
  Usually when you open a URL in new window in TWebBrowser it opens
  the Internet Explorer. This tip creates a new instance of your
  browser form and opens the new site in your browser.
}


procedure TForm1.WebBrowser1NewWindow2(Sender: TObject;
  var ppDisp: IDispatch; var Cancel: WordBool);
var
  NewWindow: TForm1;
begin
  // a new instance of the form will be created
  // Eine neue Instanz wird erstellt
  NewWindow := TForm1.Create(self);

  NewWindow.Show;
  ppDisp := NewWindow.Webbrowser1.DefaultDispatch;
end;

查看源代码
// You need a TMemo, a TButton und a NMHTTP
// Man braucht ein TMemo, einen TButton und eine TNMHTTP

procedure TForm1.Button1Click(Sender: TObject);
begin
  NMHTTP1.Get('www.swissdelphicenter.ch');
  memo1.Text := NMHTTP1.Body
end;
动态加载代码
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.Create(ms));
      finally
        ms.Free;
      end;
    finally
      sl.Free;
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  WB_LoadHTML(WebBrowser1,'SwissDelphiCenter');
end;
列出所有连接
procedure TForm1.Button1Click(Sender: TObject);
var
  i: Integer;
begin
  for i := 0 to Webbrowser1.OleObject.Document.links.Length - 1 do
    Listbox1.Items.Add(Webbrowser1.OleObject.Document.Links.Item(i));
end;


{*****************}

{ if there are frames }

procedure TForm1.Button2Click(Sender: TObject);
var
  u : variant;
  v : IDispatch;
  s : string;

  procedure RecurseLinks(htmlDoc: variant);
  var
    BodyElement : variant;
    ElementCo: variant;
    HTMLFrames: variant;
    HTMLWnd : variant;
    j, i : integer;
  begin
    if VarIsEmpty(htmlDoc) then
      exit;
    BodyElement := htmlDoc.body;
    if BodyElement.tagName = 'BODY' then
    begin
      ElementCo := htmlDoc.links;
      j := ElementCo.Length - 1;
      for i := 0 to j do
      begin
        u := ElementCo.item(i);
        s := u.href;
        listLinks.Items.Add(s);
      end;
    end;
    HTMLFrames := htmlDoc.Frames;
    j := HTMLFrames.length - 1;
    for i := 0 to j do
    begin
      HTMLWnd := HTMLFrames.Item(i);
      RecurseLinks(HTMLWnd.Document);
    end;
  end; // RecurseLinks
begin
  v := WebBrowser1.document;
  listLinks.Clear;
  RecurseLinks(v);
end;
URL编码
function HTTPEncode(const AStr: string): string;
const
  NoConversion = ['A'..'Z', 'a'..'z', '*', '@', '.', '_', '-'];
var
  Sp, Rp: PChar;
begin
  SetLength(Result, Length(AStr) * 3);
  Sp := PChar(AStr);
  Rp := PChar(Result);
  while Sp^ <> #0 do
  begin
    if Sp^ in NoConversion then
      Rp^ := Sp^
    else if Sp^ = ' ' then
      Rp^ := '+'
    else
    begin
      FormatBuf(Rp^, 3, '%%%.2x', 6, [Ord(Sp^)]);
      Inc(Rp, 2);
    end;
    Inc(Rp);
    Inc(Sp);
  end;
  SetLength(Result, Rp - PChar(Result));
end;


procedure TForm1.Button1Click(Sender: TObject);
begin
  Edit1.Text := HTTPEncode(Edit1.Text);
end;
过滤连接
{
  For this tip you need Memo1, ListBox1, Label1, Button1.

  For diesen Tip braucht man ein Memo1, eine ListBox1,
  ein Label1 und einen Button1.
}

procedure TForm1.Button1Click(Sender: TObject);
var  
  i, p: Integer;
  s: string;
begin
  ListBox1.Clear;
  for i := 0 to Memo1.Lines.Count - 1 do
  begin
    if Pos('http://', Memo1.Lines.Strings[i]) > 0 then
    begin
      s := '';
      {If the current line contains a "http://", read on until a space is found

       Die aktuelle Zeile wird nach der Zeichenfolge "http://" durchsucht
       und bei Erfolg ab der gefundenen Position ausgelesen, bis ein
       Leerzeichen auftritt...}

      for p := Pos('http://', Memo1.Lines.Strings[i]) to
        Length(Memo1.Lines.Strings[i]) do
        if Memo1.Lines.Strings[i][p] <> ' ' then
          s := s + Memo1.Lines.Strings[i][p]
      else
        break;

       {Remove some characters if address doesn't end with a space

       Falls die gefundene Adresse nicht mit einem Leerzeichen abschlie?t,
       werden hier noch anh?ngende Textzeichen entfernt...}

      while Pos(s[Length(s)], '..;!")]}?''>') > 0 do
        Delete(s, Length(s), 1);
      // Add the Address to the list...
      //Gefundene Adresse in die Liste aufnehmen...
      ListBox1.Items.Add(s);
    end;
  end;

  // Show the number of Addresses in Label1
  // Die Zahl der gefundenen Adressen in Label1 anzeigen...

  if ListBox1.Items.Count > 0 then
    label1.Caption := IntToStr(ListBox1.Items.Count) +
      ' Adresse(n) gefunden.'
  else
    label1.Caption := 'Keine Adresse gefunden.';
end;
***************************************************
高亮显示HTML代码
procedure HTMLSyntax(RichEdit: TRichEdit; TextCol, TagCol, DopCol: TColor);
var  
  i, iDop: Integer;
  s: string;
  Col: TColor;
  isTag, isDop: Boolean;
begin
  iDop := 0;
  isDop := False;
  isTag := False;
  Col := TextCol;
  RichEdit.SetFocus;

  for i := 0 to Length(RichEdit.Text) do
  begin
    RichEdit.SelStart := i;
    RichEdit.SelLength := 1;
    s := RichEdit.SelText;

    if (s = '<') or (s = '{') then isTag := True;

    if isTag then
      if (s = '"') then
        if not isDop then
        begin
          iDop  := 1;
          isDop := True;
        end  
        else
          isDop := False;

    if isTag then
      if isDop then
      begin
        if iDop <> 1 then Col := DopCol;
      end  
      else
        Col := TagCol
    else
      Col := TextCol;

    RichEdit.SelAttributes.Color := Col;

    iDop := 0;

    if (s = '>') or (s = '}') then isTag := False;
  end;
   
  RichEdit.SelLength := 0;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  RichEdit1.Lines.BeginUpdate;
  HTMLSyntax(RichEdit1, clBlue, clRed, clGreen);
  RichEdit1.Lines.EndUpdate;
end;
********************************************************
分割字符
unit StrFuncs;

interface

uses SysUtils, Classes;

function StrToArrays(str, r: string; out temp: TStrings): Boolean;
function ArrayToStr(str: TStrings; r: string): string;

implementation


function StrToArrays(str, r: string; out temp: TStrings): Boolean;
var
  j: Integer;
begin
  if temp <> nil then  
  begin
    temp.Clear;
    while str <> '' do  
    begin
      j := Pos(r, str);
      if j = 0 then j := Length(str) + 1;
      temp.Add(Copy(Str, 1, j - 1));
      Delete(Str, 1, j + Length(r) - 1);
    end;
    Result := True;
    else  
      Result := False;
  end;
end;


function ArrayToStr(str: TStrings; r: string): string;
var
  i: Integer;
begin
  Result := '';
  for i := 0 to Str.Count - 1 do
  begin
    Result := Result + Str.Strings[i] + r;
  end;
end;

end.
********************************************************
隐藏最大,最小化按钮
{
  This article shows by example how to suppress the maximize and
  minimize buttons on an form at runtime.
  To disable an form's Minimize and Maximize buttons,
  you need to use the SetWindowLong Windows API
  function to change the style of the window.
}

{ Dieses Beispiel zeigt, wie man die Schaltfl?chen zur Minimierung,
  Maximierung einer Form zur Laufzeit verstecken kann.
  Man braucht dafür die SetWindowLong Windows API um den Stil
  des Fensters zu ?ndern.
  Der Code kann auch für non-VCL Anwendungen gebraucht werden.
}

// Add the following code to the OnCreate event
// procedure for your form (TForm1):

procedure TForm1.FormCreate(Sender: TObject);
var
  l: DWORD;
begin
  l := GetWindowLong(Self.Handle, GWL_STYLE);
  l := l and not (WS_MINIMIZEBOX);
  l := l and not (WS_MAXIMIZEBOX);
  l := SetWindowLong(Self.Handle, GWL_STYLE, l);
end;
***************************************
关闭MDI窗口
unit Child;

// Have you noticed that when you try to close a MDIChild form
// the form minimizes but doesn't disappear from your Main form
// client area?
//
// With this tip you can learn how to really close the MDI child
// form and free the memory occupied by the form


interface

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

type
  TMDIChildForm = class(TForm)
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  MDIChildForm: TMDIChildForm;

implementation

{$R *.DFM}

procedure TMDIChildForm.FormClose(Sender: TObject;
  var Action: TCloseAction);
begin
  // This line of code frees memory and closes the form
  Action := caFree;
end;

end.
**************************
列出目录下的所有文件
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;
*********************************************************
加密解密文件
unit EZCrypt;

{modeled by Ben Hochstrasser(bhoc@surfeu.ch) after some code snippet from borland}

interface

uses Windows, Classes;

type
  TWordTriple = Array[0..2] of Word;

function FileEncrypt(InFile, OutFile: String; Key: TWordTriple): boolean;
function FileDecrypt(InFile, OutFile: String; Key: TWordTriple): boolean;
function TextEncrypt(const s: string; Key: TWordTriple): string;
function TextDecrypt(const s: string; Key: TWordTriple): string;
function MemoryEncrypt(Src: Pointer; SrcSize: Cardinal; Target: Pointer; TargetSize: Cardinal; Key: TWordTriple): boolean;
function MemoryDecrypt(Src: Pointer; SrcSize: Cardinal; Target: Pointer; TargetSize: Cardinal; Key: TWordTriple): boolean;

implementation

function MemoryEncrypt(Src: Pointer; SrcSize: Cardinal; Target: Pointer; TargetSize: Cardinal; Key: TWordTriple): boolean;
var
  pIn, pOut: ^byte;
  i : Cardinal;
begin
  if SrcSize = TargetSize then
  begin
    pIn := Src;
    pOut := Target;
    for i := 1 to SrcSize do
    begin
      pOut^ := pIn^ xor (Key[2] shr 8);
      Key[2] := Byte(pIn^ + Key[2]) * Key[0] + Key[1];
      inc(pIn);
      inc(pOut);
    end;
    Result := True;
  end else
    Result := False;
end;

function MemoryDecrypt(Src: Pointer; SrcSize: Cardinal; Target: Pointer; TargetSize: Cardinal; Key: TWordTriple): boolean;
var
  pIn, pOut: ^byte;
  i : Cardinal;
begin
  if SrcSize = TargetSize then
  begin
    pIn := Src;
    pOut := Target;
    for i := 1 to SrcSize do
    begin
      pOut^ := pIn^ xor (Key[2] shr 8);
      Key[2] := byte(pOut^ + Key[2]) * Key[0] + Key[1];
      inc(pIn);
      inc(pOut);
    end;
    Result := True;
  end else
    Result := False;
end;

function TextCrypt(const s: string; Key: TWordTriple; Encrypt: Boolean): string;
var
  bOK: Boolean;
begin
  SetLength(Result, Length(s));
  if Encrypt then
    bOK := MemoryEncrypt(PChar(s), Length(s), PChar(Result), Length(Result), Key)
  else
    bOK := MemoryDecrypt(PChar(s), Length(s), PChar(Result), Length(Result), Key);
  if not bOK then Result := '';
end;

function FileCrypt(InFile, OutFile: String; Key: TWordTriple; Encrypt: Boolean): boolean;
var
  MIn, MOut: TMemoryStream;
begin
  MIn := TMemoryStream.Create;
  MOut := TMemoryStream.Create;
  Try
    MIn.LoadFromFile(InFile);
    MOut.SetSize(MIn.Size);
    if Encrypt then
      Result := MemoryEncrypt(MIn.Memory, MIn.Size, MOut.Memory, MOut.Size, Key)
    else
      Result := MemoryDecrypt(MIn.Memory, MIn.Size, MOut.Memory, MOut.Size, Key);
    MOut.SaveToFile(OutFile);
  finally
    MOut.Free;
    MIn.Free;
  end;
end;

function TextEncrypt(const s: string; Key: TWordTriple): string;
begin
  Result := TextCrypt(s, Key, True);
end;

function TextDecrypt(const s: string; Key: TWordTriple): string;
begin
  Result := TextCrypt(s, Key, False);
end;

function FileEncrypt(InFile, OutFile: String; Key: TWordTriple): boolean;
begin
  Result := FileCrypt(InFile, OutFile, Key, True);
end;

function FileDecrypt(InFile, OutFile: String; Key: TWordTriple): boolean;
begin
  Result := FileCrypt(InFile, OutFile, Key, False);
end;


********************************************
执行一个文档并等待它完成
{
  This tip allows you to open any document with its
  associated application (not only exe, com) and wait for it to finish.
}


{
  Dieser Tip erm?glicht es, nicht nur normale Programme, sondern auch Dateien,
  die mit Programmen ge?ffnet werden, auszuführen und darauf zu warten,
  bis sie beendet sind.
}

uses
  Shellapi;

function StartAssociatedExe(FileName: string; var ErrorCode: Cardinal): Boolean;
var
  Prg: string;
  ProcessInfo: TProcessInformation;
  StartupInfo: TStartupInfo;
begin
  SetLength(Prg, MAX_PATH);
  Result := False;
  ErrorCode := FindExecutable(PChar(FileName), nil, PChar(Prg));
  if ErrorCode >= 32 then
  begin
    SetLength(Prg, StrLen(PChar(Prg)));
    FillChar(StartupInfo, SizeOf(TStartupInfo), 0);
    with StartupInfo do
    begin
      cb := SizeOf(TStartupInfo);
      wShowWindow := SW_SHOW;
    end;
    if CreateProcess(PChar(Prg), PChar(Format('%s %s', [Prg, FileName])),
      nil, nil, False, NORMAL_PRIORITY_CLASS, nil, nil, StartupInfo, ProcessInfo) then
    begin
      WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
      GetExitCodeProcess(ProcessInfo.hProcess, ErrorCode);
      CloseHandle(ProcessInfo.hProcess);
      CloseHandle(ProcessInfo.hThread);
      Result := True;
    end
    else
      ErrorCode := GetLastError;
  end;
end;

// Example, Beispiel:

procedure TForm1.Button1Click(Sender: TObject);
var
  ErrorCode: Cardinal;
begin
  StartAssociatedExe('c:\test.doc', ErrorCode);
end;
*************************************
在文本文件中替换
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;
***************************
直接建立一个Excel文件
const
  CXlsBof: array[0..5] of Word = ($809, 8, 00, $10, 0, 0);
  CXlsEof: array[0..1] of Word = ($0A, 00);
  CXlsLabel: array[0..5] of Word = ($204, 0, 0, 0, 0, 0);
  CXlsNumber: array[0..4] of Word = ($203, 14, 0, 0, 0);
  CXlsRk: array[0..4] of Word = ($27E, 10, 0, 0, 0);

procedure XlsBeginStream(XlsStream: TStream; const BuildNumber: Word);
begin
  CXlsBof[4] := BuildNumber;
  XlsStream.WriteBuffer(CXlsBof, SizeOf(CXlsBof));
end;

procedure XlsEndStream(XlsStream: TStream);
begin
  XlsStream.WriteBuffer(CXlsEof, SizeOf(CXlsEof));
end;

procedure XlsWriteCellRk(XlsStream: TStream; const ACol, ARow: Word;
  const AValue: Integer);
var
  V: Integer;
begin
  CXlsRk[2] := ARow;
  CXlsRk[3] := ACol;
  XlsStream.WriteBuffer(CXlsRk, SizeOf(CXlsRk));
  V := (AValue shl 2) or 2;
  XlsStream.WriteBuffer(V, 4);
end;

procedure XlsWriteCellNumber(XlsStream: TStream; const ACol, ARow: Word;
  const AValue: Double);
begin
  CXlsNumber[2] := ARow;
  CXlsNumber[3] := ACol;
  XlsStream.WriteBuffer(CXlsNumber, SizeOf(CXlsNumber));
  XlsStream.WriteBuffer(AValue, 8);
end;

procedure XlsWriteCellLabel(XlsStream: TStream; const ACol, ARow: Word;
  const AValue: string);
var
  L: Word;
begin
  L := Length(AValue);
  CXlsLabel[1] := 8 + L;
  CXlsLabel[2] := ARow;
  CXlsLabel[3] := ACol;
  CXlsLabel[5] := L;
  XlsStream.WriteBuffer(CXlsLabel, SizeOf(CXlsLabel));
  XlsStream.WriteBuffer(Pointer(AValue)^, L);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  FStream: TFileStream;
  I, J: Integer;
begin
  FStream := TFileStream.Create('c:\e.xls', fmCreate);
  try
    XlsBeginStream(FStream, 0);
    for I := 0 to 99 do
      for J := 0 to 99 do
      begin
        XlsWriteCellNumber(FStream, I, J, 34.34);
        // XlsWriteCellRk(FStream, I, J, 3434);
        // XlsWriteCellLabel(FStream, I, J, Format('Cell: %d,%d', [I, J]));
      end;
    XlsEndStream(FStream);
  finally
    FStream.Free;
  end;
end;
***************************************
获得正在运行的文件列表
uses
  Psapi, tlhelp32;

procedure CreateWin9xProcessList(List: TstringList);
var
  hSnapShot: THandle;
  ProcInfo: TProcessEntry32;
begin
  if List = nil then Exit;
  hSnapShot := CreateToolHelp32Snapshot(TH32CS_SNAPPROCESS, 0);
  if (hSnapShot <> THandle(-1)) then
  begin
    ProcInfo.dwSize := SizeOf(ProcInfo);
    if (Process32First(hSnapshot, ProcInfo)) then
    begin
      List.Add(ProcInfo.szExeFile);
      while (Process32Next(hSnapShot, ProcInfo)) do
        List.Add(ProcInfo.szExeFile);
    end;
    CloseHandle(hSnapShot);
  end;
end;

procedure CreateWinNTProcessList(List: TstringList);
var
  PIDArray: array [0..1023] of DWORD;
  cb: DWORD;
  I: Integer;
  ProcCount: Integer;
  hMod: HMODULE;
  hProcess: THandle;
  ModuleName: array [0..300] of Char;
begin
  if List = nil then Exit;
  EnumProcesses(@PIDArray, SizeOf(PIDArray), cb);
  ProcCount := cb div SizeOf(DWORD);
  for I := 0 to ProcCount - 1 do
  begin
    hProcess := OpenProcess(PROCESS_QUERY_INFORMATION or
      PROCESS_VM_READ,
      False,
      PIDArray[I]);
    if (hProcess <> 0) then
    begin
      EnumProcessModules(hProcess, @hMod, SizeOf(hMod), cb);
      GetModuleFilenameEx(hProcess, hMod, ModuleName, SizeOf(ModuleName));
      List.Add(ModuleName);
      CloseHandle(hProcess);
    end;
  end;
end;

procedure GetProcessList(var List: TstringList);
var
  ovi: TOSVersionInfo;
begin
  if List = nil then Exit;
  ovi.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
  GetVersionEx(ovi);
  case ovi.dwPlatformId of
    VER_PLATFORM_WIN32_WINDOWS: CreateWin9xProcessList(List);
    VER_PLATFORM_WIN32_NT: CreateWinNTProcessList(List);
  end
end;

function EXE_Running(FileName: string; bFullpath: Boolean): Boolean;
var
  i: Integer;
  MyProcList: TstringList;
begin
  MyProcList := TStringList.Create;
  try
    GetProcessList(MyProcList);
    Result := False;
    if MyProcList = nil then Exit;
    for i := 0 to MyProcList.Count - 1 do
    begin
      if not bFullpath then
      begin
        if CompareText(ExtractFileName(MyProcList.Strings[i]), FileName) = 0 then
          Result := True
      end
      else if CompareText(MyProcList.strings[i], FileName) = 0 then Result := True;
      if Result then Break;
    end;
  finally
    MyProcList.Free;
  end;
end;


// Example 1: Is a Exe-File running ?
procedure TForm1.Button1Click(Sender: TObject);
begin
  if EXE_Running('Notepad.exe', False) then
    ShowMessage('EXE is running')
  else
    ShowMessage('EXE is not running');
end;


// Example 2: List running Exe-Files
procedure TForm1.Button3Click(Sender: TObject);
var
  i: Integer;
  MyProcList: TstringList;
begin
  MyProcList := TStringList.Create;
  try
    GetProcessList(MyProcList);
    if MyProcList = nil then Exit;
    for i := 0 to MyProcList.Count - 1 do
      ListBox1.Items.Add(MyProcList.Strings[i]);
  finally
    MyProcList.Free;
  end;
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;

********************************
在控件中显示目录结构
procedure TForm1.GetDirectories(Tree: TTreeView; Directory: string; Item: TTreeNode; IncludeFiles: Boolean);
var
  SearchRec: TSearchRec;
  ItemTemp: TTreeNode;
begin
  Tree.Items.BeginUpdate;
  if Directory[Length(Directory)] <> '\' then Directory := Directory + '\';
  if FindFirst(Directory + '*.*', faDirectory, SearchRec) = 0 then
  begin
    repeat
      if (SearchRec.Attr and faDirectory = faDirectory) and (SearchRec.Name[1] <> '.') then
      begin
        if (SearchRec.Attr and faDirectory > 0) then
          Item := Tree.Items.AddChild(Item, SearchRec.Name);
        ItemTemp := Item.Parent;
        GetDirectories(Tree, Directory + SearchRec.Name, Item, IncludeFiles);
        Item := ItemTemp;
      end
      else if IncludeFiles then
        if SearchRec.Name[1] <> '.' then
          Tree.Items.AddChild(Item, SearchRec.Name);
    until FindNext(SearchRec) <> 0;
    FindClose(SearchRec);
  end;
  Tree.Items.EndUpdate;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  Node: TTreeNode;
  Path: string;
  Dir: string;
begin
  Dir := 'c:\temp';
  Screen.Cursor := crHourGlass;
  TreeView1.Items.BeginUpdate;
  try
    TreeView1.Items.Clear;
    GetDirectories(TreeView1, Dir, nil, True);
  finally
    Screen.Cursor := crDefault;
    TreeView1.Items.EndUpdate;
  end;
end;

********************************************
如何搜索字符串
{
  ScanFile searches for a string in a file and returns the position of the string
  in the file or -1, if not found.

  ScanFile sucht in einer Datei nach dem Vorkommen
  eines bestimmten Strings und gibt bei Erfolg die Position zurück, wo der String
  gefunden wurde.
}

function ScanFile(const FileName: string;
  const forString: string;
  caseSensitive: Boolean): Longint;
const
  BufferSize = $8001;  { 32K+1 bytes }
var
  pBuf, pEnd, pScan, pPos: PChar;
  filesize: LongInt;
  bytesRemaining: LongInt;
  bytesToRead: Integer;
  F: file;
  SearchFor: PChar;
  oldMode: Word;
begin
  { assume failure }
  Result := -1;
  if (Length(forString) = 0) or (Length(FileName) = 0) then Exit;
  SearchFor := nil;
  pBuf      := nil;
  { open file as binary, 1 byte recordsize }
  AssignFile(F, FileName, );
  oldMode  := FileMode;
,   FileMode := 0;    { read-only access }
  Reset(F, 1);
  FileMode := oldMode;
  try { allocate memory for buffer and pchar search string }
    SearchFor := StrAlloc(Length(forString) + 1);
    StrPCopy(SearchFor, forString);
    if not caseSensitive then  { convert to upper case }
      AnsiUpper(SearchFor);
    GetMem(pBuf, BufferSize);
    filesize       := System.Filesize(F);
    bytesRemaining := filesize;
    pPos           := nil;
    while bytesRemaining > 0 do
    begin
      { calc how many bytes to read this round }
      if bytesRemaining >= BufferSize then
        bytesToRead := Pred(BufferSize)
      else
        bytesToRead := bytesRemaining;
      { read a buffer full and zero-terminate the buffer }
      BlockRead(F, pBuf^, bytesToRead, bytesToRead);
      pEnd  := @pBuf[bytesToRead];
      pEnd^ := #0;
      pScan := pBuf;
      while pScan < pEnd do
      begin
        if not caseSensitive then { convert to upper case }
          AnsiUpper(pScan);
        pPos := StrPos(pScan, SearchFor);  { search for substring }
        if pPos <> nil then
        begin { Found it! }
          Result := FileSize - bytesRemaining +
            Longint(pPos) - Longint(pBuf);
          Break;
        end;
        pScan := StrEnd(pScan);
        Inc(pScan);
      end;
      if pPos <> nil then Break;
      bytesRemaining := bytesRemaining - bytesToRead;
      if bytesRemaining > 0 then
      begin
        Seek(F, FilePos(F) - Length(forString));
        bytesRemaining := bytesRemaining + Length(forString);
      end;
    end; { While }
  finally
    CloseFile(F);
    if SearchFor <> nil then StrDispose(SearchFor);
    if pBuf <> nil then FreeMem(pBuf, BufferSize);
  end;
end; { ScanFile }


// Search in autoexec.bat for "keyb" with case insensitive
// In der autoexec.bat nach "keyb" suchen

procedure TForm1.Button1Click(Sender: TObject);
var
  Position: integer;
begin
  Position := ScanFile('c:\autoexec.bat', 'keyb', False);
  ShowMessage(IntToStr(Position));
end;
***********************************
建立快捷键
uses
  Registry,
  ActiveX,
  ComObj,
  ShlObj;

type
  ShortcutType = (_DESKTOP, _QUICKLAUNCH, _SENDTO, _STARTMENU, _OTHERFOLDER);

function CreateShortcut(SourceFileName: string; // the file the shortcut points to
                        Location: ShortcutType; // shortcut location
                        SubFolder,  // subfolder of location
                        WorkingDir, // working directory property of the shortcut
                        Parameters,
                        Description: string): //  description property of the shortcut
                        string;
const
  SHELL_FOLDERS_ROOT = 'Software\MicroSoft\Windows\CurrentVersion\Explorer';
  QUICK_LAUNCH_ROOT = 'Software\MicroSoft\Windows\CurrentVersion\GrpConv';
var
  MyObject: IUnknown;
  MySLink: IShellLink;
  MyPFile: IPersistFile;
  Directory, LinkName: string;
  WFileName: WideString;
  Reg: TRegIniFile;
begin

  MyObject := CreateComObject(CLSID_ShellLink);
  MySLink := MyObject as IShellLink;
  MyPFile := MyObject as IPersistFile;

  MySLink.SetPath(PChar(SourceFileName));
  MySLink.SetArguments(PChar(Parameters));
  MySLink.SetDescription(PChar(Description));

  LinkName := ChangeFileExt(SourceFileName, '.lnk');
  LinkName := ExtractFileName(LinkName);

  // Quicklauch
  if Location = _QUICKLAUNCH then
  begin
    Reg := TRegIniFile.Create(QUICK_LAUNCH_ROOT);
    try
      Directory := Reg.ReadString('MapGroups', 'Quick Launch', '');
    finally
      Reg.Free;
    end;
  end
  else
  // Other locations
  begin
    Reg := TRegIniFile.Create(SHELL_FOLDERS_ROOT);
    try
    case Location of
      _OTHERFOLDER : Directory := SubFolder;
      _DESKTOP     : Directory := Reg.ReadString('Shell Folders', 'Desktop', '');
      _STARTMENU   : Directory := Reg.ReadString('Shell Folders', 'Start Menu', '');
      _SENDTO      : Directory := Reg.ReadString('Shell Folders', 'SendTo', '');
    end;
    finally
      Reg.Free;
    end;
  end;

  if Directory <> '' then
  begin
    if (SubFolder <> '') and (Location <> _OTHERFOLDER) then
      WFileName := Directory + '\' + SubFolder + '\' + LinkName
    else
      WFileName := Directory + '\' + LinkName;


    if WorkingDir = '' then
      MySLink.SetWorkingDirectory(PChar(ExtractFilePath(SourceFileName)))
    else
      MySLink.SetWorkingDirectory(PChar(WorkingDir));

    MyPFile.Save(PWChar(WFileName), False);
    Result := WFileName;
  end;
end;

function GetProgramDir: string;
var
  reg: TRegistry;
begin
  reg := TRegistry.Create;
  try
    reg.RootKey := HKEY_CURRENT_USER;
    reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders', False);
    Result := reg.ReadString('Programs');
    reg.CloseKey;
  finally
    reg.Free;
  end;
end;

// Some examples:

procedure TForm1.Button1Click(Sender: TObject);
const
PROGR = 'c:\YourProgram.exe';
var
  resPath: string;
begin
  //Create a Shortcut in the Quckick launch toolbar
  CreateShortcut(PROGR, _QUICKLAUNCH, '','','','Description');

  //Create a Shortcut on the Desktop
  CreateShortcut(PROGR, _DESKTOP, '','','','Description');

  //Create a Shortcut in the Startmenu /"Programs"-Folder
  resPath := CreateShortcut(PROGR, _OTHERFOLDER, GetProgramDir,'','','Description');
  if resPath <> '' then
  begin
    ShowMessage('Shortcut Successfully created in: ' + resPath);
  end;
end;


******************************************
在文本文件中搜索
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Buttons;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Memo1: TMemo;
    Edit1: TEdit;
    SpeedButton1: TSpeedButton;
    procedure SpeedButton1Click(Sender: TObject);
  private
    { Private-Deklarationen }
  public
    { Public-Deklarationen }
  end;

var
  Form1: TForm1;



  // Aus einem alten c't-Heft von C nach Delphi übersetzt
  // Deklarationsteil

procedure Ts_init(P: PChar; m: Integer);
function Ts_Search(Text, p: PChar; m: Integer; Start: Longint): Longint;



  // Globale Variablen
  // *****************


var

  shift: array[0..255] of Byte;     // Shifttabelle für Turbosearch
  Look_At: Integer;                   // Look_At-Position für Turbosearch



implementation

{$R *.DFM}


procedure Ts_init(P: PChar; m: Integer);
var
  i: Integer;
begin
  // *** Suchmuster analysieren ****

  {1.}   for i := 0 to 255 do shift[i] := m + 1;
  {2.}   for i := 0 to m - 1 do Shift[Ord(p[i])] := m - i;

  Look_at := 0;

  {3.}   while (look_At < m - 1) do  
  begin
    if (p[m - 1] = p[m - (look_at + 2)]) then Exit
    else  
      Inc(Look_at, 1);
  end;

  // *** Beschreibung ****
  //  1. Sprungtabelle Shift[0..255] wird mit der max. Sprungweite (Musterl?nge+1)
  //     initialisiert.
  //  2. Für jedes Zeichen im Muster wird seine Position (von hinten gez?hlt) in
  //     der Shift-Tabelle eingetragen.
  //     Für das Muster "Hans" würden folgende Shiftpositionen ermittelt werde:
  //      Für H  = ASCII-Wert = 72d ,dass von hinten gez?hlt an der 4. Stelle ist,
  //                                 wird Shift[72] := 4 eingetragen.
  //      Für a  = 97d   = Shift[97]  := 3;
  //      Für n  = 110d  = Shift[110] := 2;
  //      Für s  = 115d  = Shift[115] := 1;
  //     Da das Muster von Vorn nach Hinten durchsucht wird, sind doppelt auf-
  //     tretende Zeichen kein Problem. Die Shift-Werte werden überschrieben und
  //     mit der kleinsten Sprungweite automatisch aktualisiert.
  //  3. Untersucht wo (position von hinten) das Letzte Zeichen im Muster
  //     nochmals vorkommt und Speichert diese in der Variable Look_AT.
  //     Die Maximale Srungweite beim Suchen kann also 2*Musterl?nge sein wenn
  //     das letzte Zeichen nur einmal im Muster vorhanden ist.
end;


function Ts_Search(Text, p: PChar; m: Integer; Start: Longint): Longint;
var
  I: Longint;
  T: PChar;
begin
  T      := Text + Start;   // Zeiger auf Startposition im Text setzen
  Result := -1;
  repeat
    i := m - 1;
    // Letztes Zeichen des Suchmusters im Text suchen.
    while (t[i] <> p[i]) do t := t + shift[Ord(t[m])];
    i := i - 1;  // Vergleichszeiger auf vorletztes Zeichen setzen
    if i < 0 then i := 0; // wenn nach nur einem Zeichen gesucht wird,
    // kann i = -1 werden.
    // restliche Zeichen des Musters vergleichen
    while (t[i] = p[i]) do  
    begin
      if i = 0 then Result := t - Text;
      i := i - 1;
    end;
    // Muster nicht gefunden -> Sprung um max. 2*m
    if Result = -1 then t := t + Look_AT + shift[Ord(t[m + look_at])];
  until Result <> -1; // Repeat
end;

//  Such-Procedure ausl?sen  (hier beim drücken eines Speedbuttons auf FORM1)

procedure TForm1.SpeedButton1Click(Sender: TObject);
var
  tt: string;
  L: Integer;
  L2, sp, a: Longint;
  F: file;         // File-Alias
  Size: Integer;   // Textl?nge
  Buffer: PChar;   // Text-Memory-Buffer
begin
  tt := Edit1.Text;      // Suchmuster
  L  := Length(TT);      // Suchmusterl?nge
  ts_init(PChar(TT), L); // Sprungtabelle für Suchmuster initialisieren
  try
    AssignFile(F, 'test.txt');
    Reset(F, 1);                   // File ?ffnen
    Size := FileSize(F);           // Filegr?sse ermitteln
    GetMem(Buffer, Size + L + 1);      // Memory reservieren in der Gr?sse von
    // TextFilel?nge+Musterl?nge+1
    try
      BlockRead(F, Buffer^, Size);  // Filedaten in den Buffer füllen
      StrCat(Buffer, PChar(TT));     // Suchmuster ans Ende des Textes anh?ngen
      // damit der Suchalgorythmus keine Fileende-
      // Kontrolle machen muss.
      // Turbo-Search

      SP := 0;               // Startpunkt der Suche im Text
      A  := 0;               // Anzahl-gefunden-Z?hler
      while SP < Size do
      begin
        L2 := Ts_Search(Buffer, PChar(TT), L, SP); // L = Musterl?nge
        // SP= Startposition im Text

        SP := L2 + L; // StartPosition auf Letzte gefundene Position+Musterl?nge
        Inc(a);     // Anzahl gefunden Z?hler
      end;
      // Am Schluss nicht vergessen Buffer freigeben und Inputfile schliessen
    finally
      FreeMem(Buffer);              // Memory freigeben.
    end;
  finally
    CloseFile(F);                   // Datei schliessen.
  end;
end;

end.


*************************************
获得HTTP数据
uses IdMultipartFormData;

{ .... }

procedure TForm1.Button1Click(Sender: TObject);
var
  data: TIdMultiPartFormDataStream;
begin
  data := TIdMultiPartFormDataStream.Create;
  try
    { add the used parameters for the script }
    data.AddFormField('param1', 'value1');
    data.AddFormField('param2', 'value2');
    data.AddFormField('param3', 'value3');

    { Call the Post method of TIdHTTP and read the result into TMemo }
    Memo1.Lines.Text := IdHTTP1.Post('http://localhost/script.php', data);
  finally
    data.Free;
  end;
end;

*****************************
发送邮件
{
  You must have the component TNMSMTP from FastNet tools.
  This component is included in Delphi 4-5 Professional and Enterprise

  Die TNMSMTP von FastNet tools wird bentigt.
  Die Komponente ist in Delphi 4-5 Professional
  und Enterprise Versionen enthalten.
}


procedure TForm1.Button1Click(Sender: TObject);
begin
  NMSMTP1.Host   := 'mail.host.com';
  NMSMTP1.UserID := 'Username';
  NMSMTP1.Connect;
  NMSMTP1.PostMessage.FromAddress       := 'webmaster@swissdelphicenter.ch';
  NMSMTP1.PostMessage.ToAddress.Text    := 'user@host.com';
  NMSMTP1.PostMessage.ToCarbonCopy.Text := 'AnotherUser@host.com';
  NMSMTP1.PostMessage.ToBlindCarbonCopy.Text := 'AnotherUser@host.com';
  NMSMTP1.PostMessage.Body.Text         := 'This is the message';
  NMSMTP1.PostMessage.Attachments.Text  := 'c:\File.txt';
  NMSMTP1.PostMessage.Subject           := 'Mail subject';
  NMSMTP1.SendMail;
  ShowMessage('Mail sent !');
  NMSMTP1.Disconnect;
end;
********************************
对计算机的操作
{1.}

function MyExitWindows(RebootParam: Longword): Boolean;
var
  TTokenHd: THandle;
  TTokenPvg: TTokenPrivileges;
  cbtpPrevious: DWORD;
  rTTokenPvg: TTokenPrivileges;
  pcbtpPreviousRequired: DWORD;
  tpResult: Boolean;
const
  SE_SHUTDOWN_NAME = 'SeShutdownPrivilege';
begin
  if Win32Platform = VER_PLATFORM_WIN32_NT then
  begin
    tpResult := OpenProcessToken(GetCurrentProcess(),
      TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY,
      TTokenHd);
    if tpResult then
    begin
      tpResult := LookupPrivilegeValue(nil,
                                       SE_SHUTDOWN_NAME,
                                       TTokenPvg.Privileges[0].Luid);
      TTokenPvg.PrivilegeCount := 1;
      TTokenPvg.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
      cbtpPrevious := SizeOf(rTTokenPvg);
      pcbtpPreviousRequired := 0;
      if tpResult then
        Windows.AdjustTokenPrivileges(TTokenHd,
                                      False,
                                      TTokenPvg,
                                      cbtpPrevious,
                                      rTTokenPvg,
                                      pcbtpPreviousRequired);
    end;
  end;
  Result := ExitWindowsEx(RebootParam, 0);
end;

// Example to shutdown Windows:

procedure TForm1.Button1Click(Sender: TObject);
begin
  MyExitWindows(EWX_POWEROFF or EWX_FORCE);
end;

// Example to reboot Windows:

procedure TForm1.Button1Click(Sender: TObject);
begin
  MyExitWindows(EWX_REBOOT or EWX_FORCE);
end;


// Parameters for MyExitWindows()


{************************************************************************}

{2. Console Shutdown Demo}

program Shutdown;
{$APPTYPE CONSOLE}

uses
  SysUtils,
  Windows;

// Shutdown Program
// (c) 2000 NeuralAbyss Software
// www.neuralabyss.com

var
  logoff: Boolean = False;
  reboot: Boolean = False;
  warn: Boolean = False;
  downQuick: Boolean = False;
  cancelShutdown: Boolean = False;
  powerOff: Boolean = False;
  timeDelay: Integer = 0;

function HasParam(Opt: Char): Boolean;
var
  x: Integer;
begin
  Result := False;
  for x := 1 to ParamCount do
    if (ParamStr(x) = '-' + opt) or (ParamStr(x) = '/' + opt) then Result := True;
end;

function GetErrorstring: string;
var
  lz: Cardinal;
  err: array[0..512] of Char;
begin
  lz := GetLastError;
  FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, nil, lz, 0, @err, 512, nil);
  Result := string(err);
end;

procedure DoShutdown;
var
  rl, flgs: Cardinal;
  hToken: Cardinal;
  tkp: TOKEN_PRIVILEGES;
begin
  flgs := 0;
  if downQuick then flgs := flgs or EWX_FORCE;
  if not reboot then flgs := flgs or EWX_SHUTDOWN;
  if reboot then flgs := flgs or EWX_REBOOT;
  if poweroff and (not reboot) then flgs := flgs or EWX_POWEROFF;
  if logoff then flgs := (flgs and (not (EWX_REBOOT or EWX_SHUTDOWN or EWX_POWEROFF))) or
      EWX_LOGOFF;
  if Win32Platform = VER_PLATFORM_WIN32_NT then
  begin
    if not OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY,
      hToken) then
      Writeln('Cannot open process token. [' + GetErrorstring + ']')
    else
    begin
      if LookupPrivilegeValue(nil, 'SeShutdownPrivilege', tkp.Privileges[0].Luid) then
      begin
        tkp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
        tkp.PrivilegeCount           := 1;
        AdjustTokenPrivileges(hToken, False, tkp, 0, nil, rl);
        if GetLastError <> ERROR_SUCCESS then
          Writeln('Error adjusting process privileges.');
      end
      else
        Writeln('Cannot find privilege value. [' + GetErrorstring + ']');
    end;
    {   if CancelShutdown then
          if AbortSystemShutdown(nil) = False then
            Writeln(\'Cannot abort. [\' + GetErrorstring + \']\')
          else
           Writeln(\'Cancelled.\')
       else
       begin
         if InitiateSystemShutdown(nil, nil, timeDelay, downQuick, Reboot) = False then
            Writeln(\'Cannot go down. [\' + GetErrorstring + \']\')
         else
            Writeln(\'Shutting down!\');
       end;
    }
  end;
  //     else begin
  ExitWindowsEx(flgs, 0);
  //     end;
end;

begin
  Writeln('Shutdown v0.3 for Win32 (similar to the Linux version)');
  Writeln('(c) 2000 NeuralAbyss Software. All Rights Reserved.');
  if HasParam('?') or (ParamCount = 0) then
  begin
    Writeln('Usage:    shutdown [-akrhfnc] [-t secs]');
    Writeln('                  -k:      don''t really shutdown, only warn.');
    Writeln('                  -r:      reboot after shutdown.');
    Writeln('                  -h:      halt after shutdown.');
    Writeln('                  -p:      power off after shutdown');
    Writeln('                  -l:      log off only');
    Writeln('                  -n:      kill apps that don''t want to die.');
    Writeln('                  -c:      cancel a running shutdown.');
  end
  else
  begin
    if HasParam('k') then warn := True;
    if HasParam('r') then reboot := True;
    if HasParam('h') and reboot then
    begin
      Writeln('Error: Cannot specify -r and -h parameters together!');
      Exit;
    end;
    if HasParam('h') then reboot := False;
    if HasParam('n') then downQuick := True;
    if HasParam('c') then cancelShutdown := True;
    if HasParam('p') then powerOff := True;
    if HasParam('l') then logoff := True;
    DoShutdown;
  end;
end.




   
// Parameters for MyExitWindows()


EWX_LOGOFF

Shuts down all processes running in the security context of the process that called the
ExitWindowsEx function. Then it logs the user off.

Alle Prozesse des Benutzers werden beendet, danach wird der Benutzer abgemeldet.

EWX_POWEROFF

Shuts down the system and turns off the power.
The system must support the power-off feature.
Windows NT/2000/XP:
The calling process must have the SE_SHUTDOWN_NAME privilege.

F?hrt Windows herunter und setzt den Computer in den StandBy-Modus,
sofern von der Hardware unterstützt.

EWX_REBOOT

Shuts down the system and then restarts the system.
Windows NT/2000/XP: The calling process must have the SE_SHUTDOWN_NAME privilege.

F?hrt Windows herunter und startet es neu.

EWX_SHUTDOWN

Shuts down the system to a point at which it is safe to turn off the power.
All file buffers have been flushed to disk, and all running processes have stopped.
If the system supports the power-off feature, the power is also turned off.
Windows NT/2000/XP: The calling process must have the SE_SHUTDOWN_NAME privilege.

F?hrt Windows herunter.


EWX_FORCE

Forces processes to terminate. When this flag is set,
the system does not send the WM_QUERYENDSESSION and WM_ENDSESSION messages.
This can cause the applications to lose data.
Therefore, you should only use this flag in an emergency.

Die aktiven Prozesse werden zwangsweise und ohne Rückfrage beendet.

EWX_FORCEIFHUNG

Windows 2000/XP: Forces processes to terminate if they do not respond to the
WM_QUERYENDSESSION or WM_ENDSESSION message. This flag is ignored if EWX_FORCE is used.

Windows 2000/XP: Die aktiven Prozesse werden aufgefordert, sich selbst zu beenden und
müssen dies best?tigen. Reagieren sie nicht, werden sie zwangsweise beendet.



*****************************************
从网上下载文件
1.}

uses
  URLMon, ShellApi;

function DownloadFile(SourceFile, DestFile: string): Boolean;
begin
  try
    Result := UrlDownloadToFile(nil, PChar(SourceFile), PChar(DestFile), 0, nil) = 0;
  except
    Result := False;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
const
  // URL Location
  SourceFile = 'http://www.guochao.com/admin/editer/UploadFile/2004730132037734.gif';
  // Where to save the file
  DestFile = 'c:\temp\google-image.gif';
begin
  if DownloadFile(SourceFile, DestFile) then
  begin
    ShowMessage('Download succesful!');
    // Show downloaded image in your browser
    ShellExecute(Application.Handle, PChar('open'), PChar(DestFile),
      PChar(''), nil, SW_NORMAL)
  end
  else
    ShowMessage('Error while downloading ' + SourceFile)
end;

// Minimum availability: Internet Explorer 3.0
// Minimum operating systems Windows NT 4.0, Windows 95

{********************************************************}

{2.}


uses
  Wininet;

function DownloadURL(const aUrl: string): Boolean;
var
  hSession: HINTERNET;
  hService: HINTERNET;
  lpBuffer: array[0..1024 + 1] of Char;
  dwBytesRead: DWORD;
begin
  Result := False;
  // hSession := InternetOpen( 'MyApp', INTERNET_OPEN_TYPE_DIRECT, nil, nil, 0);
  hSession := InternetOpen('MyApp', INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
  try
    if Assigned(hSession) then
    begin
      hService := InternetOpenUrl(hSession, PChar(aUrl), nil, 0, 0, 0);
      if Assigned(hService) then
        try
          while True do
          begin
            dwBytesRead := 1024;
            InternetReadFile(hService, @lpBuffer, 1024, dwBytesRead);
            if dwBytesRead = 0 then break;
            lpBuffer[dwBytesRead] := #0;
            Form1.Memo1.Lines.Add(lpBuffer);
          end;
          Result := True;
        finally
          InternetCloseHandle(hService);
        end;
    end;
  finally
    InternetCloseHandle(hSession);
  end;
end;

{********************************************************}

{3. Forces a download of the requested file, object, or directory listing from the origin server,
    not from the cache
}

function DownloadURL_NOCache(const aUrl: string; var s: String): Boolean;
var
  hSession: HINTERNET;
  hService: HINTERNET;
  lpBuffer: array[0..1024 + 1] of Char;
  dwBytesRead: DWORD;
begin
  Result := False;
  s := '';
  // hSession := InternetOpen( 'MyApp', INTERNET_OPEN_TYPE_DIRECT, nil, nil, 0);
  hSession := InternetOpen('MyApp', INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
  try
    if Assigned(hSession) then
    begin
      hService := InternetOpenUrl(hSession, PChar(aUrl), nil, 0, INTERNET_FLAG_RELOAD, 0);
      if Assigned(hService) then
        try
          while True do
          begin
            dwBytesRead := 1024;
            InternetReadFile(hService, @lpBuffer, 1024, dwBytesRead);
            if dwBytesRead = 0 then break;
            lpBuffer[dwBytesRead] := #0;
            s := s + lpBuffer;
          end;
          Result := True;
        finally
          InternetCloseHandle(hService);
        end;
    end;
  finally
    InternetCloseHandle(hSession);
  end;
end;

//aufrufen
var
  s: String;
begin
if DownloadURL('http://www.swissdelphicenter.ch/', s) then
   ShowMessage(s);
end;

************************************
通过句柄获得正在运行的文件的路径
uses
  PsAPI, TlHelp32;
// portions by Project Jedi www.delphi-jedi.org/
const
  RsSystemIdleProcess = 'System Idle Process';
  RsSystemProcess = 'System Process';

function IsWinXP: Boolean;
begin
  Result := (Win32Platform = VER_PLATFORM_WIN32_NT) and
    (Win32MajorVersion = 5) and (Win32MinorVersion = 1);
end;

function IsWin2k: Boolean;
begin
  Result := (Win32MajorVersion >= 5) and
    (Win32Platform = VER_PLATFORM_WIN32_NT);
end;

function IsWinNT4: Boolean;
begin
  Result := Win32Platform = VER_PLATFORM_WIN32_NT;
  Result := Result and (Win32MajorVersion = 4);
end;

function IsWin3X: Boolean;
begin
  Result := Win32Platform = VER_PLATFORM_WIN32_NT;
  Result := Result and (Win32MajorVersion = 3) and
    ((Win32MinorVersion = 1) or (Win32MinorVersion = 5) or
    (Win32MinorVersion = 51));
end;

function RunningProcessesList(const List: TStrings; FullPath: Boolean): Boolean;

  function ProcessFileName(PID: DWORD): string;
  var
    Handle: THandle;
  begin
    Result := '';
    Handle := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, False, PID);
    if Handle <> 0 then
      try
        SetLength(Result, MAX_PATH);
        if FullPath then
        begin
          if GetModuleFileNameEx(Handle, 0, PChar(Result), MAX_PATH) > 0 then
            SetLength(Result, StrLen(PChar(Result)))
          else
            Result := '';
        end
        else
        begin
          if GetModuleBaseNameA(Handle, 0, PChar(Result), MAX_PATH) > 0 then
            SetLength(Result, StrLen(PChar(Result)))
          else
            Result := '';
        end;
      finally
        CloseHandle(Handle);
      end;
  end;

  function BuildListTH: Boolean;
  var
    SnapProcHandle: THandle;
    ProcEntry: TProcessEntry32;
    NextProc: Boolean;
    FileName: string;
  begin
    SnapProcHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
    Result := (SnapProcHandle <> INVALID_HANDLE_VALUE);
    if Result then
      try
        ProcEntry.dwSize := SizeOf(ProcEntry);
        NextProc := Process32First(SnapProcHandle, ProcEntry);
        while NextProc do
        begin
          if ProcEntry.th32ProcessID = 0 then
          begin
            // PID 0 is always the "System Idle Process" but this name cannot be
            // retrieved from the system and has to be fabricated.
            FileName := RsSystemIdleProcess;
          end
          else
          begin
            if IsWin2k or IsWinXP then
            begin
              FileName := ProcessFileName(ProcEntry.th32ProcessID);
              if FileName = '' then
                FileName := ProcEntry.szExeFile;
            end
            else
            begin
              FileName := ProcEntry.szExeFile;
              if not FullPath then
                FileName := ExtractFileName(FileName);
            end;
          end;
          List.AddObject(FileName, Pointer(ProcEntry.th32ProcessID));
          NextProc := Process32Next(SnapProcHandle, ProcEntry);
        end;
      finally
        CloseHandle(SnapProcHandle);
      end;
  end;

  function BuildListPS: Boolean;
  var
    PIDs: array [0..1024] of DWORD;
    Needed: DWORD;
    I: Integer;
    FileName: string;
  begin
    Result := EnumProcesses(@PIDs, SizeOf(PIDs), Needed);
    if Result then
    begin
      for I := 0 to (Needed div SizeOf(DWORD)) - 1 do
      begin
        case PIDs[I] of
          0:
            // PID 0 is always the "System Idle Process" but this name cannot be
            // retrieved from the system and has to be fabricated.
            FileName := RsSystemIdleProcess;
          2:
            // On NT 4 PID 2 is the "System Process" but this name cannot be
            // retrieved from the system and has to be fabricated.
            if IsWinNT4 then
              FileName := RsSystemProcess
            else
              FileName := ProcessFileName(PIDs[I]);
            8:
            // On Win2K PID 8 is the "System Process" but this name cannot be
            // retrieved from the system and has to be fabricated.
            if IsWin2k or IsWinXP then
              FileName := RsSystemProcess
            else
              FileName := ProcessFileName(PIDs[I]);
            else
              FileName := ProcessFileName(PIDs[I]);
        end;
        if FileName <> '' then
          List.AddObject(FileName, Pointer(PIDs[I]));
      end;
    end;
  end;
begin
  if IsWin3X or IsWinNT4 then
    Result := BuildListPS
  else
    Result := BuildListTH;
end;

function GetProcessNameFromWnd(Wnd: HWND): string;
var
  List: TStringList;
  PID: DWORD;
  I: Integer;
begin
  Result := '';
  if IsWindow(Wnd) then
  begin
    PID := INVALID_HANDLE_VALUE;
    GetWindowThreadProcessId(Wnd, @PID);
    List := TStringList.Create;
    try
      if RunningProcessesList(List, True) then
      begin
        I := List.IndexOfObject(Pointer(PID));
        if I > -1 then
          Result := List[I];
      end;
    finally
      List.Free;
    end;
  end;
end;



************************
注册系统热键
{
  The following example demonstrates registering hotkeys with the
  system to globally trap keys.

  Das Folgende Beispiel zeigt, wie man Hotkeys registrieren und
  darauf reagieren kann, wenn sie gedrückt werden. (systemweit)
}

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
    id1, id2, id3, id4: Integer;
    procedure WMHotKey(var Msg: TWMHotKey); message WM_HOTKEY;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

// Trap Hotkey Messages
procedure TForm1.WMHotKey(var Msg: TWMHotKey);
begin
  if Msg.HotKey = id1 then
    ShowMessage('Ctrl + A pressed !');
  if Msg.HotKey = id2 then
    ShowMessage('Ctrl + Alt + R pressed !');
  if Msg.HotKey = id3 then
    ShowMessage('Win + F4 pressed !');
  if Msg.HotKey = id4 then
    ShowMessage('Print Screen pressed !');
end;

procedure TForm1.FormCreate(Sender: TObject);
  // Different Constants from Windows.pas
const
  MOD_ALT = 1;
  MOD_CONTROL = 2;
  MOD_SHIFT = 4;
  MOD_WIN = 8;
  VK_A = $41;
  VK_R = $52;
  VK_F4 = $73;
begin
  // Register Hotkey Ctrl + A
  id1 := GlobalAddAtom('Hotkey1');
  RegisterHotKey(Handle, id1, MOD_CONTROL, VK_A);

  // Register Hotkey Ctrl + Alt + R
  id2 := GlobalAddAtom('Hotkey2');
  RegisterHotKey(Handle, id2, MOD_CONTROL + MOD_Alt, VK_R);

  // Register Hotkey Win + F4
  id3 := GlobalAddAtom('Hotkey3');
  RegisterHotKey(Handle, id3, MOD_WIN, VK_F4);

  // Globally trap the Windows system key "PrintScreen"
  i, d4 := GlobalAddAtom('Hotkey4');
  RegisterHotKey, (Handle, id4, 0, VK_SNAPSHOT);
end;

// Unregister the Hotkeys
procedure TForm1.FormDestroy(Sender: TObject);
begin
  UnRegisterHotKey(Handle, id1);
  GlobalDeleteAtom(id1);
  UnRegisterHotKey(Handle, id2);
  GlobalDeleteAtom(id2);
  UnRegisterHotKey(Handle, id3);
  GlobalDeleteAtom(id3);
  UnRegisterHotKey(Handle, id4);
  GlobalDeleteAtom(id4);
end;

end.

{
  RegisterHotKey fails if the keystrokes specified for the hot key have
  already been registered by another hot key.

  Windows NT4 and Windows 2000/XP: The F12 key is reserved for use by the
  debugger at all times, so it should not be registered as a hot key. Even
  when you are not debugging an application, F12 is reserved in case a
  kernel-mode debugger or a just-in-time debugger is resident.
}

« 上一篇 | 下一篇 »