vpn连接程序hta版实现代码（修改）

复制代码代码如下:

<HTA:APPLICATION

ID="MySampleHTA"

Caption="yes"

SCROLL="auto"

border="none"

border

SINGLEINSTANCE="yes"

maximizebutton="no"

BORDER="no"

icon="dxdiag.exe">

<style>

body

{

font-size:12;

BACKGROUND: #DADADA;

margin-left:5;

}

input

{

width:50;

overflow:visible;

border:1px solid lightblue;

background-color:#cccccc;

cursor:text;

}

button

{

border:1px solid gray;

width:70;

margin-left:2;

cursor:hand;

font-size:12;

filter:progid:DXImageTransform.Microsoft.Gradient(startColorStr='#eaeaff', endColorStr='#618fff', gradientType='0');

}

</style>

<body>

<button id="ipshow" onclick=vbs:show>当前ip显示</button>

<button id="vpnshow" onclick=vbs:vpnshow>vpn列表</button>

</body>

Set oShell = CreateObject("WScript.Shell")

Sub Window_onLoad

window.resizeTo 450,380

window.moveTo 300, 300

copy

End Sub

Sub copy

x("ip").value=me.clipboarddata.getdata("Text")

setTimeout "copy", 2000

End Sub

Function x(obj)

Set x=document.getElementById(obj)

End function

Sub dconn

cmd=oShell.exec("rasdial /d").StdOut.ReadAll()

x("url").innerHTML=cmd

End Sub

Sub show

x("url").innerHTML= "<br><br><iframe src=http://www.ip138.com/ip2city.asp></iframe>"

End Sub

Sub conn

tempfile="c:tmp~386"

If Findfile(tempfile) = false Then

writef tempfile,x("ip").value

x("url").innerHTML ="Create pbk file ........ok，连接中"

Else

writef tempfile,x("ip").value

x("url").innerHTML ="pbk file 存在........ok，连接中"

End If

x("url").innerHTML= oShell.exec("rasdial pvpn "&x("id").value&" "&x("pass").value&" /PHONEBOOK:"&tempfile).StdOut.ReadAll()

End Sub

Sub vpnshow

Set FSO = CreateObject("Scripting.FileSystemObject")

File = "ip.txt"

Set txt = fso.OpenTextFile(File)

If Not txt.atEndOfStream Then '先确定还没有到达结尾的位置

Content = txt.ReadAll '读取整个文件的数据

Lines = Replace(Content, vbCrlf, "<br>") '将文本内分行字符vbCrlf换成HTML换行标记"<br>"

x("url").innerHTML= Lines

End If

End Sub

Function Findfile(str)

Set FSO = CreateObject("Scripting.FileSystemObject")

If FSO.FileExists(str) Then

findfile=true

Else

findfile=false

End If

End Function

Function writef(pbk_file,ip)

Set FSO = CreateObject("Scripting.FileSystemObject")

with fso.opentextfile(pbk_file,2,true)

.writeline "[pvpn]"

.writeline "Encoding=1"

.writeline "Type=2"

.writeline "AutoLogon=0"

.writeline "UseRasCredentials=1"

.writeline "DialParamsUID=546750"

.writeline "Guid=76C5D8FF120C6A4F8E63F0B1E5D74AD4"

.writeline "BaseProtocol=1"

.writeline "VpnStrategy=2"

.writeline "ExcludedProtocols=0"

.writeline "LcpExtensions=1"

.writeline "DataEncryption=8"

.writeline "SwCompression=1"

.writeline "NegotiateMultilinkAlways=0"

.writeline "SkipNwcWarning=0"

.writeline "SkipDownLevelDialog=0"

.writeline "SkipDoubleDialDialog=0"

.writeline "DialMode=1"

.writeline "DialPercent=75"

.writeline "DialSeconds=120"

.writeline "HangUpPercent=10"

.writeline "HangUpSeconds=120"

.writeline "OverridePref=15"

.writeline "RedialAttempts=3"

.writeline "RedialSeconds=60"

.writeline "IdleDisconnectSeconds=0"

.writeline "RedialOnLinkFailure=0"

.writeline "CallbackMode=0"

.writeline "CustomDialDll="

.writeline "CustomDialFunc="

.writeline "CustomRasDialDll="

.writeline "AuthenticateServer=0"

.writeline "ShareMsFilePrint=1"

.writeline "BindMsNetClient=1"

.writeline "SharedPhoneNumbers=0"

.writeline "GlobalDeviceSettings=0"

.writeline "PrerequisiteEntry="

.writeline "PrerequisitePbk="

.writeline "PreferredPort=VPN4-0"

.writeline "PreferredDevice=WAN Miniport (L2TP)"

.writeline "PreferredBps=0"

.writeline "PreferredHwFlow=1"

.writeline "PreferredProtocol=1"

.writeline "PreferredCompression=1"

.writeline "PreferredSpeaker=1"

.writeline "PreferredMdmProtocol=0"

.writeline "PreviewUserPw=1"

.writeline "PreviewDomain=0"

.writeline "PreviewPhoneNumber=0"

.writeline "ShowDialingProgress=1"

.writeline "ShowMonitorIconInTaskBar=1"

.writeline "CustomAuthKey=-1"

.writeline "AuthRestrictions=608"

.writeline "TypicalAuth=2"

.writeline "IpPrioritizeRemote=1"

.writeline "IpHeaderCompression=0"

.writeline "IpAddress=0.0.0.0"

.writeline "IpDnsAddress=0.0.0.0"

.writeline "IpDns2Address=0.0.0.0"

.writeline "IpWinsAddress=0.0.0.0"

.writeline "IpWins2Address=0.0.0.0"

.writeline "IpAssign=1"

.writeline "IpNameAssign=1"

.writeline "IpFrameSize=1006"

.writeline "IpDnsFlags=0"

.writeline "IpNBTFlags=1"

.writeline "TcpWindowSize=0"

.writeline "UseFlags=0"

.writeline "IpSecFlags=0"

.writeline "IpDnsSuffix="

.writeline ""

.writeline "NETCOMPONENTS="

.writeline "ms_server=1"

.writeline "ms_msclient=1"

.writeline "ms_psched=1"

.writeline ""

.writeline "MEDIA=rastapi"

.writeline "Port=VPN4-0"

.writeline "Device=WAN Miniport (L2TP)"

.writeline ""

.writeline "DEVICE=vpn"

.writeline "PhoneNumber="&x("ip").value

.writeline "AreaCode="

.writeline "CountryCode=1"

.writeline "CountryID=1"

.writeline "UseDialingRules=0"

.writeline "Comment="

.writeline "LastSelectedPhone=0"

.writeline "PromoteAlternates=0"

.writeline "TryNextAlternateOnFail=1"

.writeline ""

.close

End with

Set fso = Nothing

End Function

sub showHelp

msg = " 在同目录下建立ip.txt" & vbcrlf

msg = msg & "------------------------------------------------" & vbcrlf

msg = msg & " ip.txt里是vpn的ip列表，一行一个，可以在每行里加说明" & vbcrlf

msg = msg & "复制IP会自动粘贴到ip框里，是否成功的话，请看ip显示：" & vbcrlf

alert msg

end sub

</SCRIPT>