拨号代码如下
unit vpn;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, Menus, ComCtrls, StdCtrls, WinSkinData, DB, ADODB,StrUtils, ExtCtrls,DialUp;
type
TForm1= class(TForm)
DialUp: TDialUp;
GroupBox1: TGroupBox;
ComboBox1: TComboBox;
ComboBox2: TComboBox;
Edit1: TEdit;
Edit2: TEdit;
Edit3: TEdit;
Edit4: TEdit;
Label1: TLabel;
RadioButton1: TRadioButton;
RadioButton2: TRadioButton;
RadioButton3: TRadioButton;
Label2: TLabel;
Button1: TButton;
Button2: TButton;
Button3: TButton;
Button4: TButton;
Button5: TButton;
Label3: TLabel;
Label4: TLabel;
Label5: TLabel;
Label6: TLabel;
Label7: TLabel;
MainMenu1: TMainMenu;
N1: TMenuItem;
N2: TMenuItem;
N3: TMenuItem;
N4: TMenuItem;
N5: TMenuItem;
N6: TMenuItem;
N7: TMenuItem;
N8: TMenuItem;
StatusBar1: TStatusBar;
Label8: TLabel;
ADOQuery1: TADOQuery;
N9: TMenuItem;
ADOConnection1: TADOConnection;
procedure Button5Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure RadioButton1Click(Sender: TObject);
procedure RadioButton2Click(Sender: TObject);
procedure RadioButton3Click(Sender: TObject);
procedure ComboBox2Change(Sender: TObject);
procedure DialUpVPN;
procedure DialUpActiveConnection(Sender: TObject; Handle: Integer;
Status: TRasConnStatusA; StatusString: String; EntryName, DeviceType,
DeviceName: array of Char);
procedure DialUpError(Sender: TObject; ErrorCode: Integer;
ErrorMessage: String);
procedure DialUpNotConnected(Sender: TObject; ErrorCode: Integer;
ErrorMessage: String);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
private
{ Private declarations }
public
{ Public declarations }
end;
type
GUID = record
Data1: Integer;
Data2: ShortInt;
Data3: ShortInt;
Data4: array[0..7] of Byte;
end;
type
TRasIPAddr = record
a: byte;
b: byte;
c: byte;
d: byte;
end;
type
TRasEntry = record
dwSize,
dwfOptions,
dwCountryID,
dwCountryCode : Longint;
szAreaCode : array[0.. 10] of Byte;
szLocalPhoneNumber : array[0..128] of Byte;
dwAlternatesOffset : Longint;
ipaddr,
ipaddrDns,
ipaddrDnsAlt,
ipaddrWins,
ipaddrWinsAlt : TRasIPAddr;
dwFrameSize,
dwfNetProtocols,
dwFramingProtocol : Longint;
szScript : Array [0..259] of Byte;
szAutodialDll : Array [0..259] of Byte;
szAutodialFunc : Array [0..259] of Byte;
szDeviceType : Array [0..16] of Byte;
szDeviceName : Array [0..128] of Byte;
szX25PadType : Array [0..32] of Byte;
szX25Address : Array [0..200] of Byte;
szX25Facilities : Array [0..200] of Byte;
szX25UserData : Array [0..200] of Byte;
dwChannels,
dwReserved1,
dwReserved2,
dwSubEntries,
dwDialMode,
dwDialExtraPercent,
dwDialExtraSampleSeconds,
dwHangUpExtraPercent,
dwHangUpExtraSampleSeconds,
dwIdleDisconnectSeconds,
dwType,
dwEncryptionType,
dwCustomAuthKey : Longint;
guidId : GUID;
szCustomDialDll : Array [0..259] of Byte;
dwVpnStrategy,
dwfOptions2,
dwfOptions3 : Longint;
szDnsSuffix : Array [0..255] of Byte;
dwTcpWindowSize : Longint;
szPrerequisitePbk : Array [0..259] of Byte;
szPrerequisiteEntry : Array [0..256] of Byte;
dwRedialCount,
dwRedialPause : Longint;
end;
TRasCredentialsA = record
dwSize, dwMask: Longint;
szUserName: array[0..256] of Byte;
szPassword: array[0..256] of Byte;
szDomain: array[0..15] of Byte;
end;
function RasSetEntryPropertiesA(lpszPhonebook, lpszEntry: PAnsichar; lpRasEntry: Pointer; dwEntryInfoSize: LongInt;lpbDeviceInfo:Pointer;dwDeviceInfoSize: Longint): Longint; stdcall;
function RasSetCredentialsA(lpszPhoneBook, lpszEntry: PAnsichar; lpCredentials: Pointer; fClearCredentials: Longint): Longint; stdcall;
procedure CopyMemory(Destination, Source: Pointer; Length:Integer) stdcall;
var
Form1: TForm1;
var conn:string;
implementation
{$R *.dfm}
function RasSetEntryPropertiesA; external 'Rasapi32.dll' name 'RasSetEntryPropertiesA'
function RasSetCredentialsA; external 'Rasapi32.dll' name 'RasSetCredentialsA';
procedure CopyMemory; external 'Kernel32.dll' name 'RtlMoveMemory';
function Create_VPN_Connection(sEntryName, sServer, sUsername, sPassword: string): Boolean;
var
sDeviceName, sDeviceType: string;
re: TRasEntry;
rc: TRasCredentialsA;
begin
sDeviceName := 'WAN 微型端口 (PPTP)';
sDeviceType := 'VPN';
with re do
begin
Result := False;
ZeroMemory(@re,SizeOf(re));
dwSize := Sizeof(re);
dwCountryCode := 86;
dwCountryID := 86;
dwDialExtraPercent := 75;
dwDialExtraSampleSeconds := 120;
dwDialMode := 1;
dwEncryptionType :=0;
dwfNetProtocols := 4;
dwfOptions := 1024262928 - $4000000 - $4000 - $80000 - $10000000 - $20000000 - $100 - $10;
dwfOptions2 := 367 - 256;
dwFramingProtocol := 1;
dwHangUpExtraPercent := 10;
dwHangUpExtraSampleSeconds := 120;
dwRedialCount := 0;
dwRedialPause := 1;
dwType := 2;
dwVpnStrategy := 3;
dwEncryptionType := 0; //0 无 1 VPN 默认值 3 拨号默认值 可选
StrCopy(@szDeviceName[0], PansiChar(sDeviceName));
StrCopy(@szDeviceType[0], PansiChar(sDeviceType));
StrCopy(@szLocalPhoneNumber[0], PansiChar(sServer));
end;
with rc do
begin
ZeroMemory(@rc,Sizeof(rc));
dwSize := sizeof(rc);
dwMask := 11;
StrCopy(@szUserName[0],PansiChar(sUsername));
StrCopy(@szPassword[0],PansiChar(sPassword));
end;
if RasSetEntryPropertiesA(Nil, PChar(sEntryName),@re, SizeOf(re), nil, 0)=0 then
if RasSetCredentialsA(Nil, PChar(sEntryName),@rc,0) = 0 then
Result := True;
end;
procedure TForm1.DialUpVPN;
begin
DialUp.GetConnections;
DialUp.DialMode:=dmsync;
DialUp.GetEntries;
DialUp.Entry:='VPN';
DialUp.Dial;
end;
procedure TForm1.DialUpActiveConnection(Sender: TObject; Handle: Integer;
Status: TRasConnStatusA; StatusString: String; EntryName, DeviceType,
DeviceName: array of Char);
begin
if Trim(EntryName)='VPN' then DialUp.HangUpConn(Handle);
end;
procedure TForm1.DialUpError(Sender: TObject; ErrorCode: Integer;
ErrorMessage: String);
begin
Application.MessageBox(PChar('与VPN服务器连接失败! '+ErrorMessage),'VPN连接',MB_OK+MB_ICONWARNING+MB_TOPMOST);
end;
procedure TForm1.DialUpNotConnected(Sender: TObject; ErrorCode: Integer;
ErrorMessage: String);
begin
Application.MessageBox(PChar('与VPN服务器连接失败! '+ErrorMessage),'VPN连接',MB_OK+MB_ICONWARNING+MB_TOPMOST);
end;
procedure TForm1.Button5Click(Sender: TObject);
begin
DialUp.GetConnections;
DialUp.DialMode:=dmsync;
DialUp.GetEntries;
DialUp.Entry:='VPN';
DialUp.DeleteEntry;
close
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
radiobutton1.Checked:=true;
//数据库连接
Adoconnection1.ConnectionString:='Provider=Microsoft.Jet.OLEDB.4.0;Jet OLEDB:Database Password=13516767586;Data Source='+ExtractFilePath(Application.ExeName)+'vpdn.dat'+';Persist Security Info=false';
Adoconnection1.LoginPrompt:=False;
Adoconnection1.Connected:=True;
with ADOQuery1 do
begin
SQL.Text:='select distinct * from vpdn order by name';
open;
while not EOF do begin
ComboBox2.Items.Append(ADOQuery1['name']);
next;
end;
end;
end;
procedure TForm1.RadioButton1Click(Sender: TObject);
begin
if radiobutton1.checked then
begin
combobox1.Clear;
combobox1.items.Add('202.96.97.241');
combobox1.items.Add('202.96.97.240');
combobox1.items.Add('61.164.1.37');
ComboBox1.ItemIndex:=0;
end
end;
procedure TForm1.RadioButton2Click(Sender: TObject);
begin
if radiobutton2.checked then
begin
combobox1.Clear;
combobox1.items.Add('218.205.54.52');
ComboBox1.ItemIndex:=0;
end
end;
procedure TForm1.RadioButton3Click(Sender: TObject);
begin
if radiobutton3.checked then
begin
combobox1.Clear;
combobox1.items.Add('124.130.209.10');
ComboBox1.ItemIndex:=0;
end
end;
procedure (Sender: TObject);
begin
with ADOQuery1 do
begin
SQL.Text:='select * from vpdn where name='+QuotedStr(Combobox2.Text);
open;
while not EOF do begin
Edit1.text:=ADOQuery1.FieldByName('userName').Asstring;
Edit2.text:=ADOQuery1.FieldByName('password').Asstring;
Edit3.text:=ADOQuery1.FieldByName('WSSBYHM').Asstring;
Edit4.text:=ADOQuery1.FieldByName('WSSBMM').Asstring;
next;
end
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
sServer, sEntryName, sUsername, sPassword: string;
begin
sEntryName := 'VPN';
sServer := combobox1.Text;
sUsername := edit1.Text;
sPassword := edit2.Text;
if Create_VPN_Connection(sEntryName, sServer, sUsername, sPassword) then
begin
DialUpVPN;
end else
begin
Application.MessageBox('VPN连接建立失败!','VPN连接',MB_OK+MB_ICONWARNING+MB_TOPMOST);
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
DialUp.GetConnections;
DialUp.DialMode:=dmsync;
DialUp.GetEntries;
DialUp.Entry:='VPN';
DialUp.DeleteEntry;
end;
end.
2017-09-13 16:30