Access开发培训
网站公告
·Access专家课堂QQ群号:151711184    ·Access快速开发平台下载地址及教程    ·欢迎加入Access专家课堂微信群!    ·如何快速搜索本站文章|示例|资料    
您的位置: 首页 > 技术文章 > 源码示例

【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

 

附   件:

点击下载此附件

 

图   示:



Access软件网官方交流QQ群 (群号:54525238)       Access源码网店

常见问答:

技术分类:

相关资源:

专栏作家

关于我们 | 服务条款 | 在线投稿 | 友情链接 | 网站统计 | 网站帮助