'选择合同附件拷贝到服务器的文件夹中
Private Sub 选择附件_Click()
On Error GoTo Err_cmdPhoto_Click
Dim fso As Object
Dim s_filepath As String
serverpath = "\\" & g_strserver & "\public_file\cght\" '服务器共享文件夹路径
strFilter = AddFilterItem("(*.*)", "文件", "*.*")
strFilename = CommonFileOpenSave(, , strFilter, , , , "请选择文件", Me.hwnd)
If Not IsNull(strFilename) And Len(strFilename) > 0 Then
Me.htfj.SetFocus
s_FileName = serverpath & Mid(strFilename, InStrRev(strFilename, "\") + 1)
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(s_FileName) = True Then '检测是否存在同名文件
MsgBox "服务器上已有相同附件名，请修改附件名后再上传!", vbCritical, "提示："
Me.htfj.SetFocus
Exit Sub
Else
'拷贝选择后的附件
FileCopy strFilename, serverpath & Mid(strFilename, InStrRev(strFilename, "\") + 1)
Me.htfj = serverpath & Mid(strFilename, InStrRev(strFilename, "\") + 1)
End If
Set fso = Nothing
End If
Exit_cmdPhoto_Click:
Exit Sub
Err_cmdPhoto_Click:
Resume Exit_cmdPhoto_Click
End Sub
'打开合同附件
Private Sub OPENFILES_Click()
If Dir(Me.htfj) <> "" Then
ShellExecute Me.hwnd, "open", Me.htfj, "", "", SW_SHOWMAXIMIZED
End If
End Sub
这一句加在模块中
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
