VBA高级运用

2023年12月1日发(作者：)

word格式-可编辑-感谢下载支持

常用VBS代码

获取路径集合

获取系统安装路径

程序代码

set WshShell = Object("")

strWinDir = EnvironmentStrings("%WinDir%")

上面的代码意思是先定义这个变量是获取系统安装路径的，然后我们用"&strWinDir&"调用这个变量。

1.2.C:Program Files路径

程序代码

msgbox CreateObject("").ExpandEnvironmentStrings("%ProgramFiles%")

1.3.C:Program FilesCommon Files路径

程序代码

msgbox CreateObject("").ExpandEnvironmentStrings("%CommonProgramFiles%")

2.给桌面添加网址快捷方式

程序代码

set gangzi = Object("")

strDesktop = lFolders("Desktop")

set oShellLink = Shortcut(strDesktop & "Internet ")

Path = ""

ption = "Internet Explorer"

cation = "%ProgramFiles%Internet , 0"

3.给收藏夹添加网址

程序代码

Const ADMINISTRATIVE_TOOLS = 6

Set objShell = CreateObject("ation")

Set objFolder = ace(ADMINISTRATIVE_TOOLS)

Set objFolderItem =

Set objShell = Object("")

strDesktopFld =

Set objURLShortcut = Shortcut(strDesktopFld & "小游戏网站.url")

word格式-可编辑-感谢下载支持

4.删除指定目录指定后缀文件

程序代码

On Error Resume Next

Set fso = CreateObject("stemObject")

File "C:*.vbs", True

Set fso = Nothing

上面代码为删除C盘根目录下后缀为vbs的文件

改主页

程序代码

Set oShell = CreateObject("")

te "HKEY_CURRENT_USERSoftwareMicrosoftInternet ExplorerMainStart

Page",""

加启动项

程序代码

Set oShell=CreateObject("")

te "HKLMSoftwareMicrosoftWindowsCurrentVersionRuncmd",""

复制自己

程序代码

set copy1=createobject("stemobject")

e(fullname).copy("c:")

复制自己到C盘的

程序代码

set copy1=createobject("stemobject")

e("").copy("c:")

复制本vbs目录下的文件到c盘的

获取系统临时目录

程序代码

Dim fso

Set fso = CreateObject("stemObject")

word格式-可编辑-感谢下载支持

9.就算代码出错 依然继续执行

程序代码

On Error Resume Next

打开网址

程序代码

Set objShell = CreateObject("")

("/")

发送邮件

程序代码

NameSpace = "/cdo/configuration/"

Set Email = CreateObject("e")

= "发件@"

= "收件@"

t = "Test "

dy = "OK!"

achment "C:"

With

.Item(NameSpace&"sendusing") = 2

.Item(NameSpace&"smtpserver") = "smtp.邮件服务器.com"

.Item(NameSpace&"smtpserverport") = 25

.Item(NameSpace&"smtpauthenticate") = 1

.Item(NameSpace&"sendusername") = "发件人用户名"

.Item(NameSpace&"sendpassword") = "发件人密码"

.Update

End With

结束进程

word格式-可编辑-感谢下载支持

隐藏打开网址

13.1.部分浏览器无法隐藏打开，而是直接打开，适合主流用户使用

程序代码

createObject("").run "iexplore /",0

13.2.兼容所有浏览器，使用IE的绝对路径+参数打开，无法用函数得到IE安装路径，只用函数得到了

Program Files路径，应该比上面的方法好，但是两种方法都不是绝对的。（本方法由刚子原创）

程序代码

Set objws=Object("")

"""C:Program FilesInternet """,vbhide

遍历硬盘删除指定文件名（下面我增加了一个先结束进程在删除的功能，不需要可以去掉）

程序代码

On Error Resume Next

Dim fPath

strComputer = "."

Set objWMIService = GetObject _

("winmgmts:" & strComputer & "rootcimv2")

Set colProcessList = ery _

("Select * from Win32_Process Where Name = ''")

For Each objProcess in colProcessList

ate()

Next

Set objWMIService = GetObject("winmgmts:" _

& "{impersonationLevel=impersonate}!" & strComputer & "rootcimv2")

Set colDirs = objWMIService. _

ExecQuery("Select * from Win32_Directory where name LIKE '%c:%' or name LIKE '%d:%' or name

LIKE '%e:%' or name LIKE '%f:%' or name LIKE '%g:%' or name LIKE '%h:%' or name LIKE '%i:%'")

Set objFSO = CreateObject("stemObject")

For Each objDir in colDirs

fPath = & ""

File(fPath), True

Next

word格式-可编辑-感谢下载支持

If led=True Then

MsgBox "本机网卡MAC地址是: " & ress

Exit For

End If

Next

获取本机注册表主页地址

程序代码

Set reg=Object("")

startpage=d("HKEY_CURRENT_USERSoftwareMicrosoftInternet ExplorerMainStart

Page")

MsgBox startpage

遍历所有磁盘的所有目录，找到所有.txt的文件，然后给所有txt文件最底部加一句话。

程序代码

On Error Resume Next

Set fso = CreateObject("stemObject")

Co = VbCrLf & "路过。。。"

For Each i In

If ype = 2 Then

GF der(i & "")

End If

Next

Sub GF(fol)

Wh fol

Dim i

For Each i In ders

GF i

Next

End Sub

word格式-可编辑-感谢下载支持

Next

End Sub

18.获取计算机所有盘符

程序代码

Set fso=CreateObject("stemobject")

Set objdrives= '取得当前计算机的所有磁盘驱动器

For Each objdrive In objdrives '遍历磁盘

MsgBox objdrive

Next

给本机所有磁盘根目录创建文件 （刚子原创）

程序代码

On Error Resume Next

Set fso=CreateObject("stemObject")

Set gangzis= '取得当前计算机的所有磁盘驱动器

For Each gangzi In gangzis '遍历磁盘

Set TestFile=TextFile(""&gangzi&"新建文件夹.vbs",Ture)

ine("By ")

Next

遍历本机全盘找到所有，然后给他们改名

程序代码

set fs = CreateObject("stemObject")

for each drive in

fstraversal lder

next

sub fstraversal(byval this)

for each folder in ders

fstraversal folder

next

set files =

for each file in files

if = "" then = ""

next

end sub

word格式-可编辑-感谢下载支持

写入代码到粘贴板（先说明一下，VBS写内容到粘贴板，网上千篇一律都是通过

ation对象来实现，但是缺点是在默认浏览器为非IE中会弹出浏览器，所以

费了很大的劲找到了这个代码来实现）

程序代码

str=“这里是你要复制到剪贴板的字符串”

Set ws = object("")

"mshta

vbscript:a("+""""+"text"+""""+","+""""&str&""""+")(close)",0,true

自动发消息（保存BVS运行即可看到效果，希望高手举一反三，刚子原创）

程序代码

On Error Resume Next

str="我是笨蛋/qq"

Set WshShell=Object("")

"mshta

vbscript:a("+""""+"text"+""""+","+""""&str&""""+")(close)",0

"tencent://message/?Menu=yes&uin=20016964&Site=&Service=200&sigT=2a39fb276d15586e1114e71f7

af38e195148b0369a16a40fdad564ce185f72e8de86db22c67ec3c1",0,true

3000

ys "^v"

ys "%s"

隐藏文件

程序代码

Set objFSO = CreateObject("stemObject")

Set objFile = e("F:软件大赛")

If utes = utes AND 2 Then

utes = utes XOR 2

End If

生成随机数（521是生成规则，不同的数字生成的规则不一样，可以用于其它用途）

程序代码

Randomize 521

point=Array(Int(100*Rnd+1),Int(1000*Rnd+1),Int(10000*Rnd+1))

msgbox join(point,"")

删除桌面IE图标（非快捷方式）

程序代码

word格式-可编辑-感谢下载支持

Set oShell = CreateObject("")

te

"HKCUSoftwareMicrosoftWindowsCurrentVersionPoliciesExplorerNoInternetIcon",1,"REG_D

WORD"

获取自身文件名

程序代码

Set fso = CreateObject("stemObject")

msgbox Name

读取Unicode编码的文件

程序代码

Set objFSO = CreateObject("stemObject")

Set objFile = xtFile("",1,False,-1)

strText = l

strText

读取指定编码的文件（默认为uft-8）gangzi变量是要读取文件的路径

程序代码

set stm2 =createobject("")

t = "utf-8"

omFile gangzi

readfile = xt

MsgBox readfile

29.禁用组策略

程序代码

Set oShell = CreateObject("")

te

"HKEY_CURRENT_USERSoftwarePoliciesMicrosoftMMCRestrictToPermittedSnapins",1,"REG_DWOR

word格式-可编辑-感谢下载支持

t = "UTF-8"

on =

ext gangzi2

File gangzi,2

set Stm1 = nothing

获取当前目录下所有文件夹名字（不包括子文件夹）

程序代码

Set fso=CreateObject("stemobject")

Set f=der(olutePathName("."))

Set folders=ders

For Each fo In folders

Next

Set folders=Nothing

Set f=nothing

Set fso=nothing