Classe pour les fichiers attachés
Publié: 29 Juin 2005 à 11:28- Code : Tout sélectionner
'Library Attachment :
' AttachmentClass
%REM
*******************************************************
Class to manage attachment
Class Attachment :
Properties:
- name
- isEmpty
- hasChanged
Methods:
- new( RTItemName )
- view()
- print()
- edit()
- reAttach()
- detachToDisk()
- detachAll()
- deleteFile()
Developped by Alexandre Denis/Collabora
version 1.1 2002/03/27
*******************************************************
%END REM
Use "#SystemWin32"
Option Declare
Declare Function NEMPutFile Lib "nnotesws" ( wHandle As Integer, Byval szFileName As String, Byval szFilter As String, Byval szTitle As String ) As Integer
Public Class Attachment
' MEMBERS ===============================================
Private pWs As NotesUIWorkspace
Private pDoc As NotesDocument
Private pRTitem As NotesRichTextItem
Private pAttachments() As NotesEmbeddedObject
Private pAttachment As NotesEmbeddedObject
Private pFilePath As String
Private pDettachDate As Variant
' PRIVATE PROCEDURES ===================================
Private Sub selectAttachment(editFlag As Integer)
' Ask user witch attachment to edit
Dim dlgDoc As NotesDocument
Dim attachArray() As String
Dim text As String
Dim i As Integer, pos As Integer, ret As Integer
If Ubound(pAttachments) = 0 Then
' If only one
Set Me.pAttachment = pAttachments(0)
Else
' If more than one
Set dlgDoc = New NotesDocument(Me.pDoc.ParentDatabase)
Redim attachArray(Ubound(pAttachments))
For i = 0 To Ubound(attachArray)
attachArray(i) = Cstr(i) & ". " & pAttachments(i).Source
Next
dlgDoc.AttachmentsList = attachArray
Select Case editFlag
Case 1: text = "Select the attachment you want to edit."
Case 2: text = "Select the attachment you want to detach."
Case 3: text = "Select the attachment you want to open or print."
Case 4: text = "Select the attachment you want to remove."
End Select
dlgDoc.Text = text
ret = Me.pWs.DialogBox( "#DlgChooseAttach", True, True, False, False, False, False, "Attachment chooser", dlgDoc)
If ret Then
pos = Val(Left(dlgDoc.DlgAttachments(0), Instr(dlgDoc.DlgAttachments(0), ".")))
Set Me.pAttachment = pAttachments(pos)
End If
End If
End Sub
'___________________________________________
Public Property Get name As String
If Not pAttachment Is Nothing Then
~name = pAttachment.source
End If
End Property
'___________________________________________
Private Function detach(editFlag As Integer) As Integer
' Detach one attachment to disk
Dim fName As String*256
Dim fileName As String
Dim tmpDir As String
Dim ret As Integer
detach = False
If editFlag = 1 Then
fileName = Environ$("TEMP") & "\" & pAttachment.name
If fileExist(fileName) Then
Randomize
tmpDir = Environ$("TEMP") & "\tmp" & Cstr(Int(Rnd()*1000))
Mkdir tmpDir
fileName = tmpDir & "\" & pAttachment.name
End If
Elseif editFlag = 2 Then
fName = Me.name
If NEMPutFile( ret, fName, "", "Save Attachment") = 0 Then Exit Function
' We need to do this because the return is a NULL terminated string.
fileName = fName
If fileExist(fileName) Then
ret = Messagebox( "This file already exist. Do you want to overwrite it?", 36, "Save Attachment")
If ret = 7 Then Exit Function
End If
Else
fileName = GetTempFileName(Me.name)
End If
Call Me.pAttachment.ExtractFile(fileName)
Me.pFilePath = fileName
Me.pDettachDate = Filedatetime(fileName)
detach = True
End Function
'___________________________________________
Private Sub launch(action As String)
' Launch the attachment with its related windows application
' Call API procedure
' actions are : "open", "print"
If LaunchFile( Me.pFilePath, action, SW_SHOW ) = 0 Then
Messagebox "Sorry, an apllication to open this document cannot be found.", 48, "Lotus Notes"
End If
End Sub
'___________________________________________
Private Function displayDisclaimer() As Integer
Dim s As New NotesSession
Dim profile As NotesDocument
displayDisclaimer = True
' Check if the user do not want to display disclaimer
Set profile = pDoc.ParentDatabase.GetProfileDocument("Attachment", s.username)
If Not profile.GetFirstItem("AttDisplayLimit") Is Nothing Then
If profile.AttDisplayLimit(0) <> "1" Then
displayDisclaimer = pWs.Dialogbox("#DlgDisclaimer", True, True, False, True, True, False, "Please, note this")
End If
' Else
' displayDisclaimer = pWs.Dialogbox("#DlgDisclaimer", True, True, False, True, True, False, "Please, note this")
End If
End Function
' PUBLIC PROCEDURES =====================================
'___________________________________________
Public Property Get isEmpty As Integer
~isEmpty = True
If IsArrayInitialized(Me.pAttachments) Then
~isEmpty = False
End If
End Property
'___________________________________________
Public Function isOpen As Integer
isOpen = IsFileOpen(Me.pFilePath)
End Function
'___________________________________________
Public Function hasChanged As Integer
Dim lastDate As Variant
hasChanged = False
lastDate = Filedatetime(Me.pFilePath)
If Me.pDettachDate <> lastDate Then
hasChanged = True
End If
End Function
'___________________________________________
Public Sub view()
Call selectAttachment(3)
If Not pAttachment Is Nothing Then
If Me.detach(3) Then
Call Me.launch("open")
End If
End If
End Sub
'___________________________________________
Public Sub print()
Call selectAttachment(3)
If Not pAttachment Is Nothing Then
If Me.detach(3) Then
Call LaunchFile( Me.pFilePath, "print", SW_HIDE )
Messagebox "Document " & pAttachment.name & " is printed.", 64, "Focus"
End If
End If
End Sub
'___________________________________________
Public Function edit(editedAtt List As Attachment) As Integer
edit = False
If IsArrayInitialized(Me.pAttachments) Then
If displayDisclaimer() Then
Call selectAttachment(1)
If pAttachment Is Nothing Then Exit Function
' Check is not already edited (in AttachmentWatcher)
Forall att In editedAtt
If att.pAttachment Is Me.pAttachment Then
Messagebox "This attachment is being edited" & Chr(10) & "or" & Chr(10) &_
"was modified but not saved in the Notes document." & Chr(10) & Chr(10) &_
"If the attachment is still being edited, switch to that document window to continue editing," & Chr(10) &_
"otherwise, save the Notes document to update it and try again.", 16, "Attachment edition"
Exit Function
End If
End Forall
If Me.detach(1) Then
Call Me.launch("open")
edit = True
End If
End If
End If
End Function
'___________________________________________
Public Sub deleteFile()
' Deletes the file - if user platform allows it !
On Error Resume Next
' Remove the comments here if you really wants deleting the attachment after reattaching it !
'-->>'Kill pFilePath
End Sub
'___________________________________________
Public Function reAttach() As Integer
' Remove old attach from item
If Not pAttachment Is Nothing Then
pAttachment.remove
pDoc.save True, False
End If
' re-Attach the file
Set pAttachment = pRTitem.EmbedObject ( EMBED_ATTACHMENT, "", pFilePath )
pDoc.save True, False
' remove file from disk
Me.deleteFile
End Function
'___________________________________________
Public Sub detachToDisk()
Call selectAttachment(2)
If Not pAttachment Is Nothing Then Me.detach(2)
End Sub
'___________________________________________
Public Sub detachAll()
' Choose dir
Dim dirPath As String
dirPath = GetDirectory("Save attachments to:")
If dirPath <> "" Then
Forall att In pAttachments
If Not att Is Nothing Then
Call att.extractFile(dirPath & "\" & att.source)
End If
End Forall
End If
End Sub
'___________________________________________
Public Sub remove(editedAtt List As Attachment)
Dim ret As Integer
Call selectAttachment(4)
If Not pAttachment Is Nothing Then
Forall att In editedAtt
If (att.pAttachment.Source = Me.pAttachment.Source) And (att.pAttachment.Parent.Name = Me.pAttachment.Parent.Name) Then
Messagebox "This attachment is being edited" & Chr(10) & "or" & Chr(10) &_
"was modified but not saved in the Notes document." & Chr(10) & Chr(10) &_
"Attachment cannot be removed.", 16, "Attachment remove"
Exit Sub
End If
End Forall
ret = Messagebox ("This operation cannot be undone. Would you like to proceed?", 36, "Removing Attachment")
If ret = 6 Then
pAttachment.remove
pDoc.save True, False
End If
End If
End Sub
' CONSTRUCTOR ==========================================
Private Sub init(rtItemName As String)
Dim attachArray As Variant
Dim i As Integer
Set pWs = New NotesUIWorkspace
Set pDoc = pWs.currentDocument.document
Set pRTitem = pDoc.GetFirstItem(rtItemName)
If pRTitem Is Nothing Then Exit Sub
If Isempty(pRTitem.embeddedObjects) Then Exit Sub
Redim pAttachments(Ubound(pRTitem.embeddedObjects))
For i = 0 To Ubound(pAttachments)
Set pAttachments(i) = pRTitem.embeddedObjects(i)
Next
End Sub
Public Sub new (rtItemName As String)
Call init( rtItemName )
End Sub
End Class
Private Function IsArrayInitialized ( t ( ) As NotesEmbeddedObject) As Integer
Dim size As Integer
size = -1
On Error Resume Next
size = Ubound(t)
On Error Goto 0
If size = -1 Then
IsArrayInitialized = False
Else
IsArrayInitialized = True
End If
End Function
Private Function fileExist(fileName) As Integer
' Check if a file exist
Dim ret As String
ret = Dir$(fileName)
If ret = "" Then
fileExist = False
Else
fileExist = True
End If
End Function
Private Function IsFileOpen(fileName) As Integer
Dim filenum As Integer
fileNum = Freefile()
On Error 101 Goto errorFileAlreadyOpen
Open fileName For Random Lock Read Write As filenum
Close filenum
IsFileOpen = False
Exit Function
errorFileAlreadyOpen:
IsFileOpen = True
Exit Function
End Function
- Code : Tout sélectionner
'#SystemWin32
'Option Public << NO ! Public members need to be explicitly declared.
Option Declare
'<Component Information>
'***************************************************************
'
' Release Date = Tuesday, 3 November, 1998
' Component Version = 1.0.0
' use Redim = True
' use UI Class = False
'
'---------------------------------------------------------------------------------
'</Component Information>
'*****************************************************************
'Used by GetEnvironmentString
'*****************************************************************
Declare Function ExpandEnvironmentStrings Lib "kernel32" Alias "ExpandEnvironmentStringsA" ( Byval szSrc As String, Byval szDest As String, DestSize As Integer ) As Integer
'*****************************************************************
' Shell
'*****************************************************************
Public Const SW_HIDE = 0&
Public Const SW_SHOWNORMAL = 1&
Public Const SW_NORMAL = 1&
Public Const SW_SHOWMINIMIZED = 2&
Public Const SW_SHOWMAXIMIZED = 3&
Public Const SW_MAXIMIZE = 3&
Public Const SW_SHOWNOACTIVATE = 4&
Public Const SW_SHOW = 5&
Public Const SW_MINIMIZE = 6&
Public Const SW_SHOWMINNOACTIVE = 7&
Public Const SW_SHOWNA = 8&
Public Const SW_RESTORE = 9&
Public Const SW_SHOWDEFAULT = 10&
Public Const SW_MAX = 10&
Const SEE_MASK_INVOKEIDLIST = &HC
Const SEE_MASK_NOCLOSEPROCESS = &H40
Const SEE_MASK_FLAG_NO_UI = &H400
Private Const STARTF_USESHOWWINDOW = 1&
Private Const STARTF_USESIZE = 2&
Private Const STARTF_USEPOSITION = 4&
Private Const STARTF_USECOUNTCHARS = 8&
Private Const STARTF_USEFILLATTRIBUTE = 10&
Private Const STARTF_RUNFULLSCREEN = 20& 'ignored for non-x86 platforms
Private Const STARTF_FORCEONFEEDBACK = 40&
Private Const STARTF_FORCEOFFFEEDBACK = 80&
Private Const STARTF_USESTDHANDLES = 100&
Private Const STARTF_USEHOTKEY = 200& 'if(WINVER >= 0x0400)
Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const INFINITE = -1&
Private Type STARTUPINFO
cb As Long
lpReserved As String
lpDesktop As String
lpTitle As String
dwX As Long
dwY As Long
dwXSize As Long
dwYSize As Long
dwXCountChars As Long
dwYCountChars As Long
dwFillAttribute As Long
dwFlags As Long
wShowWindow As Integer
cbReserved2 As Integer
lpReserved2 As Long
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type
Private Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessID As Long
dwThreadID As Long
End Type
Type SHELLEXECUTEINFO
cbSize As Long
fMask As Long
hwnd As Long
lpVerb As String
lpFile As String
lpParameters As String
lpDirectory As String
nShow As Long
hInstApp As Long
lpIDList As Long
lpClass As String
hkeyClass As Long
dwHotKey As Long
hIcon As Long
hProcess As Long
End Type
Declare Function WaitForSingleObject Lib "kernel32" (Byval hHandle As Long, Byval dwMilliseconds As Long) As Long
Declare Function CreateProcessA Lib "kernel32" (Byval _
lpApplicationName As Long, Byval lpCommandLine As String, Byval _
lpProcessAttributes As Long, Byval lpThreadAttributes As Long, _
Byval bInheritHandles As Long, Byval dwCreationFlags As Long, _
Byval lpEnvironment As Long, Byval lpCurrentDirectory As Long, _
lpStartupInfo As STARTUPINFO, lpProcessInformation As _
PROCESS_INFORMATION) As Long
Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
(Byval hwnd As Long, Byval lpszOp As String, _
Byval lpszFile As String, Byval lpszParams As String, _
Byval LpszDir As String, Byval FsShowCmd As Long) As Long
Declare Private Function ShellExecuteEX Lib "shell32" Alias "ShellExecuteEx" (lpExecInfo As SHELLEXECUTEINFO) As Long
Declare Function CloseHandle Lib "kernel32" (Byval hObject As Long) As Long
'Get Folder Declarations
Const BIF_RETURNONLYFSDIRS = 1
Const BIF_DONTGOBELOWDOMAIN = 2
Const MAX_PATH = 260
Private Type BrowseInfo
hWndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As String
ulflags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Declare Function SHGetPathFromIDList Lib "shell32" (Byval pidList As Long, Byval lpBuffer As String) As Long
Const MAX_FILENAME_LEN = 256
Const UNIQUE_NAME = &H0
Declare Function GetTempFileNameA Lib "kernel32" (Byval lpszPath As String, Byval lpPrefixString As String, _
Byval wUnique As Long, Byval lpTempFileName As String) As Long
Public Sub HiddenShellAndWait ( Byval aRunProg As String )
'----------------------------------------------------------------------------------------
' Start a new process in a hidden window.
' This function Wait for the end of the process.
'
'input :
' aRunProg, the command line.
'
' return:
' Nothing
'----------------------------------------------------------------------------------------
Dim RetVal As Long
Dim proc As PROCESS_INFORMATION
Dim StartInf As STARTUPINFO
StartInf.wShowWindow = SW_HIDE
StartInf.dwFlags = STARTF_USESHOWWINDOW
StartInf.cb = Len(StartInf)
'Execute the given path
RetVal = CreateProcessA(0&, aRunProg, 0&, 0&, 1&, NORMAL_PRIORITY_CLASS, 0&, 0&, StartInf, proc)
'Disable this app until the shelled one is done
RetVal = WaitForSingleObject(proc.hProcess, INFINITE)
RetVal = CloseHandle(proc.hProcess)
End Sub
Public Sub ShellAndWait ( Byval aRunProg As String )
'----------------------------------------------------------------------------------------
' Start a new process.
' This function Wait for the end of the process.
'
'input :
' aRunProg, the command line.
'
' return:
' Nothing
'----------------------------------------------------------------------------------------
Dim proc As PROCESS_INFORMATION
Dim StartInf As STARTUPINFO
Dim RetVal As Long
StartInf.cb = Len(StartInf)
RetVal = CreateProcessA(0&, aRunProg, 0&, 0&, 1&, NORMAL_PRIORITY_CLASS, 0&, 0&, StartInf, proc)
'Disable this app until the shelled one is done
RetVal = WaitForSingleObject(proc.hProcess, INFINITE)
RetVal = CloseHandle(proc.hProcess)
End Sub
Public Function GetEnvironmentString ( aEnv As String , aVal As String ) As Integer
'----------------------------------------------------------------------------------------
' Return the value of an environment string.
'
'input :
' aEnv the environment string for which a value is needed.
'
'output:
' aVal the value of the environment string.
'
' return:
' Allways true.
'----------------------------------------------------------------------------------------
Dim szSrc As String
Dim szDest As String
Dim DestSize As Integer
Dim RetSize As Integer
szSrc = "%" & aEnv & "%" & Chr$(0)
DestSize = 254
szDest = String(DestSize + 1, 0)
RetSize = ExpandEnvironmentStrings (szSrc, szDest, DestSize)
If RetSize > DestSize Then
DestSize = RetSize
szDest = String(DestSize + 1, 0)
RetSize = ExpandEnvironmentStrings (szSrc, szDest, DestSize)
End If
aVal = Left (szDest, RetSize)
GetEnvironmentString = True
End Function
Public Function LaunchFile( fileName As String, verb As String, show As Integer ) As Long
Dim info As SHELLEXECUTEINFO
info.cbSize = Len(info)
info.fMask = SEE_MASK_NOCLOSEPROCESS Or SEE_MASK_FLAG_NO_UI
info.lpVerb = verb
info.lpFile = fileName
info.nShow = show
info.hInstApp = 0
info.lpIDList = 0
LaunchFile = ShellExecuteEX(info)
'LaunchFile = info.hProcess
End Function
Public Function GetDirectory(BoxTitle As String) As String
Dim lpIDList As Long
Dim sBuffer As String *260
Dim szTitle As String
Dim temp As String
Dim endpath As String
Dim filepath As String
Dim tBrowseInfo As BrowseInfo
tbrowseinfo.lpszTitle = BoxTitle
tBrowseInfo.ulflags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
lpIDList = SHBrowseForFolder(tBrowseInfo)
If (lpIDList) Then
SHGetPathFromIDList lpIDList, sBuffer
temp = Left(sBuffer, Instr(sBuffer, Chr(0)) - 1)
endpath = "\"
filepath$ = temp + endpath
End If
GetDirectory = filepath$
End Function
Public Function GetTempFileName(fileName As String) As String
' Give a temporary file name given a fileName
Dim extension As String
Dim newfName As String
Dim path As String
extension = Right$(fileName, Len(fileName) - Instr(fileName, "."))
path = Environ$("Temp")
newfName = Space(Len(path) + MAX_FILENAME_LEN)
Call GetTempFileNameA(path, "tmp", UNIQUE_NAME, newfName)
newfName = Left$(newfName, Instr(newfName, Chr$(0)) - 1)
GetTempFileName = Left$(newfName, Instr(Ucase(newfName), ".TMP")) & extension
End Function