Макрос VBA в Outlook для периодической записи входящих писем в БД Fccess

Весь MS Office, программирование на Visual Basic for Applications и MS VB

Модератор: Naeel Maqsudov

Ответить
Margenal
Сообщения: 2
Зарегистрирован: 20 авг 2017, 10:54

23 сен 2017, 19:39

Всем доброго дня!

Поскольку в 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
Ответить