实例44-获取文件夹中的文件名称，实例45-重命名文件 Excel程序VBA编程 代码分享
实例44-获取文件夹中的文件名称
Private Sub CommandButton获取_Click()
'---不包含文件夹
With ThisWorkbook.Worksheets("操作界面")
If Trim(.Cells(2, "C").Value) = "" Then
MsgBox "文件夹路径参数不能为空"
Exit Sub
End If
Dim fpath As String
fpath = Trim(.Cells(2, "C").Value)
End With
Set fs = CreateObject("Scripting.FileSystemObject")
Set fs_folder = fs.GetFolder(fpath)
Call getfilename(fs_folder)
With ThisWorkbook.Worksheets("名称列表")
.Columns(1).AutoFit
.Columns(2).AutoFit
.Activate
End With
End Sub
Sub getfilename(fso)
With Worksheets("名称列表")
.UsedRange.ClearContents
Dim addrow
'--------------------------------------------------------------
.Cells(1, 1) = "完整路径"
.Cells(1, 2) = "文件名"
addrow = .Cells(1000000, 1).End(xlUp).Row + 1
Dim f
For Each f In fso.Files
.Cells(addrow, 1) = f.Path
.Cells(addrow, 2) = "'" & f.Name
addrow = addrow + 1
Next
End With
End Sub
实例45-重命名文件
Private Sub CommandButton获取_Click()
'---不包含文件夹
With ThisWorkbook.Worksheets("操作界面")
If Trim(.Cells(2, "C").Value) = "" Then
MsgBox "文件夹路径参数不能为空"
Exit Sub
End If
Dim fpath As String
fpath = Trim(.Cells(2, "C").Value)
End With
Set fs = CreateObject("Scripting.FileSystemObject")
Set fs_folder = fs.GetFolder(fpath)
Call getfilename(fs_folder)
With ThisWorkbook.Worksheets("名称列表")
.Columns(1).AutoFit
.Columns(2).AutoFit
.Activate
End With
End Sub
Sub getfilename(fso)
With Worksheets("名称列表")
.UsedRange.ClearContents
Dim addrow
'--------------------------------------------------------------
.Cells(1, 1) = "完整路径"
.Cells(1, 2) = "原文件名"
.Cells(1, 3) = "新文件名"
addrow = .Cells(1000000, 1).End(xlUp).Row + 1
Dim f
For Each f In fso.Files
.Cells(addrow, 1) = f.Path
.Cells(addrow, 2) = "'" & f.Name
addrow = addrow + 1
Next
End With
End Sub
Private Sub CommandButton重命名_Click()
With Worksheets("名称列表")
Dim i, imax
imax = .Cells(1000000, 1).End(xlUp).Row
If imax = 1 Then
Exit Sub
End If
Dim old_name As String
Dim new_name As String
For i = 2 To imax
old_name = .Cells(i, 1)
new_name = Left(.Cells(i, 1), Len(.Cells(i, 1)) - Len(.Cells(i, 2)) - 1) & "\" & .Cells(i, 3)
Name old_name As new_name
Next i
.Activate
MsgBox "处理完成"
End With
End Sub
