上传图片或附件到指定文件夹或共享文件夹的通用函数

做了个通用的函数来处理上传图片或附件，主要使用了vba的FileSystemObject对象，其实就是将选中的图片或者附件复制到指定的文件夹，复制成功后函数会返回上传路径。

'常量枚举图片和附件
Public Enum acFileType
acPicture = 1
acFiles = 2
End Enum
'================================
'函数名称： UploadFile
'功能描述： 复制图片或者附件到某个指定文件夹或者共享文件夹中
'输入参数： strDestinationPath 必需的,共享或者存放附件的目标文件夹路径。
' FileType 必需的,附件类型分图片和文件acPicture，acFiles
' bIsUpload 非必需的默认为True，True复制，False不复制
'返回参数： 字符串源文件路径或者目标文件路径
'使用示例： UploadFile("\\192.168.1.10\共享文件夹\",acPicture,True) '复制到共享文件夹，共享文件夹需要有写入权限
' UploadFile("C:\软件图片\",acPicture,True) 指定本地文件夹
'作 者： 金宇
'创建日期： 2012-05-30
'================================
Public Function UploadFile(strDestinationPath As String, _
FileType As acFileType, _
Optional bIsUpload As Boolean = True) As String
On Error GoTo ErrorHandler
Dim strSourceFile As String
Dim strDestinationFile As String
Dim strFullFileName As String
Dim FSO As Object

'如果文件夹路径右侧不带\，那就加上斜杠
If Right$(strDestinationPath, 1) <> "\" Then
strDestinationPath = strDestinationPath & "\"
End If
'检测是否存在文件夹
Set FSO = CreateObject("
Scripting.FileSystemObject")
If Not FSO.FolderExists(strDestinationPath) Then
MsgBox "此路径文件夹[" & strDestinationPath & "]未找到，请检查文件夹路径！", vbCritical, "系统提示"
Set FSO = Nothing
Exit Function
End If

With Application.FileDialog(3)
.Title = "Choose File"
.InitialFileName = ""
.Filters.Clear
Select Case FileType
Case 1
.Filters.Add "Graphics Files", "*.jpg;*.bmp;*.gif;*.png"
Case 2
.Filters.Add "Files", "*.pdf;*.doc;*.docx;*.xls;*.rar"
Case Else
.Filters.Add "All Files", "*.*"
End Select
.AllowMultiSelect = False
If .Show Then
strSourceFile = .SelectedItems.Item(1)
strDestinationFile = strDestinationPath & Mid$(strSourceFile, InStrRev(strSourceFile, "\") + 1)
strFullFileName = Mid$(strSourceFile, InStrRev(strSourceFile, "\") + 1)

If bIsUpload = True Then 'true则将选中的图片上传到指定的文件夹中，否则不上传只显示选择的图片
If FSO.FileExists(strDestinationFile) = True Then
If MsgBox("存在重复的文件名，是否替换？", vbOKCancel + vbInformation, "确认") = vbOK Then
FSO.copyfile strSourceFile, strDestinationFile, True
Else
Exit Function
End If
Else
FSO.copyfile strSourceFile, strDestinationFile
End If
Set FSO = Nothing
UploadFile = strDestinationFile
Else
UploadFile = strSourceFile
End If

End If
End With

ExitHere:
Set FSO = Nothing
Exit Function

ErrorHandler:
MsgBox Err.Description, vbInformation, "提示"
Resume ExitHere
End Function

演 示：

示例下载：

【access源码示例】上传图片或附件到指定文件夹或共享文件夹的通用函数【Access软件网】