动态建立一个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.
}