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

时　间:2012-06-01 11:59:41
作　者:金宇   ID：43  城市：江阴
摘　要:上传图片或附件到指定文件夹或共享文件夹的通用函数
正　文:

做了个通用的函数来处理上传图片或附件，主要使用了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

附   件:

点击下载此附件

图   示: