Макрос VBA в Outlook для периодической записи входящих писем в БД Access
Добавлено: 23 сен 2017, 19:39
Всем доброго дня!
Поскольку в VBA я не силен.
Просьба помочь в решении следующей задачи есть установленный Outlook, необходимо, что бы Outlook периодически записывал все поступающие в БД Access.
написал следующий макрос но при запуске макроса подсвечивает Sub LOG()
Поскольку в VBA я не силен.
Просьба помочь в решении следующей задачи есть установленный Outlook, необходимо, что бы Outlook периодически записывал все поступающие в БД Access.
написал следующий макрос но при запуске макроса подсвечивает Sub LOG()
Код: Выделить всё
'LOG - Имя макроса
Sub LOG()
'Private WithEvents myOlItems As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set myOlItems = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub myOlItems_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
Dim objAtt As Outlook.Attachment
Dim iBody, iAttachments, iRecipients As String
If TypeName(item) = "MailItem" Then
Set Msg = item
' Debug.Print Msg.Subject
Dim q As Integer
'Dim iRecipients, iAttachments As String
With Msg
If .Recipients.Count > 0 Then
For q = 1 To .Recipients.Count
iRecipients = .Recipients.item(q).Name & "; " & iRecipients
Next q
End If
End With
With Msg
If .Attachments.Count > 0 Then
For q = 1 To .Attachments.Count
Set objAtt = .Attachments(q)
iAttachments = objAtt.FileName & " | " & iAttachments
Next q
End If
End With
iBody = Replace(RemoveHTML(Msg.Body), "'", "`")
Dim conn As New ADODB.Connection
Dim RS As New ADODB.Recordset
Dim stm As ADODB.Stream
conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=D:\test.accdb;Persist Security Info=False"
conn.Execute "INSERT INTO ImportOutlook " & _
" (Subject, Body, Recipients, " & _
" SenderName, Recieved, FilesCount, Attachments, N)" & _
" VALUES ('" & Msg.Subject & "' , '" & iBody & "', '" & iRecipients & "', " & _
"'" & Msg.SenderName & "', '" & Msg.CreationTime & "', '" & Msg.Attachments.Count & "', '" & iAttachments & "', '" & Msg.EntryID & "')"
conn.Close
' attachments (files)
Dim MyDateID
MyDateID = Msg.EntryID
DestFolder = "D:\AutoEmails2\"
'For Each Msg In myFolder.Items.Restrict("[Unread]=TRUE")
If Msg.Attachments.Count > 0 Then
If Len(Dir(DestFolder & MyDateID, vbDirectory)) = 0 Then
MkDir DestFolder & MyDateID
End If
For j = 1 To Msg.Attachments.Count
Msg.Attachments.item(j).SaveAsFile DestFolder & "\" & MyDateID & "\" & Msg.Attachments.item(j).DisplayName
Next j
End If
' mi.UnRead = False
'Next
End If
ProgramExit:
Exit Sub
ErrorHandler:
Debug.Print Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Function RemoveHTML(sString As String) As String
'MsgBox RemoveHTML("<html><b>And</b><!-- some comment --> <p>then
some</p></html>")
On Error GoTo Error_Handler
Dim oRegEx As Object
Set oRegEx = CreateObject("vbscript.regexp")
With oRegEx
'.Pattern = "<[^>]+>" 'basic html pattern
.Pattern = "<!*[^<>]*>" 'html tags and comments
.Global = True
.IgnoreCase = True
.MultiLine = True
End With
RemoveHTML = oRegEx.Replace(sString, "")
Error_Handler_Exit:
On Error Resume Next
Set oRegEx = Nothing
Exit Function
Error_Handler:
MsgBox "The following error has occured." & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: RemoveHTML" & vbCrLf & _
"Error Description: " & Err.Description, _
vbCritical, "An Error has Occured!"
Resume Error_Handler_Exit
End Function
End Function