Option Explicit Public Enum olSaveAsTypeEnum olSaveAsTxt = 0 olSaveAsRTF = 1 olSaveAsMsg = 3 End Enum Private WithEvents Items As Outlook.Items Private WithEvents OutItems As Outlook.Items Private Const MAIL_PATH As String = "\\server\Aloni\AloniScanTbl\Mails\" Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean) If TypeOf Item Is Outlook.MailItem Then SaveMailAsFile Item, olSaveAsMsg, MAIL_PATH End If End Sub Private Sub Application_Startup() Dim Ns As Outlook.NameSpace Set Ns = Application.GetNamespace("MAPI") Set Items = Ns.GetDefaultFolder(olFolderInbox).Items Set OutItems = Ns.GetDefaultFolder(olFolderOutbox).Items End Sub Private Sub Items_ItemAdd(ByVal Item As Object) If TypeOf Item Is Outlook.MailItem Then SaveMailAsFile Item, olSaveAsMsg, MAIL_PATH End If End Sub Private Sub SaveMailAsFile(oMail As Outlook.MailItem, eType As olSaveAsTypeEnum, sPath As String) On Error GoTo err Dim STRfLDR As String Dim sFile As String Dim sExt As String Dim sName As String Select Case eType Case olSaveAsTxt: sExt = ".txt" Case olSaveAsMsg: sExt = ".msg" Case olSaveAsRTF: sExt = ".rtf" Case Else: Exit Sub End Select If CreateFolder = True Then With oMail sName = AddToAloni(Left(.SenderName, 20), Left(.SenderEmailAddress, 25), Trim(Left(.To, 20)), Trim(Left(.Subject, 50)), Trim(Left(.Body, 250)), sExt) & sExt If .SenderName = "" Then STRfLDR = "OUT\" Else STRfLDR = "IN\" End If End With oMail.SaveAs sPath & STRfLDR & sName, eType End If Exit Sub err: MsgBox err.Description End Sub Public Function FnSendMailSafe(StrTo As String, StrCC As String, StrBCC As String, BlnSendDisplay As Boolean, strSubject As String, strMessageBody As String, Optional strAttachments As String) As Boolean On Error GoTo ErrorHandler: Dim MAPISession As Outlook.NameSpace Dim MAPIFolder As Outlook.MAPIFolder Dim MAPIMailItem As Outlook.MailItem Dim oRecipient As Outlook.Recipient Dim TempArray() As String Dim varArrayItem As Variant Dim strEmailAddress As String Dim strAttachmentPath As String Dim blnSuccessful As Boolean Set MAPISession = Application.Session If Not MAPISession Is Nothing Then MAPISession.Logon , , True, False Set MAPIFolder = MAPISession.GetDefaultFolder(olFolderOutbox) If Not MAPIFolder Is Nothing Then Set MAPIMailItem = MAPIFolder.Items.Add(olMailItem) If Not MAPIMailItem Is Nothing Then With MAPIMailItem TempArray = Split(StrTo, ";") For Each varArrayItem In TempArray strEmailAddress = Trim(varArrayItem) If Len(strEmailAddress) > 0 Then Set oRecipient = .Recipients.Add(strEmailAddress) oRecipient.Type = olTo Set oRecipient = Nothing End If Next varArrayItem TempArray = Split(StrCC, ";") For Each varArrayItem In TempArray strEmailAddress = Trim(varArrayItem) If Len(strEmailAddress) > 0 Then Set oRecipient = .Recipients.Add(strEmailAddress) oRecipient.Type = olCC Set oRecipient = Nothing End If Next varArrayItem TempArray = Split(StrBCC, ";") For Each varArrayItem In TempArray strEmailAddress = Trim(varArrayItem) If Len(strEmailAddress) > 0 Then Set oRecipient = .Recipients.Add(strEmailAddress) oRecipient.Type = olBCC Set oRecipient = Nothing End If Next varArrayItem .Subject = strSubject If StrComp(Left(strMessageBody, 6), "", vbTextCompare) = 0 Then .HTMLBody = strMessageBody Else .Body = strMessageBody End If TempArray = Split(strAttachments, ";") For Each varArrayItem In TempArray strAttachmentPath = Trim(varArrayItem) If Len(strAttachmentPath) > 0 Then .Attachments.Add strAttachmentPath End If Next varArrayItem If BlnSendDisplay = False Then .Send Else .Display End If Set MAPIMailItem = Nothing End With End If Set MAPIFolder = Nothing End If MAPISession.Logoff End If blnSuccessful = True ExitRoutine: Set MAPISession = Nothing FnSendMailSafe = blnSuccessful Exit Function ErrorHandler: MsgBox "שגיאת תפעול אוטלוק" & vbCrLf & vbCrLf & "Error Number: " & CStr(err.Number) & vbCrLf & "Error Description: " & err.Description, vbApplicationModal + vbCritical Resume ExitRoutine End Function Private Function AddToAloni(StrName As String, SndrEmail As String, StrTo As String, StrSubj As String, StrBody As String, StrExt As String) As String On Error GoTo err Dim LngMaxId As Long Dim rst As ADODB.Recordset Dim objCon As ADODB.Connection Set objCon = New ADODB.Connection objCon.ConnectionString = "Provider=SQLNCLI.1;Password=1111;Persist Security Info=True;User ID=USER1;Initial Catalog=ALONISQL;Data Source=SERVER" objCon.Open objCon.ConnectionString Dim rcdMailItem As New ADODB.Recordset rcdMailItem.Open "ImageTbl", objCon.ConnectionString, adOpenKeyset, adLockOptimistic Set rst = objCon.Execute("SELECT dbo.ImageMaxId()") LngMaxId = rst.Fields(0) rcdMailItem.AddNew rcdMailItem![selected] = 1 rcdMailItem![DocDate] = Date rcdMailItem![ClientNum] = 0 rcdMailItem![kind] = 2 rcdMailItem![DocType] = 1 rcdMailItem![CodeAnaf] = 0 rcdMailItem![DocName] = LngMaxId If StrName = "" Then rcdMailItem![FileName] = MAIL_PATH & "OUT\" & LngMaxId & StrExt rcdMailItem![ScanName] = StrSubj rcdMailItem![MailIn] = 0 Else rcdMailItem![FileName] = MAIL_PATH & "IN\" & LngMaxId & StrExt rcdMailItem![ScanName] = StrSubj rcdMailItem![MailIn] = 1 rcdMailItem![MailFrom] = SndrEmail End If rcdMailItem![MailTo] = StrTo rcdMailItem![Note] = StrBody rcdMailItem![UserMail] = 1 rcdMailItem.Update AddToAloni = LngMaxId Set rst = objCon.Execute("EXEC UpdateClientNumByMail") Set rst = objCon.Execute("EXEC UpdateMailByClientNumSubj") objCon.Close rcdMailItem.Close Set objCon = Nothing Set rcdMailItem = Nothing Exit Function err: MsgBox err.Description End Function Private Function CreateFolder() As Boolean On Error GoTo err Dim fso Set fso = CreateObject("Scripting.FileSystemObject") If Not fso.FolderExists(MAIL_PATH) Then fso.CreateFolder (MAIL_PATH) If Not fso.FolderExists(MAIL_PATH & "\IN") Then fso.CreateFolder (MAIL_PATH & "\IN") End If If Not fso.FolderExists(MAIL_PATH & "\OUT") Then fso.CreateFolder (MAIL_PATH & "\OUT") End If CreateFolder = True Else If Not fso.FolderExists(MAIL_PATH & "\IN") Then fso.CreateFolder (MAIL_PATH & "\IN") End If If Not fso.FolderExists(MAIL_PATH & "\OUT") Then fso.CreateFolder (MAIL_PATH & "\OUT") End If CreateFolder = True End If Exit Function err: CreateFolder = False End Function