[AC-2010] Envoi mail mais avec Lotus Notes (User et Password) [Résolu]

[electrosat03]

Bonjour à tous,

Je dois pouvoir envoyer un mail avec Lotus Notes et 1 fichier excel en pièce jointe sur appuis d'un bouton, mais j'aimerais que cela se fasse sans que je rentre les infos dans Lotus. Tout doit se faire de façon transparente pour l'utilisateur.

J'ai bien sur fais une recherche et j'ai trouvé un code, mais dans celui-ci, on défini le user name mais pas le password, or, dans l'entreprise il faut pour se connecter à Lotus le User Name et le passWord.

Ma question est donc, comment définir le Password dans le code.

Voici le code

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
Procédure globale:
 
 
Public Sub SendNotesMail(ByVal Subject As String, _
ByVal Attachment As String, ByVal RECIPIENT As String, _
ByVal CC As String, ByVal BCC As String, _
ByVal BodyText As String, ByVal SaveIt As Boolean) 
 
Dim oMaildb As Object 
Dim oMailDoc As Object 
Dim oAttachME As Object 
Dim oSession As Object 
Dim oEmbedObj As Object 
 
Dim sUserName As String 
Dim sMailDbName As String 
 
Const STR_ATTACHMENT As String = "Attachment" 
 
On Error GoTo L_ErrCannotCreateNotesSession 
    Set oSession = CreateObject("Notes.NotesSession") 
    sUserName = oSession.sUserName 
    sMailDbName = Left$(sUserName, 1) & Right$(sUserName, _
         (Len(sUserName) - InStr(1, sUserName, " "))) & ".nsf" 
    DoEvents 
    lblStatus.Caption = "Information about sender..." 
    Call Sleep(1000) 
    Set oMaildb = oSession.GETDATABASE(vbNullString, _
             sMailDbName) 
     If oMaildb.IsOpen = True Then 
     Else 
         oMaildb.OPENMAIL 
     End If 
    Set oMailDoc = oMaildb.CREATEDOCUMENT 
    oMailDoc.Form = "Memo" 
    oMailDoc.SENDTO = RECIPIENT 
    If Len(CC) = 0 Then 
    Else 
        oMailDoc.CopyTo = BC 
    End If 
    If Len(BCC) = 0 Then 
    Else 
        oMailDoc.blindCopyTo = BCC 
    End If 
    oMailDoc.Subject = Subject 
    oMailDoc.Body = BodyText 
    oMailDoc.SAVEMESSAGEONSEND = SaveIt 
    DoEvents 
    lblStatus.Caption = "Looking for attached files..." 
    Call Sleep(1000) 
 
    If Attachment <> vbNullString Then 
        Set oAttachME = oMailDoc.CREATERICHTEXTITEM_
           (STR_ATTACHMENT) 
        Set oEmbedObj = oAttachME.EMBEDOBJECT(1454, _
                vbNullString, Attachment, STR_ATTACHMENT) 
        oMailDoc.CREATERICHTEXTITEM _
                (STR_ATTACHMENT) 
    End If 
    DoEvents 
    oMailDoc.PostedDate = Now() 
 
 
 'To send the message, remove the quotes characters (') near each line 
  ' lblStatus.Caption = "Sending message..." 
  ' Call Sleep(1000) 
  '
  ' oMailDoc.SEND 0, RECIPIENT 
  ' lblStatus.Caption = "Message sent" 
 
  ' MsgBox "Your message has been sent successfully...", 64, "End" 
 
 
L_ExCannotCreateNotesSession: 
    Set oMaildb = Nothing 
    Set oMailDoc = Nothing 
    Set oAttachME = Nothing 
    Set oSession = Nothing 
    Set oEmbedObj = Nothing 
    Exit Sub 
L_ErrCannotCreateNotesSession: 
  Select Case Err 
      Case 429 
          MsgBox "Impossible de localiser un Client Notes; " & _
                     "Votre message n'a pas été envoyé !", 16, _
                          "Lotus Notes requis" 
      Case Else 
          MsgBox "Un erreur a empêché l'envoi du message." & _
                  vbCrlf & "Veuillez en référer à votre administrateur " & _
                      "pour lui soumettre cette erreur..." & vbCrlf & Error ,_
                             16, "Error #" & Str(Err) 
  End Select 
  Resume L_ExCannotCreateNotesSession 
End Sub

Code :

1
2
3
4
5
6
Mode d'utilisation:
 
Sub CreateMemoNotes() 
  SendNotesMail Me!txtSubject, Me!txtAttachment, Me!txtTo, _
                Me!txtCC, Me!txtCCC, Me!txtMessage, False 
End Sub

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
Déclaration de l'API (A placer en haut de module) :
 
 
 
Private Declare Function GetOpenFileName Lib _
"comdlg32.dll" Alias "GetOpenFileNameA" _
(pOpenfilename As OPENFILENAME) As Long 
 
Private Type OPENFILENAME 
  lStructSize As Long 
  hwndOwner As Long 
  hInstance As Long 
  lpstrFilter As String 
  lpstrCustomFilter As String 
  nMaxCustFilter As Long 
  nFilterIndex As Long 
  lpstrFile As String 
  nMaxFile As Long 
  lpstrFileTitle As String 
  nMaxFileTitle As Long 
  lpstrInitialDir As String 
  lpstrTitle As String 
  flags As Long 
  nFileOffset As Integer 
  nFileExtension As Integer 
  lpstrDefExt As String 
  lCustData As Long 
  lpfnHook As Long 
  lpTemplateName As String 
End Type 
 
Private Const OFN_READONLY = &H1 
Private Const OFN_OVERWRITEPROMPT = &H2 
Private Const OFN_HIDEREADONLY = &H4 
Private Const OFN_NOCHANGEDIR = &H8 
Private Const OFN_SHOWHELP = &H10 
Private Const OFN_ENABLEHOOK = &H20 
Private Const OFN_ENABLETEMPLATE = &H40 
Private Const OFN_ENABLETEMPLATEHANDLE = &H80 
Private Const OFN_NOVALIDATE = &H100 
Private Const OFN_ALLOWMULTISELECT = &H200 
Private Const OFN_EXTENSIONDIFFERENT = &H400 
Private Const OFN_PATHMUSTEXIST = &H800 
Private Const OFN_FILEMUSTEXIST = &H1000 
Private Const OFN_CREATEPROMPT = &H2000 
Private Const OFN_SHAREAWARE = &H4000 
Private Const OFN_NOREADONLYRETURN = &H8000 
Private Const OFN_NOTESTFILECREATE = &H10000 
Private Const OFN_NONETWORKBUTTON = &H20000 
Private Const OFN_NOLONGNAMES = &H40000 
Private Const OFN_EXPLORER = &H80000 
Private Const OFN_NODEREFERENCELINKS = &H100000 
Private Const OFN_LONGNAMES = &H200000

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
Fonction d'affichage de la boîte de dialogue des fichiers à joindre
 
 
Public Function fnctGetAttachedFiles(ByVal InitialDir _
 As String, ByVal Extensions As String, _
        ByVal ApplicationName As String) As String 
 
Const MIN_PATH As Integer = 260 
Const MAX_PATH As Integer = 8192 
Dim oOFN As OPENFILENAME 
Dim lReturn As Long 
Dim sFilter As String 
Dim sAttachmentString As String 
Dim aApplications() As String 
Dim aExtensions() As String 
Dim I As Integer 
 
    aApplications = Split(ApplicationName, ";") 
    aExtensions = Split(Extensions, ";") 
 
    For I = LBound(aApplications) To UBound(aApplications) 
        sFilter = sFilter & "Fichiers " & aApplications(I) & _
          vbNullChar & aExtensions(I) & vbNullChar 
    Next 
 
    With oOFN 
    .lStructSize = Len(oOFN) 
    .hwndOwner = Application.hWndAccessApp 
    .lpstrFile = Extensions 
    .lpstrFilter = sFilter 
    .nFilterIndex = 1 
    .lpstrFile = String(MIN_PATH, 0) 
    .flags = OFN_LONGNAMES Or OFN_HIDEREADONLY _
          Or OFN_ALLOWMULTISELECT 
    .nMaxFile = IIf((.flags And OFN_ALLOWMULTISELECT) = _
         OFN_ALLOWMULTISELECT, MAX_PATH, MIN_PATH - 1) 
    .lpstrFileTitle = .lpstrFile 
    .nMaxFileTitle = .nMaxFile 
    .lpstrInitialDir = IIf(Len(InitialDir) = 0, _
          Left(Application.CurrentProject.Path, 3), InitialDir) 
    .lpstrTitle = "Sélection de fichiers en pièces jointes" 
    End With 
    lReturn = GetOpenFileName(oOFN) 
 
    sAttachmentString = oOFN.lpstrFile 
    If InStr(1, sAttachmentString, vbNullChar) Then 
      sAttachmentString = Trim(Left(sAttachmentString, _
       InStr(1, sAttachmentString, vbNullChar) - 1)) 
    End If 
 
    fnctGetAttachedFiles = sAttachmentString 
 
End Function

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
Code à affecter au bouton Parcourir...
 
Sub ShowFileDialog() 
Dim sAttachmentString As String 
 
  sAttachmentString = fnctGetAttachedFiles("D:\Data", _
       "*.doc;*.xls;*.mdb;*.txt", "Word;Excel;Access;Notepad") 
  If Len(sAttachmentString) > 0 Then 
    Me!txtAttachment = sAttachmentString 
  Else 
    Me!txtAttachment = vbnulstring 
  End If 
End Sub

Merci.

[electrosat03]

Re,

J'ai enfin trouvé la solution, merci

A+