常用代码归集

jsgj2023

Sub 判断指定的文件是否存在()
Dim myfilename As String
myfilename = ThisWorkbook.Path & "\寻找Adele-lfy.xls"
If Len(Dir(myfilename, vbDirectory)) > 0 Then
    If Dir(myfilename) <> "" Then
        MsgBox "该文件存在!"
    Else
        MsgBox "该文件不存在!"
    End If
Else
    MsgBox "所指定的文件夹或文件不存在!"
End If
End Sub

jsgj2023

Sub 获取当前电脑的盘符()
Dim fso As Scripting.FileSystemObject
Dim mydrive As Scripting.Drive
Dim i As Integer
Set fso = New Scripting.FileSystemObject
i = 1
For Each mydrive In fso.Drives
    Cells(i, 1) = mydrive.DriveLetter
    i = i + 1
Next
Set fso = Nothing
End Sub

jsgj2023

Sub 判断指定的驱动器是否存在()
Dim fso As Scripting.FileSystemObject
Dim strmsg As String
Dim disk As String
disk = InputBox("请输入驱动器名称:")
Set fso = New Scripting.FileSystemObject
If fso.DriveExists(disk) Then
    strmsg = "驱动器" & UCase(disk) & "存在!"
Else
     strmsg = "驱动器" & UCase(disk) & "不存在!"
End If
    MsgBox strmsg
End Sub

jsgj2023

Sub 获取指定文件夹的路径()
Dim fso As Scripting.FileSystemObject
Set fso = New Scripting.FileSystemObject
MsgBox "system文件夹路径为:" & fso.GetSpecialFolder(specialfolder:=SystemFolder).Path
MsgBox "temporary文件夹路径为:" & fso.GetSpecialFolder(specialfolder:=TemporaryFolder).Path
MsgBox "windows文件夹路径为:" & fso.GetSpecialFolder(specialfolder:=WindowsFolder).Path
End Sub

jsgj2023

Sub 获取当前文件夹下的子文件夹名称和大小()
Dim fso As Scripting.FileSystemObject
Dim myfol As Scripting.Folder
Dim myfolder As String
Dim i As Long
myfolder = ThisWorkbook.Path
Range("a1:c1") = Array("子文件名称", "大小", "短名称")
Set fso = New Scripting.FileSystemObject
i = 2
For Each myfol In fso.GetFolder(myfolder).SubFolders
    Cells(i, 1) = myfol.Name
    Cells(i, 2) = myfol.Size
    Cells(i, 3) = myfol.ShortName
    i = i + 1
Next
Set fso = Nothing
End Sub

jsgj2023

Sub 获取当前文件夹的相关操作信息()
    Dim fso As New FileSystemObject
    Dim myfolder As Folder
    Set myfolder = fso.GetFolder(ThisWorkbook.Path)
    MsgBox "名称:" & myfolder.Name _
    & vbCrLf & "DOS用短名称:" & myfolder.ShortName _
    & vbCrLf & "路径:" & myfolder.Path _
    & vbCrLf & "大小:" & Round(myfolder.Size / 1024, 2) & "KB" _
    & vbCrLf & "类型:" & myfolder.Type _
    & vbCrLf & "创建日期:" & myfolder.DateCreated _
    & vbCrLf & "最近一次访问日期:" & myfolder.DateLastAccessed _
    & vbCrLf & "最近一次修改日期:" & myfolder.DateLastModified _
    & vbCrLf & "所在驱动器:" & myfolder.Drive _
    & vbCrLf & "所在文件夹:" & myfolder.ParentFolder
    Set myfolder = Nothing
End Sub

jsgj2023

Sub 判断当前文件夹的属性()
Dim fso As Scripting.FileSystemObject
Dim mystr As String
Dim myfolder As String
myfolder = ThisWorkbook.Path
Set fso = New Scripting.FileSystemObject
With fso.GetFolder(myfolder)
    If (.Attributes And Normal) = Normal Then mystr = mystr & "普通"
    If (.Attributes And ReadOnly) = ReadOnly Then mystr = mystr & "只读"
    If (.Attributes And Hidden) = Hidden Then mystr = mystr & "隐藏"
    If (.Attributes And System) = System Then mystr = mystr & "系统"
    If (.Attributes And Directory) = Directory Then mystr = mystr & "文件夹"
    If (.Attributes And Archive) = Archive Then mystr = mystr & "存档"
End With
MsgBox "该文件夹的属性为:" & mystr
Set fso = Nothing
End Sub

jsgj2023

Sub 创建指定名称的文件夹()
Dim fso  As Scripting.FileSystemObject
Dim myfolder As String
myfolder = ThisWorkbook.Path & "\Adele"
Set fso = New Scripting.FileSystemObject
If fso.FolderExists(myfolder) Then
    MsgBox "该文件夹已经存在,无法创建!"
Else
    fso.CreateFolder myfolder
    MsgBox "文件夹创建成功!"
End If
Set fso = Nothing
End Sub

jsgj2023

Sub 移动指定的文件夹()
    Dim myfolder As String
    Dim mynewfilepath As String
    Dim fso As Scripting.FileSystemObject
    myfolder = ThisWorkbook.Path & "\Adele"
    mynewfilepath = ThisWorkbook.Path & "\lfy\"
    Set fso = New Scripting.FileSystemObject
    If fso.FolderExists(myfolder) Then
        fso.MoveFolder myfolder, mynewfilepath
        MsgBox "已经将文件夹" & myfolder & "移动到了文件" & mynewfilepath
    Else
        MsgBox "要移动的文件夹不存在!"
    End If
    Set fso = Nothing
End Sub

jsgj2023

Sub 删除指定目标位置的文件()
Dim myfolder As String
Dim fso As Scripting.FileSystemObject
myfolder = ThisWorkbook.Path & "\Adele\lfy"
Set fso = New Scripting.FileSystemObject
If fso.FolderExists(myfolder) Then
    fso.DeleteFolder myfolder, force:=True
    MsgBox "文件夹" & myfolder & "连同文件一起被删除了!"
Else
    MsgBox "文件夹" & myfolder & "不存在,无法删除!"
End If
Set fso = Nothing
End Sub