Function OpenAttach(file As NotesDocument)
On Error Goto errorProc
Dim fileItem As Notesrichtextitem
Dim appl As Variant
Dim filename As String
Dim o As NotesEmbeddedObject
Dim fileType As String
Dim taskID As Variant
If file.HasEmbedded Then
Set o = file.GetAttachment(file.GetItemValue("AttachName")(0))
If Not o Is Nothing Then
On Error Resume Next
filename = Environ$("Temp") & "\" & o.Source
On Error Goto errorProc
Else
Msgbox "Невозможно открыть вложение.", 48, "Ошибка"
Exit Function
End If
file.EmbedFilepath = filename
' активируем связанное с аттачем (или выбранное пользователем) приложение для просмотра вложения
fileType = Lcase(Strrightback(filename, "."))
Select Case fileType
Case "doc","rtf","dot": 'если документ ворда
Call o.ExtractFile (filename)
Set appl = CreateObject("Word.Application")
appl.visible = True
appl.Documents.Open filename
Case "xls","xlt": 'Если эксель
Call o.ExtractFile (filename)
Set appl = CreateObject("Excel.Application")
appl.visible = True
appl.Workbooks.add(filename)
Case "html","htm", "xml", "txt", "zip", "rar", "gif", "jpg", "jpeg", "bmp": 'Если это точно можно открыть эксплоером
Call o.ExtractFile (filename)
taskID = Shell("explorer.exe " & filename, 1)
Case Else: 'если что-то другое
Dim path As Variant
Dim dr As String
Dim stream As NotesStream
On Error Resume Next
dr = Environ$("HOMEPATH")
On Error Goto errorProc
If Err > 0 Then
Err = 0
dr = ""
End If
path = ws.SaveFileDialog(False,,,dr, o.Source)
If Not Isempty(path) Then
On Error Goto extracting
Open Path(0) For Input As 1
Close 1
If Msgbox ("Заменить сщуствующий " & o.Name & "?", 4 + 32 ,db.Title) = 6 Then
Call o.ExtractFile(Path(0))
End If
End If
End Select
End If
Exit Function
extracting:
Call o.ExtractFile(Path(0))
Resume endofsub
endofsub:
Exit Function
errorProc:
Msgbox "Error#" & Err & " on line " & Erl & " in function " & Lsi_info(2) & " : " & Error, 48, "Runtime error"
Resume endofsub
End Function
