网站首页 > 知识剖析 正文
做了个通用的函数来处理上传图片或附件,主要使用了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
演 示:
示例下载:
猜你喜欢
- 2025-07-09 代码分享:Python和VB代码实现批量合并EXCEL数据,拿走不谢
- 2025-07-09 vba常用代码总结(excel vba常用代码175个实例解析)
- 2025-07-09 注意了!在VBA使用Dir函数的“隐秘陷阱”
- 2025-07-09 使用VBA合并多个Excel文件(用vba合并多个excel工作表)
- 2025-07-09 ExcelVBA函数:保存当前工作簿的临时副本
- 2025-07-09 Excel常用技能分享与探讨(5-宏与VBA简介 VBA-实用自定义过程)
- 2025-07-09 Excel常用技能分享与探讨(5-宏与VBA简介 VBA常用到的函数一)
- 2025-07-09 Word隐藏的自动备份功能!每次保存生成独立副本,防丢稿终极方案
- 2025-07-09 保存后自动备份工作簿 《Excel VBA 从入门到放弃系列》
- 2025-07-09 Excel VBA学习笔记:取文件夹中所有文件:DIR函数
- 最近发表
-
- 表格存储 SQL 查询多元索引(表格存储 sql 查询多元索引的方法)
- 数据库教程-SQL Server多条件模糊查询
- Twitch宣布放弃Flash并逐步转型至HTML5平台
- 移动平台最强播放器MX Player:终于支持安卓5.0了!
- win10 NFS+黑群晖远程加载管理Windows文件夹(读写NTFS格式+高清播放器)
- Android端VLC 3.3版本发布,重新设计播放器界面
- 不仅仅被苹果封杀!Youtube宣布迁移Flash
- 揭开网站背后的魔法:B/S系统原来这么简单!
- Adobe Animate (An) 2020网页设计软件下载和安装教程
- Adobe发布“巨量”安全更新:遏制Flash“祸害”Linux
- 标签列表
-
- xml (46)
- css animation (57)
- array_slice (60)
- htmlspecialchars (54)
- position: absolute (54)
- datediff函数 (47)
- array_pop (49)
- jsmap (52)
- toggleclass (43)
- console.time (63)
- .sql (41)
- ahref (40)
- js json.parse (59)
- html复选框 (60)
- css 透明 (44)
- css 颜色 (47)
- php replace (41)
- css nth-child (48)
- min-height (40)
- xml schema (44)
- css 最后一个元素 (46)
- location.origin (44)
- table border (49)
- html tr (40)
- video controls (49)