General |
6.129 Inviare da codice VBA una e-mail con allegati usando Outlook Express |
Andrea Barchetti |
Il codice che segue non è tutta farina del mio sacco ma frutto di una ricerca estenuante. Ho deciso di inviare il materiale al Sito Comune per le numerose richieste che ho avuto nel NewsGroup. Inserire in un modulo del database il seguente codice VBA: Private Type MAPIRecip Reserved As Long RecipClass As Long Name As String Address As String EIDSize As Long EntryID As String End Type Private Type MAPIFileTag Reserved As Long TagLength As Long Tag() As Byte EncodingLength As Long Encoding() As Byte End Type Private Type MAPIFile Reserved As Long Flags As Long Position As Long PathName As String FileName As String FileType As Long End Type Private Type MAPIMessage Reserved As Long Subject As String NoteText As String MessageType As String DateReceived As String ConversationID As String Originator As Long Flags As Long RecipCount As Long Recipients As Long FileCount As Long Files As Long End Type Public Declare Function MAPISendMail Lib "c:\programmi\outlook express\msoe.dll" (ByVal Session As Long, _ ByVal UIParam As Long, ByRef message As MAPIMessage, ByVal Flags As Long, ByVal Reserved As Long) As Long Private Const MAPI_E_NO_LIBRARY = 999 Private Const MAPI_E_INVALID_PARAMETER = 998 Private Const MAPI_ORIG = 0 Private Const MAPI_TO = 1 Private Const MAPI_CC = 2 Private Const MAPI_BCC = 3 Private Const MAPI_UNREAD = 1 Private Const MAPI_RECEIPT_REQUESTED = 2 Private Const MAPI_SENT = 4 Private Const MAPI_LOGON_UI = &H1 Private Const MAPI_NEW_SESSION = &H2 Private Const MAPI_DIALOG = &H8 Private Const MAPI_UNREAD_ONLY = &H20 Private Const MAPI_ENVELOPE_ONLY = &H40 Private Const MAPI_PEEK = &H80 Private Const MAPI_GUARANTEE_FIFO = &H100 Private Const MAPI_BODY_AS_FILE = &H200 Private Const MAPI_AB_NOMODIFY = &H400 Private Const MAPI_SUPPRESS_ATTAch = &H800 Private Const MAPI_FORCE_DOWNLOAD = &H1000 Private Const MAPI_OLE = &H1 Private Const MAPI_OLE_STATIC = &H2 Dim mAf() As MAPIFile Dim mAr() As MAPIRecip Dim lAr As Long Dim lAf As Long Dim mM As MAPIMessage Dim aErrors(0 To 26) As String Private Sub Class_Initialize() aErrors(0) = "Success" aErrors(1) = "User Abort" aErrors(2) = "Failure" aErrors(3) = "LogIn Failure" aErrors(4) = "Disk Full" aErrors(5) = "Insufficient Memory" aErrors(6) = "Block Too Small" aErrors(8) = "Too Many Sessions" aErrors(9) = "Too Many Files" aErrors(10) = "Too Many Recipients" aErrors(11) = "Attachment No Found" aErrors(12) = "Attachment Open Failure" aErrors(13) = "Attachment Write Failure" aErrors(14) = "Unknown Recipient" aErrors(15) = "Bad Recipient" aErrors(16) = "No Messages" aErrors(17) = "Invalid Message" aErrors(18) = "Text Too Large" aErrors(19) = "Invalid Session" aErrors(20) = "Type Not Suppported" aErrors(21) = "Ambiguous Recipient" aErrors(22) = "Message in Use" aErrors(23) = "Network Failure" aErrors(24) = "Invalid Edit Fields" aErrors(25) = "Invalid Recipient" aErrors(26) = "Not Supported" End Sub Public Sub Azzera_Email() lAr = 0 lAf = 0 End Sub Public Sub BCCAddressAdd(ByVal strAddress As String) RecipientAdd MAPI_BCC, , strAddress End Sub Public Sub BCCAdd(ByVal strName As String, ByVal strAddress As String) RecipientAdd MAPI_BCC, strName End Sub Public Sub BCCNameAdd(ByVal strName As String) RecipientAdd MAPI_BCC, strName, strAddress End Sub Public Sub CCAddressAdd(ByVal strAddress As String) RecipientAdd MAPI_CC, , strAddress End Sub Public Sub CCNameAdd(ByVal strName As String) RecipientAdd MAPI_CC, strName End Sub Public Sub MessageIs1(ByVal strNoteText As String) mM.NoteText = strNoteText End Sub Public Sub SubjectIs1(ByVal strSubject As String) mM.Subject = strSubject End Sub Public Sub ToAddressAdd(ByVal strAddress As String) RecipientAdd MAPI_TO, , strAddress End Sub Public Sub ToNameAdd(ByVal strName As String) RecipientAdd MAPI_TO, strName End Sub Public Sub FileAdd(ByVal strPathName As String) Dim F As MAPIFile With F .PathName = StrConv(strPathName, vbFromUnicode) End With ReDim Preserve mAf(lAf) mAf(lAf) = F lAf = lAf + 1 End Sub Public Sub Send1() Dim r As Long With mM If lAf > 0 Then .FileCount = lAf .Files = VarPtr(mAf(0)) End If If lAr > 0 Then .RecipCount = lAr .Recipients = VarPtr(mAr(0)) r = MAPISendMail(0, 0, mM, 0, 0) If r <> 0 Then If aErrors(r) = "" Then MsgBox " Email non creata " Else MsgBox aErrors(r) & " - Email non creata" End If Else End If End If End With End Sub Public Sub RecipientAdd(ByVal lngType As Long, Optional ByVal strName As String, Optional ByVal strAddress As String) Dim r As MAPIRecip r.RecipClass = lngType If strName <> "" Then r.Name = StrConv(strName, vbFromUnicode) If strAddress <> "" Then r.Address = StrConv(strAddress, vbFromUnicode) ReDim Preserve mAr(lAr) mAr(lAr) = r lAr = lAr + 1 End Sub Sub Invia_MSOE(TO1 As Variant, CC1 As Variant, BCC1 As Variant, ByVal OGG1 As String, ByVal MSG1 As String, AFIL1 As Variant) Dim T1, B1, C1, A1 As Long 'NUOVA TRASMISSIONE Azzera_Email 'ACCODA TO For T1 = LBound(TO1) To UBound(TO1) If TO1(T1) <> "" Then ToAddressAdd TO1(T1) Else MsgBox "MANCA IL DESTINATARIO - CHIUDO" Exit Sub End If Next T1 'ACCODA CC For C1 = LBound(CC1) To UBound(CC1) If CC1(C1) <> "" Then CCAddressAdd CC1(C1) Else End If Next C1 'ACCODA BCC For B1 = LBound(BCC1) To UBound(BCC1) If BCC1(B1) <> "" Then BCCAddressAdd BCC1(B1) Else End If Next B1 'INSERISCI TESTO MESSAGGIO MessageIs1 MSG1 'INSERISCI OGGETTO MESSAGGIO SubjectIs1 OGG1 'ACCODA ALLEGATI For A1 = LBound(AFIL1) To UBound(AFIL1) If AFIL1(A1) <> "" Then FileAdd AFIL1(A1) Else End If Next A1 'INVIA Send1 End SubQuesto è un esempio di un invio di una e-mail a più destinatari e che ha come allegati tre file: Dim MSGX, OBJX As Variant Dim aTO(0 To 1) As String Dim aCC(0 To 1) As String Dim aBCC(0 To 0) As String Dim aFiles(0 To 2) As String aFiles(0) = "C:\EMAIL\Qui.ZIP" aFiles(1) = "C:\EMAIL\Quo.ZIP" aFiles(2) = "C:\DOC\Qua.PDF" aTO(0) = "pippo@pluto.it" aTO(1) = "etabeta@pluto.it" aCC(0) = "paperino@pluto.it" aCC(1) = "Paperina@pluto.it" aBCC(0) = "topolino@pluto.it" OBJX = "Oggetto del messaggio" MSGX = "Testo del messaggio" Invia_MSOE aTO, aCC, aBCC, OBJX, MSGX, aFilesIl codice VBA di cui sopra è stato testato con Access 97. Nota di Alessandro Massarenti L'invio di messaggi con MAPISendMail va in crisi in presenza di Account di posta definiti con connessione LAN (anche disabilitati) e si sta lavorando off-line. Quindi anche il sistema suggerito in questa FAQ in quel caso non funziona. |