delphi进行pptp拨号的源代码(50分)

{*******************************************************}
{ }
{ Windows VPN Client }
{ }
{ Version 1.00 }
{ }
{ Author : Shadow by Apr. 08 2002 }
{ }
{*******************************************************}
unit dialunit;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, DialUp, ComCtrls, ExtCtrls, shellapi;

const
WM_TRAYNOTIFY = WM_USER + 200;
type
TForm1 = class(TForm)
Button1: TButton;
DialUp1: TDialUp;
DialBtn: TButton;
StatusBar1: TStatusBar;
Timer1: TTimer;
UserNameTxt: TEdit;
PasswordTxt: TEdit;
Label1: TLabel;
Label2: TLabel;
IPAddrTxt: TEdit;
Label3: TLabel;
Label4: TLabel;
Label5: TLabel;
procedure Button1Click(Sender: TObject);
procedure DialBtnClick(Sender: TObject);
procedure DialUp1AsyncEvent(Sender: TObject; State, Error: Integer;
MessageText: String);
procedure Timer1Timer(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure IPAddrTxtKeyPress(Sender: TObject; var Key: Char);
procedure UserNameTxtKeyPress(Sender: TObject; var Key: Char);
procedure PasswordTxtKeyPress(Sender: TObject; var Key: Char);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
procedure TrayNotifyMessage(var Sender: TMessage); message WM_TRAYNOTIFY;
procedure MarkTaskBarIcon(Sender: TObject);
procedure WMHotKey(var msg : TWMHotKey);message WM_HOTKEY;
public
{ Public declarations }
function GetSystemVer() : String;
procedure CreateConn();
procedure HangUpConn();
function CreateMutex : Boolean;
procedure DestroyMutex;
end;

var
Form1: TForm1;
tnd : TNOTIFYICONDATA;

implementation
var
mutex : hWnd;
CloseFlag : boolean;
hotKeyId : integer;

{$R *.DFM}

function TForm1.CreateMutex : Boolean;
var
PrevInstHandle : THandle;
WndCaption : array[0..254] of char;
ClassName : array[0..30] of char;
AppTitle : Pchar;
begin
AppTitle := StrAlloc(100);
StrPCopy(AppTitle,Application.Title);
Result := True;
Mutex := Windows.CreateMutex(nil,False,AppTitle);
if (GetLastError = ERROR_ALREADY_EXISTS) or (Mutex = 0) then
begin
Result := False;
SetWindowText(Application.Handle,'');
PrevInstHandle := FindWindow(nil,AppTitle);
if PrevInstHandle <> 0 then
begin
GetWindowText(PrevInstHandle,@WndCaption,254);
GetClassName(PrevInstHandle, ClassName,30);
if ClassName = 'TApplication' then
begin
if IsIconic(PrevInstHandle) then //判断是否已经最小化
ShowWindow(PrevInstHandle,SW_RESTORE)
else
SetForegroundWindow(PrevInstHandle);
end;
end;
if Mutex <> 0 then
Mutex := 0;
end;
StrDispose(AppTitle);
end;

procedure TForm1.DestroyMutex;
begin
if Mutex <> 0 then
CloseHandle(Mutex);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
Application.ProcessMessages;
HangUpConn;
Application.ProcessMessages;
DialUp1.Entry := 'VPN conn';
Application.ProcessMessages;
DialUp1.DeleteEntry;
Application.ProcessMessages;
CloseFlag := True;
close;
end;

procedure TForm1.DialBtnClick(Sender: TObject);
begin
if trim(UserNameTxt.Text) = '' then
begin
UserNameTxt.SetFocus;
exit;
end;
if trim(PassWordTxt.Text) = '' then
begin
PassWordTxt.SetFocus;
exit;
end;
if Trim(IPAddrTxt.text) = '' then
begin
IPAddrTxt.SetFocus;
exit;
end;
CreateConn;
DialUp1.Entry := 'VPN conn';
DialUp1.SetEntryUserName(UserNameTxt.Text);
DialUp1.SetEntryPassword(PassWordTxt.Text);
DialUp1.Dial;
DialBtn.Enabled := False;
end;

procedure TForm1.DialUp1AsyncEvent(Sender: TObject; State, Error: Integer;
MessageText: String);
begin
Self.StatusBar1.Panels[1].Text := MessageText;
Application.ProcessMessages;
if MessageText = '连接成功' then
begin
DialUp1.InitializePerfStats(True,True);
// Label5.Caption := 'Server IP: ' + DialUp1.ServerIP ;
// label4.Caption := ' Local IP: ' + DialUp1.ClientIP;
// IPAddrTxt.color := clScrollBar;
IPAddrTxt.Enabled := False;
UserNametxt.Enabled := False;
PassWordTxt.Enabled := False;
DialBtn.Enabled := False;
Timer1.Enabled:=True;
SendMessage(Handle,WM_SYSCOMMAND,SC_MINIMIZE,0);
end;
if Error <> 0 Then
begin
case Error of
691: begin
messagebox(handle,'用户名或密码错误','错误',MB_ICONERROR);
DialBtn.Enabled := True;
DialBtn.SetFocus;
end;
678: begin
messagebox(handle,'指定的服务器不存在或没有打开VPN服务','错误',MB_ICONERROR);
DialBtn.Enabled := True;
DialBtn.SetFocus;
end;
769: begin
messagebox(handle,'服务器地址非法或域名不存在','错误',MB_ICONERROR);
DialBtn.Enabled := True;
DialBtn.SetFocus;
end;
619: begin
messagebox(handle,'指定的端口没有连接','错误',MB_ICONERROR);
DialBtn.Enabled := True;
DialBtn.SetFocus;
end;
end;
end;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
if not DialUp1.GetPerfStats then
begin
Beep;
Self.StatusBar1.Panels[3].Text:='ERROR';
Self.StatusBar1.Panels[5].Text:='ERROR';
end else
begin
Self.StatusBar1.Panels[3].Text:=IntToStr(DialUp1.BytesXmit);
Self.StatusBar1.Panels[5].Text:=IntToStr(DialUp1.BytesRecv);
end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
CloseFlag := False;
Application.OnMinimize := MarkTaskBarIcon;
EnableMenuItem(GetSystemMenu(Handle,False),sc_CLOSE,MF_GRAYED);
hotkeyid := GlobalAddATom('chyDefineHotKey');
registerhotkey(handle,hotkeyid,mod_control,81);
end;

function TForm1.GetSystemVer: String;
var
MyVerInfo : TOSVersionInfo;
begin
MyVerInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
GetVersionEx(MyVerInfo);
case MyVerInfo.dwPlatformId of
VER_PLATFORM_WIN32s: result := 'Win 32s under Windows 3.1';
VER_PLATFORM_WIN32_WINDOWS:
if (MyVerInfo.dwMinorVersion = 0) then
if Trim(MyVerInfo.szCSDVersion) = 'B' then
Result := 'Windows 95OSR2'
else
Result := 'Windows 95'
else if MyVerInfo.dwMinorVersion = 10 then
if Trim(MyVerInfo.szCSDVersion) = 'A' then
Result := 'Windows 98SE'
else
Result := 'Windows 98'
else if MyVerInfo.dwMinorVersion = 90 then
result := 'Windows ME';
VER_PLATFORM_WIN32_NT:
case MyVerInfo.dwMajorVersion of
3: result := 'Windows NT3.0';
4: result := 'Windows NT4.0';
5:
if MyVerInfo.dwMinorVersion >= 1 then
result := 'Windows XP'
else
result := 'Windows 2000';
end;
end;
end;

procedure TForm1.CreateConn;
var
rasEntry : TRasEntry;
rasEntrySize :longInt;
dwResult : longInt;
begin
rasEntrySize := SizeOf(rasEntry);
fillchar(rasEntry,rasEntrySize,0);
rasEntry.dwSize := rasEntrySize;
rasEntry.szDeviceType := RASDT_Vpn;
rasEntry.dwfOptions := RASEO_RequireMsEncryptedPw or RASEO_RequireDataEncryption or
RASEO_IpHeaderCompression or RASEO_RemoteDefaultGateway or
RASEO_RequireEncryptedPw or RASEO_SwCompression or
RASEO_NetworkLogon or RASEO_UseCountryAndAreaCodes;
strpcopy(rasEntry.szLocalPhoneNumber,IPAddrTxt.Text);
rasEntry.dwCountryID := 86;
rasEntry.dwCountryCode := 21;
// rasEntry.szAreaCode := 'China';
rasEntry.dwfNetProtocols := RASNP_Ipx or RASNP_Ip or RASNP_NetBeui;
rasEntry.dwFramingProtocol := RASFP_ppp;
if (GetSystemVer = 'Windows 2000') or (GetSystemVer = 'Windows XP') then
rasEntry.szDeviceName := 'RAS VPN Line 0'
else
rasEntry.szDeviceName := 'Microsoft VPN Adapter';
dwResult := RasSetEntryProperties(nil,'VPN conn',@rasEntry,sizeof(rasEntry),nil,0);
if dwResult <> 0 then
messagebox(handle,'建立VPN适配器出错','错误',MB_ICONERROR);
end;

procedure TForm1.HangUpConn;
var
bufSize : LongInt;
numEntries : LongInt;
Entries : array[1..10] of TRasConn;
Stat : TRasConnStatus;
hRas : THRasConn;
begin
Entries[1].dwSize := SizeOf(TRasConn);
bufSize := Sizeof(TRasConn) * 10;
FillChar(stat, Sizeof(TRasConnStatus), 0);
Stat.dwSize:=Sizeof(TRasConnStatus);
if RasEnumConnections(@entries[1], bufsize, numEntries) = 0 then
begin
if numEntries > 0 then
with entries[1] do
begin
hRas := Longint(Pointer(hrasconn));
RasHangUp(hRas);
end;
end;
end;

procedure TForm1.FormShow(Sender: TObject);
begin
if UserNameTxt.Enabled then
UserNameTxt.SetFocus;
end;

procedure TForm1.IPAddrTxtKeyPress(Sender: TObject; var Key: Char);
begin
if key = chr(vk_Return) then
begin
DialBtn.SetFocus;
DialBtnClick(Sender);
end;
end;

procedure TForm1.UserNameTxtKeyPress(Sender: TObject; var Key: Char);
begin
if (key = chr(vk_Return)) and (trim(UserNameTxt.Text) <> '') then
PasswordTxt.SetFocus;
end;

procedure TForm1.PasswordTxtKeyPress(Sender: TObject; var Key: Char);
begin
if (key = chr(vk_Return)) and (trim(PassWordTxt.Text) <> '') then
IPAddrTxt.SetFocus;
end;

procedure TForm1.MarkTaskBarIcon(Sender: TObject);
begin
Form1.Visible := False;
tnd.cbSize := sizeof(tnd);
tnd.Wnd := Handle;
tnd.uID := 128;
tnd.uFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP;
tnd.uCallbackMessage := WM_TRAYNOTIFY;
tnd.hIcon := Application.Icon.Handle;
StrPCopy(tnd.szTip,Application.Title);
Shell_NotifyIcon(NIM_ADD,@tnd);
end;

procedure TForm1.TrayNotifyMessage(var Sender: TMessage);
begin
if Sender.LParam = WM_LBUTTONDBLCLK then
begin
Shell_NotifyIcon(NIM_DELETE,@tnd);
Form1.Visible := True;
Application.Restore;
Application.BringToFront;
end;
end;

procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
if CloseFlag then
CanClose := True
else
CanClose := False;
end;

procedure TForm1.WMHotKey(var msg: TWMHotKey);
begin
msg.Result := 1;
Form1.Visible := True;
Application.Restore;
application.BringToFront;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
unregisterhotkey(handle,hotkeyid);
DeleteAtom(hotkeyid);
end;

end.