前几天有个网友做了一个管理系统,他希望下载指定路径的附件,然后自动打开(不想直接打开共享内附件,避免用户修改原始的附件资料),在微信群里问了几天,提示他参考FileDialog,但是他想要现成的并发帖http://accessoft.com/bbs/showtopic.asp?id=26915,刚好自己有空也就研究了一下:
他说的下载,其实是复制(将共享文件复制到用户电脑),查询了和参考了大神们的资料,自己整合了一下,实现了功能。
1、参考大神的获取完整文件名代码:
Public Function GetFullFileName(strFileName As Variant) As String
'返回完整文件名
'例:"C:\File.txt" ,输出:"File.txt"
Dim I As Integer
For I = Len(strFileName) To 1 Step -1
If Mid$(strFileName, I, 1) = "\" Then
GetFullFileName = Mid$(strFileName, I + 1)
Exit Function
End If
Next I
GetFullFileName = strFileName
End Function
2、参考大神的复制文件代码:
Public Sub CopyFileWindowsWay(SourceFile As String, DestinationFile As String)
Dim lngReturn As Long
Dim typFileOperation As SHFILEOPSTRUCT
With typFileOperation
.hWnd = 0
.wFunc = FO_COPY
.pFrom = SourceFile & vbNullChar & vbNullChar '源文件。
.pTo = DestinationFile & vbNullChar & vbNullChar '目标文件。
.fFlags = FOF_ALLOWUNDO
End With
'拷贝操作。
lngReturn = SHFileOperation(typFileOperation)
If lngReturn <> 0 Then '如果拷贝失败。
MsgBox Err.LastDllError, vbCritical or vbOKOnly
Else
'MsgBox "复制成功!", vbInformation
If typFileOperation.fAnyOperationsAborted = True Then
MsgBox "Operation Failed", vbCritical or vbOKOnly
End If
End If
End Sub
3、下载按钮代码:
Private Sub Command4_Click()
Dim strFileName As String
Dim strPathName As String
Dim strFilePath As String
strFileName = GetFullFileName(Me.FilePath)
With Application.FileDialog(2) 'msoFileDialogSaveAs
'将下面一行的单引号去除,表示启用指定的文件夹位置
'.InitialFileName = "D:\"
.InitialFileName = strFileName
If .Show Then
strPathName = .SelectedItems(1)
strFilePath = GetFilePath(strPathName)
'如果文件已存在,则先删除已存在的文件,以达到替换目的
If Dir(strPathName) <> "" Then Kill strPathName
Call CopyFileWindowsWay(Me.FilePath, strFilePath)
End If
End With
If strPathName <> "" Then
Shell "explorer.exe """ & strPathName & """", vbNormalFocus
End If
End Sub
附 件:
点击下载此附件
演 示: