DominoArea.org [Archive]

bonjour,
je ne sais pas si c'est possible mais j aimerai pouvoir imprimer les pieces jointes de certains documents d'une base en automatique (quand l utilisateur demande l impression du document de la base )

comment faire ?


merci d'avance !

Salut,

Il faut que tu détache ton fichier et ensuite passez par des objets OLE pour générer les impressions.

Bonjour,

Massilia56 et Icoder sont-ils le même personne ?

Pour un début de piste, jette un oeil la-dessus (question posée très récemment...).
http://www.dominoarea.org/phpBB2/viewto ... er&t=14077

Thierry

Non je n ai pas une double personnalité ...
j ai juste oublié de rechercher si le sujet etais deja traité ... desolé !!!

Re,

Voilà une petite proposition :lib #SystemWin32

Code : Tout sélectionner

'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
   Kill newfName
End Function

lib AttachmentWatcherClass

Code : Tout sélectionner

'Library Attachment Watcher:

%REM
*******************************************************
 Used to track edited attachment documents

Class AttachmentWatcher :
  Properties: all private
   
  Methods:
    - new( RTItemName )
    - delete()
    - editAttachment()
    - check()

Developped by Alexandre Denis/Collabora
version 1  2002/03/21
*******************************************************
%END REM

Use "AttachmentClass"
Use "#PopMenu"

Option Public
Option Declare


Public Class AttachmentWatcher
   ' MEMBERS ===============================================
   Private attachmentToWatch List As Attachment
   
     ' PRIVATE PROCEDURES ===================================
   Private Sub watchAttachment(att As Attachment)
      ' Adds the attachment in the watching list
      Set attachmentToWatch(att.name) = att
   End Sub
   
     ' PUBLIC PROCEDURES ====================================
   Public Function check() As Integer
      Dim ret       As Integer
      Dim lName As String ' list tag
      
      check = True
      ' Return True if all attachments are closed and user decided what to do
      Forall att In attachmentToWatch
         If att.isOpen Then
            check = False
         Else
            If att.hasChanged Then
               att.reAttach
            Else
               att.deleteFile
            End If
            lName = Listtag(att)
            Delete att
            Erase attachmentToWatch(lName)
         End If
      End Forall
      If Not check Then
         ret = Messagebox("Some attachments are still in edition. Do you want to leave without saving them ?", 36, "Attachment edition")
         If ret = 6 Then
              ' If no then do not continu current event
            check = True
         End If
      End If
   End Function
     '___________________________________________
   Public Sub editAttachment(fieldName As String)
      Dim att As New Attachment(fieldName)
      
      If att.edit(attachmentToWatch) Then
         Call Me.watchAttachment(att)
      End If
   End Sub
    '___________________________________________
   Public Sub removeAttachment(fieldName As String)
      Dim att As New Attachment(fieldName)
      
      Call att.remove(Me.attachmentToWatch)
   End Sub
   
   ' CONSTRUCTOR ==========================================
   Public Sub new()
   End Sub
   
   ' DESTRUCTOR ===========================================
   Public Sub delete()
      ' Cleans up memory
      Dim lName As String
      Forall att In attachmentToWatch
         lName = Listtag(att)
         Delete att
         Erase attachmentToWatch(lName)
      End Forall
   End Sub
End Class
Public Sub AttachMenu(attWatcher As AttachmentWatcher, rtFieldName As String)
   Dim att As Attachment
   Dim ws As New NotesUIWorkspace
   
   Set att = New Attachment(rtFieldName)
   
   If ws.currentdocument.editMode Then
      Select Case PopMenu("Attachment actions:;-;-;Edit;Detach...;Launch...;Print;-;Detach All",0,0)
      'Case 2 : Call att.attach()
         'Case 3 : Call attWatcher.removeAttachment(rtFieldName)
      Case 2 : Call attWatcher.editAttachment(rtFieldName)
      Case 3 : att.detachToDisk
      Case 4 : att.view
      Case 5 : att.print
      Case 6 : att.detachAll
      End Select
   Else
      Select Case PopMenu("Attachment actions:;-;Detach...;Launch...;Print;-;Detach All",0,0)
      Case 2 : att.detachToDisk
      Case 3 : att.view
      Case 4 : att.print
      Case 5 : att.detachAll
      End Select
   End If
   
End Sub

lib #ArrayClass

Code : Tout sélectionner

Option Public
Option Declare

%INCLUDE "lsconst.lss"

Class Array2
   
   ' MEMBERS =================================
   Private pArray As Variant   
   Private pDataType As String
   
   ' PUBLIC PROCEDURES =======================
   Public Property Get isEmpty As Integer
      ' Check is array is initialized or not
      ' to use : Me.isEmpty
      ~isEmpty = isArrayInitialized()
   End Property
   
   Public Property Get values As Variant
      values = pArray
   End Property
   
   ' PRIVATE PROCEDURES =====================
   Private Function isArrayInitialized () As Integer
      Dim size As Integer
      
      size = -1
      On Error Resume Next
      size = Ubound(pArray)
      
      If size = -1 Then
         IsArrayInitialized = False
      Else
         IsArrayInitialized = True
      End If   
   End Function
   
   ' CONSTRUCTOR ============================
   Public Sub new(value As Variant)
      Dim singleValue As Integer
      
      
      Select Case Datatype(value)
      Case V_INTEGER : Redim pArray(0) As Integer
         singleValue = True
      Case V_LONG : Redim pArray(0) As Long
         singleValue = True
      Case V_SINGLE : Redim pArray(0) As Single
         singleValue = True
      Case V_DOUBLE : Redim pArray(0) As Double
         singleValue = True
      Case V_CURRENCY : Redim pArray(0) As Currency
         singleValue = True
      Case V_DATE : Redim pArray(0) As Variant
         singleValue = True
      Case V_STRING : Redim pArray(0) As String
         singleValue = True
      Case V_DISPATCH : Redim pArray(0) As Variant
         singleValue = True
      Case V_ERROR : Redim pArray(0) As Variant
         singleValue = True
      Case V_BOOLEAN : Redim pArray(0) As Variant
         singleValue = True
      Case V_VARIANT : singleValue = False
      Case V_IUNKNOWN : Redim pArray(0) As Variant
         singleValue = True
      Case V_LSOBJ : Redim pArray(0) As Variant
         singleValue = True
      Case V_PRODOBJ : Redim pArray(0) As Variant
         singleValue = True
      Case Else
         singleValue = False
%REM
2048   List
8192   Fixed array
8704   Dynamic array
%END REM
      End Select
      If singleValue Then
         pArray(0) = value
      Else
         Redim pArray(Ubound(value) - Lbound(value))
      End If
   End Sub
   
End Class


'_____________________________________________________________________
Public Class Array
     '**************************************************
     '* Introducing a better way to handle arrays
     '**************************************************
   Public Array() As Variant
   Private valueLookingFor As Variant '* used by the GetNextOccurence function
   
     '********
     '* NEW
     '********
   Sub New
      Redim Array(0)
   End Sub
   
     '*****************************
     '* APPEND NEW VALUE
     '*****************************
   Sub AppendNewValue( newValue As Variant )
          '* Appends new value to end of array
      If Ubound( Array ) = 0 And array( Ubound( array ) ) = "" Then
               '* Array was probably just initialized, use the first opening
         Array( Ubound( Array ) ) = newValue
      Else
         Redim Preserve Array ( Ubound( Array ) + 1 )
         Array( Ubound( Array ) ) = newValue
      End If
   End Sub     
   
     '***************
     '* INITIALIZE
     '***************
   Sub Initialize( newValues As Variant )
          '* takes an existing array and populates Class array
      Redim Array(0)
      If Isarray( newValues ) Then
         Forall value In newValues
            Me.AppendNewValue( value )
         End Forall
      Else
         Me.AppendNewValue( newValues )
      End If
   End Sub
   
     '**********************
     '* GET UBOUNDS
     '**********************
   Property Get UBounds As Integer
      On Error Goto ErrHandler
      UBounds = Ubound( Array )
      Exit Property
errHandler:
      If Err = 200 Then
               '* array hasn't been initialized yet, return -1
         UBounds = -1   
      End If
      Exit Property
   End Property
   
     '*********************
     '* GET LBOUNDS
     '*********************
   Property Get LBounds As Integer
      On Error Goto ErrHandler
      LBounds = Lbound( Array )
      Exit Property
errHandler:
      If Err = 200 Then
               '* array hasn't been initialized yet, return -1
         LBounds = -1   
      End If
      Exit Property
   End Property
   
     '*********************
     '* SET UBOUNDS
     '*********************
   Property Set UBounds As Integer
      Dim tempLBounds As Integer
      On Error Goto ErrHandler
      tempLBounds = Me.LBounds
      If tempLBounds = -1 Then
               '* Array hasn't been initialized yet
               '* we don't know LBounds, so make it the same as UBounds
         Redim Array( UBounds To UBounds )
      Elseif tempLBounds > UBounds Then
               '* do nothing, leave the array
      Else
               '* Array has been initialized, redim it
         Redim Array( tempLBounds To UBounds )
      End If
      Exit Property
errHandler:
      Exit Property 
   End Property
   
     '*********************
     '* SET LBOUNDS
     '*********************
   Property Set LBounds As Integer
      Dim tempUBounds As Integer
      On Error Goto ErrHandler
      tempUBounds = Me.UBounds
      Select Case tempUBounds
      Case Is = -1
               '* Array hasn't been initialized yet
               '* we don't know UBounds, so make it the same as UBounds
         Redim Array( LBounds To LBounds )
      Case Is = 0
               '* assume user doesn't care about upper bounds if it's only 0
         Redim Array( LBounds To LBounds )
      Case Is < LBounds
               '* do nothing, can't have lower bound bigger than upper bound
      Case Else
         Redim Array( LBounds To tempUBounds )
      End Select
      Exit Property
errHandler:
      Exit Property 
   End Property
   
     '************************
     '* RETURN ARRAY
     '************************
   Sub ReturnArray( newArray() As Variant )
          '* returns an array representing the Class array
      Dim x As Integer
      Redim newArray( Me.LBounds To Me.UBounds )
      For x = Me.LBounds To Me.UBounds
         newArray( x ) = Array( x )
      Next
   End Sub
   
     '*****************
     '* GET COUNT
     '*****************
   Property Get Count As Integer
          '* Returns number of values in an array
      Dim x As Integer, counter As Integer
      For x = Me.LBounds To Me.UBounds
         counter = counter + 1
      Next
      Count = counter
   End Property
   
     '**********************************
     '* FIND FIRST OCCURENCE
     '**********************************
   Function FindFirstOccurence( valueToFind As Variant ) As Integer
          '* finds first occurence of a value
      Dim x As Integer, counter As Integer
      valueLookingFor = valueToFind
      For x = Me.LBounds To Me.UBounds
         counter = counter + 1
         If Array( x ) = valueLookingFor Then
            FindFirstOccurence = counter
            Exit Function
         End If
      Next
      FindFirstOccurence = -1 '* didn't find an occurence
   End Function
   
     '**********************************
     '* FIND NEXT OCCURENCE
     '**********************************
   Function FindNextOccurence( PrevOccurence As Integer ) As Integer
          '* finds next occurence of value, returns -1 if not found
      Dim x As Integer, counter As Integer
      For x = Me.LBounds To Me.UBounds
         counter = counter + 1
         If counter > PrevOccurence Then
            If Array( x ) = valueLookingFor Then
               FindNextOccurence = counter
               Exit Function
            End If
         Else
                    '* don't start searching yet
         End If
      Next
      FindNextOccurence = -1 '* didn't find an occurence
   End Function
   
     '***********************
     '* GET NTH VALUE
     '***********************
   Function GetNthValue( n As Integer ) As Variant
          '* This will grab a value for the Nth position
          '* make sure n is within bounds first
      Dim x As Integer, counter As Integer
      If n > Me.Count Or n < 0 Then
         GetNthValue = ""
         Exit Function
      End If
      counter = Me.LBounds
      For x = Me.LBounds To Me.UBounds
         If counter = n Then
            GetNthValue = Array( x )
            Exit Function
         End If
         counter = counter + 1
      Next
   End Function
   
     '***********************
     '* SET NTH VALUE
     '***********************
   Function SetNthValue( n As Integer, newValue As Variant ) As Variant
          '* Find the Nth position, and set it's value
          '* make sure n isn't lower than bounds first
      Dim x As Integer, counter As Integer
      If n < 0 Then
         SetNthValue = False
         Exit Function
      End If
      If n > Me.Count Then
         Redim Preserve Array( Me.LBounds To n )
         Array( n ) = newValue
         SetNthValue = True
         Exit Function
      End If
      For x = Lbound( Array ) To Ubound( Array )
         counter = counter + 1
         If counter = n Then
            Array( x ) = newValue
            SetNthValue = True
            Exit Function
         End If
      Next
      SetNthValue = False
   End Function
   
     '******************************
     '* REMOVE NTH VALUE
     '******************************
   Function RemoveNthValue( n As Integer ) As Variant
          '* not only remove the value, but shrink the array size too
          '* make sure n is within bounds first
      Dim x As Integer, counter As Integer
      If n > Me.Count Or n <= 0 Then
         RemoveNthValue = False
         Exit Function
      End If
      Dim newArray() As Variant, found As Variant
      Redim newArray( Me.LBounds To ( Me.UBounds - 1 ) )
      found = False
      For x = Lbound( Array ) To Ubound( Array )
         counter = counter + 1
         If counter <> n Then
            If found = False Then
               newArray( x ) = Array( x )
            Else
               newArray( x - 1 ) = Array ( x )
            End If
         Else
            found = True
         End If
      Next
      Redim Array( Me.LBounds To ( Me.UBounds - 1 ) )
      For x = Lbound( Array ) To Ubound( Array )
         Array( x ) = newArray( x )
      Next
      RemoveNthValue = True
   End Function
   
     '******************************************
     '* REMOVE DUPLICATE ENTRIES
     '******************************************
   Sub RemoveDuplicateEntries
          '* Just what the subprocedure's title indicates
      Dim s As New NotesSession
      Dim doc As NotesDocument
      Dim tmpArray As Variant, arrayContents() As Variant
      
      Set doc = New NotesDocument(s.CurrentDatabase)
      Call Me.ReturnArray( arrayContents() )
      doc.Array = ""
      doc.Array = arrayContents
      tmpArray = Evaluate("@Trim(@Unique(Array))", doc)
      
      Call Me.Initialize( tmpArray )
%REM
      '* Old method
      Dim x As Integer, counter As Integer
      Dim tempArray List As Variant
      
          '* Use list to remove duplicates as list tags have to be unique
      Forall value In Array
         tempArray(value) = value
      End Forall
      
          '* Swap arrays
      Forall temp In tempArray
         counter = counter + 1 '* Figure out how many entries there are
      End Forall
      If Me.LBounds = 0 Then '* if it's zero, subtract one from counter, otherwise, we'll have an extra entry
         Redim Preserve Array( Me.LBounds To ( counter - 1 ) )
      Else
         Redim Preserve Array( Me.LBounds To counter )
      End If
      x = Me.LBounds
      Forall temp In tempArray
         Array( x ) = temp
         x = x + 1
      End Forall 
%ENDREM      
   End Sub
   
     '************************
     '* REMOVE SPACES
     '************************
   Sub RemoveSpaces
          '* This removes any values from the array that are equal to ""
      Dim continue As Variant, counter As Integer, x As Integer, Occurence As Integer
      continue = True
      If Me.LBounds = Me.UBounds Then '* don't want to touch it if there is only one value
         continue = False
      End If
      Do While continue = True
         counter = 0 '* reset counter 
         For x = Me.LBounds To Me.UBounds
            counter = counter + 1
            If Array( x ) = "" Then
                         '* get rid of this one
               Me.RemoveNthValue( counter )
               Exit For
            End If   
         Next
               '* check if there is another occurence of "", if so, keep going
         Occurence = Me.FindFirstOccurence( "" )
         If Occurence <> -1 Then
            continue = True
         Else
            continue = False
         End If
      Loop
   End Sub
   
     '*********
     '* SORT
     '*********
   Sub Sort( SortType As Variant )
          '* SortType is True for Ascending order, False for Descending order 
      Dim lowerBounds, upperBounds, cur, cur2 As Integer
      Dim temp As Variant
      upperBounds = Me.UBounds
      lowerBounds = Me.LBounds
      
      If upperBounds = lowerBounds Then Exit Sub
      For cur = lowerBounds To upperBounds
         cur2 = cur
         Do While cur2 > lowerBounds 'bubble up
            If SortType Then '* sort ascending
               If ( Array( cur2 ) > Array(cur2 - 1) ) Then
                  Exit Do
               Else
                  temp = Array( cur2 )
                  Array( cur2 ) = Array( cur2-1 )
                  Array(cur2-1) = temp
               End If
            Else '* sort descending
               If ( Array( cur2 ) < Array(cur2 - 1) ) Then
                  Exit Do
               Else
                  temp = Array( cur2 )
                  Array( cur2 ) = Array( cur2-1 )
                  Array(cur2-1) = temp
               End If
            End If
            cur2 = cur2-1
         Loop
      Next
   End Sub
   
     '****************
     '* ISMEMBER
     '****************
   Function IsMember( value As Variant ) As Variant
          '* returns true if value passed is in list, false if not found
      Dim x As Integer
      For x = Me.LBounds To Me.UBounds
         If Array( x ) = value Then
            IsMember = True
            Exit Function
         End If
      Next
      IsMember = False
   End Function
   
     '*****************
     '* ISNOTHING
     '*****************
   Function IsNothing As Variant
          '* determines if array is completely empty
      Dim x As Integer
      For x = Me.LBounds To Me.UBounds
         If Array( x ) <> "" Then
            IsNothing = False
            Exit Function
         End If
      Next
      IsNothing = True
   End Function
End Class

lib #PopMenu

Code : Tout sélectionner

Option Public
Type RECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
End Type

Type POINTAPI
   x As Long
   y As Long
End Type

Type MSG
   hwnd As Long
   message As Long
   wParam As Long
   lParam As Long
   time As Long
   pt As POINTAPI
End Type

Declare Function GetCursorPos Lib "user32" Alias "GetCursorPos" (lpPoint As POINTAPI) As Long
Declare Function CreatePopupMenu Lib "user32" Alias "CreatePopupMenu" () As Long
Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" (Byval hMenu As Long, Byval wFlags As Long, Byval wIDNewItem As Integer, Byval lpNewItem As Any) As Long
Declare Function TrackPopupMenu Lib "user32" Alias "TrackPopupMenu" (Byval hMenu As Long, Byval wFlags As Long, Byval x As Long, Byval y As Long, Byval nReserved As Long, Byval hwnd As Long, lprc As Rect) As Long
Declare Function DestroyMenu Lib "user32" Alias "DestroyMenu" (Byval hMenu As Long) As Long
Declare Function GetMessage Lib "user32" Alias "GetMessageA" (lpMsg As MSG, Byval hwnd As Long, Byval wMsgFilterMin As Long, Byval wMsgFilterMax As Long) As Long
Declare Function GetActiveWindow Lib "user32" Alias "GetActiveWindow" () As Long
Function PopMenu (pstrItem As String, mx As Long, my As Long) As Long
' Pop a menu at coordinates mx, my (pixels)
' or current cursor position if 0,0
' pstrItem is a semicolon-delimited string
' ie: "Item 1;Item 2;-;Item 3"
' A separator is created from a '-'
' Use of ampersand to underline character is Ok
'
' Returns number of item chosen, or 0 if user
' clicks off the menu or presses <Esc>
   
   Const MF_ENABLED = &H0
   Const MF_GRAYED = &H1
   Const MF_CHEKED = &H8
   Const MF_DISABLED = &H2
   Const TPM_LEFTALIGN = &H0
   Const MF_SEPARATOR = &H800
   Const SEP = ";"
   Dim msgdata As MSG
   Dim rectdata As RECT
   Dim Cursor As POINTAPI
   Redim strItem(1 To 20) As String
   Dim i As Long
   Dim j As Long
   Dim last As Long
   Dim hMenu As Long
   Dim id As Integer
   Dim junk As Long
   
   
   If Right$(pstrItem, 1) <> SEP Then pstrItem = pstrItem + SEP
   j = 1
   Do
      i = Instr(j, pstrItem, SEP)
      If i Then
         last = last + 1
         strItem(last) = Mid$(pstrItem, j, i - j)
         j = i + 1
      End If
   Loop Until i = 0
   
   hMenu = CreatePopupMenu()
   
   id = 1
   For i = 1 To last
      If strItem(i) <> "-" Then
         junk = AppendMenu(hMenu, MF_ENABLED, id, strItem(i))
         id = id + 1
      Else
         junk = AppendMenu(hMenu, MF_SEPARATOR, 0, "")
      End If
   Next
   
   If mx = 0 And my = 0 Then
      Call GetCursorPos(Cursor)
      mx = Cursor.x
      my = Cursor.y
   End If
   
   junk = TrackPopupMenu(hMenu, TPM_LEFTALIGN, mx, my, 0, GetActiveWindow(), rectdata)
   junk = GetMessage(msgdata, GetActiveWindow(), 0, 0)
   
   i = Abs(msgdata.wparam)
   If msgdata.message = 273 Then
      PopMenu = i
   End If
   Call DestroyMenu(hMenu)
End Function

lib AttachmentClass

Code : Tout sélectionner

'Library Attachment :

%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
     '___________________________________________
   Private Function detach(editFlag As Integer) As Integer
      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)
      ' 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 name As String
      If Not pAttachment Is Nothing Then
         ~name = pAttachment.source
      End If
   End Property
     '___________________________________________
   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 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 deleteFile()
      On Error Resume Next
      Kill pFilePath
   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

Oups, j'ai oublier la base !

Bonjour stephane dit...
la base est endomagé... pret de 2 ans apres je me demande si le lien est encore valide?
Merci...

Salut,

Je rentre ce week end je regarderais si j'ai une version encore bonne.

Stéphane Maillard a écrit:Salut,

Je rentre ce week end je regarderais si j'ai une version encore bonne.

Merci bien ^^
Bon week end a toi... ou a plus tard dans la journée qui sait...

Pour Rappel ^^
Merci....

Salut,

Je ne l'ai plus, j'ai pas regardé toutes mes archives encore mais sur celle que j'ai eu le temps elle n'y était plus.

Arf c'est dommage mais je te remercie ^^
Bonne journée...