常用代码归集

jsgj2023

Sub 打开windows资源管理器()
Dim mysh  As Shell32.Shell
Set mysh = CreateObject("shell.application")
mysh.Explore ThisWorkbook.Path
Set mysh = Nothing
End Sub

jsgj2023

Sub 运行程序()
Dim mysh As Shell32.Shell
Dim myflditem As Shell32.FolderItem
Set mysh = CreateObject("shell.application")
For Each myflditem In mysh.Namespace(ssfCONTROLS).Items
    If myflditem.Name = "显示" Then
        myflditem.InvokeVerbEx
        Exit For
    End If
Next
End Sub

jsgj2023

Sub 创建快捷方式()
Dim mywsh As IWshRuntimeLibrary.WshShell
Dim myshtcut As IWshRuntimeLibrary.WshShortcut
Dim mypath As String
Set mywsh = CreateObject("wscript.shell")
mypath = mywsh.SpecialFolders("desktop")
Set myshtcut = mywsh.CreateShortcut(mypath & "\mytest.lnk")
With myshtcut
    .TargetPath = ThisWorkbook.FullName
    .Save
End With
MsgBox "快捷方式创建成功!" & vbCrLf & "名称为:" & myshtcut.FullName
Set myshtcut = Nothing
Set mywsh = Nothing
End Sub

jsgj2023

Sub 打开指定的网址()
Dim myir As InternetExplorer
Set myIE = New InternetExplorer
With myIE
    .Visible = True
    .Navigate "http://club.excelhome.net/forum.php"
End With
Set myIE = Nothing
End Sub

jsgj2023

Private Declare Function playwavesound Lib "winmm.dll" Alias "sndplaysoundA" (ByVal lpszsoundname As String, ByVal uflags As Long) As Long
Sub 播放指定的声音文件()
Dim soundname As String
soundname = "C:\WINDOWS\Media\Windows XP 注销音.wav"
playwavesound soundname, 0
End Sub

jsgj2023

Private Declare Function getsystemmetrics Lib "user32" Alias "GetSystemMetrics" (ByVal nindex As Long) As Long
Const xscreen = 0
Const yscreen = 1
Sub 获取电脑屏幕分辨率()
    Dim xval As Long
    Dim yval As Long
    yval = getsystemmetrics(yscreen)
    xval = getsystemmetrics(xscreen)
    MsgBox "您的电脑屏幕分辨率为:" & xval & "X" & yval
End Sub

jsgj2023

Sub 打开邮件客户端()
Dim myie As Object
Set myie = CreateObject("internetexplorer.application")
With myie
    .navigate "mailto:654573995@.qq.com"
    .Quit
End With
End Sub

jsgj2023

Sub 创建word文档()
Dim res, docapp As Word.Application
Application.StatusBar = "创建新的word文档........."
Set docapp = New Word.Application
With docapp
    .Visible = True
    Application.StatusBar = "创建新的word文档....."
    .Documents.Add
    .ActiveDocument.Paragraphs(1).Range.InsertBefore "excel vba 实用操作技巧"
    .Application.StatusBar = "保存文档....."
    .ActiveDocument.SaveAs2 ThisWorkbook.Path & "\excel vba实用操作技巧.doc"
    Application.StatusBar = "退出新建的word文档..."
    res = MsgBox("已经创建了word文档,是否要关闭word文档?", vbYesNo)
    If res = vbYes Then
        .Quit
    End If
End With
Set docapp = Nothing
Application.StatusBar = False
End Sub

jsgj2023

Sub 统计文件夹中的文件数量()
    Dim myfs As FileSearch
    Dim mypath As String
    Dim i As Long
    Dim n As Long
    Set myfs = Application.FileSearch
    mypath = ThisWorkbook.Path
    With myfs
        .NewSearch
        .LookIn = mypath
        .FileType = msoFileTypeAllFiles
        .Filename = "*.*"
        .SearchSubFolders = True
        If .Execute(SortBy:=msoSortByFileName) > 0 Then
            n = .FoundFiles.Count
            MsgBox "该文件夹里有" & n & "个文件"
            ReDim myfile(1 To n) As String
            For i = 1 To n
                myfile(i) = .FoundFiles(i)
                Cells(i, 1) = myfile(i)
            Next
        Else
            MsgBox "该文件夹里没有任何文件!"
        End If
    End With
    Set myfs = Nothing
End Sub

jsgj2023

Sub 统计当前工作簿所在的文件夹中工作簿的数量并列出工作簿的名称()
Dim mypath As String
Dim myfilename As String
Dim i As Long
mypath = ThisWorkbook.Path & "\"
myfilename = Dir(mypath, 0)
i = 0
Do While Len(myfilename) > 0
    Cells(i + 1, 1) = mypath & myfilename
    myfilename = Dir()
    i = i + 1
Loop
MsgBox "该文件夹里有" & i & "个文件!"
End Sub