+ Ответить в теме
Показано с 1 по 1 из 1

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

  1. #1
    Margenal is on a distinguished road
    Регистрация
    20.08.2017
    Сообщений
    2
    Вес репутации
    0

    По умолчанию Макрос VBA в Outlook для периодической записи входящих писем в БД Access

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

    Поскольку в VBA я не силен.

    Просьба помочь в решении следующей задачи есть установленный Outlook, необходимо, что бы Outlook периодически записывал все поступающие в БД Access.

    написал следующий макрос но при запуске макроса подсвечивает Sub LOG()

    Код :
    1.  'LOG - Имя макроса
    2. Sub LOG()
    3. 'Private WithEvents myOlItems  As Outlook.Items
    4.  
    5. Private Sub Application_Startup()
    6.     Dim olApp As Outlook.Application
    7.     Dim objNS As Outlook.NameSpace
    8.       Set olApp = Outlook.Application
    9.       Set objNS = olApp.GetNamespace("MAPI")
    10.       Set myOlItems = objNS.GetDefaultFolder(olFolderInbox).Items
    11. End Sub
    12.  
    13. Private Sub myOlItems_ItemAdd(ByVal item As Object)
    14.  
    15. On Error GoTo ErrorHandler
    16.  
    17.   Dim Msg As Outlook.MailItem
    18.   Dim objAtt As Outlook.Attachment
    19.   Dim iBody, iAttachments, iRecipients As String
    20.  
    21.   If TypeName(item) = "MailItem" Then
    22.     Set Msg = item
    23.     ' Debug.Print Msg.Subject
    24.    
    25.     Dim q As Integer
    26.     'Dim iRecipients, iAttachments As String
    27.     With Msg
    28.      If .Recipients.Count > 0 Then
    29.       For q = 1 To .Recipients.Count
    30.        iRecipients = .Recipients.item(q).Name & "; " & iRecipients
    31.       Next q
    32.      End If
    33.     End With
    34.    
    35.     With Msg
    36.     If .Attachments.Count > 0 Then
    37.      For q = 1 To .Attachments.Count
    38.       Set objAtt = .Attachments(q)
    39.       iAttachments = objAtt.FileName & " | " & iAttachments
    40.      Next q
    41.     End If
    42.     End With
    43.    
    44.     iBody = Replace(RemoveHTML(Msg.Body), "'", "`")
    45.  
    46.     Dim conn As New ADODB.Connection
    47.     Dim RS As New ADODB.Recordset
    48.     Dim stm As ADODB.Stream
    49.  
    50.     conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=D:\test.accdb;Persist Security Info=False"
    51.    
    52.     conn.Execute "INSERT INTO ImportOutlook " & _
    53.     " (Subject, Body, Recipients,  " & _
    54.     " SenderName, Recieved, FilesCount, Attachments, N)" & _
    55.     " VALUES ('" & Msg.Subject & "' , '" & iBody & "', '" & iRecipients & "', " & _
    56.     "'" & Msg.SenderName & "', '" & Msg.CreationTime & "', '" & Msg.Attachments.Count & "',  '" & iAttachments & "',  '" & Msg.EntryID & "')"
    57.    
    58.     conn.Close
    59.    
    60.         ' attachments (files)
    61.         Dim MyDateID
    62.         MyDateID = Msg.EntryID
    63.         DestFolder = "D:\AutoEmails2\"
    64.         'For Each Msg In myFolder.Items.Restrict("[Unread]=TRUE")
    65.         If Msg.Attachments.Count > 0 Then
    66.             If Len(Dir(DestFolder & MyDateID, vbDirectory)) = 0 Then
    67.                    MkDir DestFolder & MyDateID
    68.             End If
    69.             For j = 1 To Msg.Attachments.Count
    70.              Msg.Attachments.item(j).SaveAsFile DestFolder & "\" & MyDateID & "\" & Msg.Attachments.item(j).DisplayName
    71.              
    72.             Next j
    73.         End If
    74.         ' mi.UnRead = False
    75.         'Next
    76.        
    77.   End If
    78.  
    79.  
    80. ProgramExit:
    81.   Exit Sub
    82. ErrorHandler:
    83.   Debug.Print Err.Number & " - " & Err.Description
    84.   Resume ProgramExit
    85. End Sub
    86.  
    87. Function RemoveHTML(sString As String) As String
    88.  'MsgBox RemoveHTML("<html><b>And</b><!-- some comment --> <p>then<br/> some</p></html>")
    89.     On Error GoTo Error_Handler
    90.     Dim oRegEx          As Object
    91.  
    92.     Set oRegEx = CreateObject("vbscript.regexp")
    93.  
    94.     With oRegEx
    95.         '.Pattern = "<[^>]+>"    'basic html pattern
    96.         .Pattern = "<!*[^<>]*>"    'html tags and comments
    97.         .Global = True
    98.         .IgnoreCase = True
    99.         .MultiLine = True
    100.     End With
    101.  
    102.     RemoveHTML = oRegEx.Replace(sString, "")
    103.  
    104. Error_Handler_Exit:
    105.     On Error Resume Next
    106.     Set oRegEx = Nothing
    107.     Exit Function
    108.  
    109. Error_Handler:
    110.     MsgBox "The following error has occured." & vbCrLf & vbCrLf & _
    111.            "Error Number: " & Err.Number & vbCrLf & _
    112.            "Error Source: RemoveHTML" & vbCrLf & _
    113.            "Error Description: " & Err.Description, _
    114.            vbCritical, "An Error has Occured!"
    115.     Resume Error_Handler_Exit
    116. End Function
    117.  
    118. End Function
    Последний раз редактировалось Margenal; 24.09.2017 в 11:52.

  2. По умолчанию

     
    Хотите избавиться от рекламы? Зарегистрируйтесь
+ Ответить в теме

Похожие темы

  1. Ввод периодической дроби в Паскале!!
    Периодическая десятичная дробь обычно записывается в виде: Любая простая дробь может быть представлена в виде десятичной периодической дроби и...
    от Alija в разделе задачи на Паскале и Delphi
  2. SMS. Отправка из скрипта. Получение входящих на URL.
    На днях наткнулся на занятный sms-gate. Подключение бесплатно, без абонентской платы. Позволяет отправлять SMS сообщения через POST запрос. Можно...
    от koldun в разделе Perl, PHP, ASP ...
  3. MS Excel и MS Outlook (2003) отсылка писем
    Доброго времени суток ! Нуждаюсь в помощи решить проблему в Excel 2003 и MS Outlook . Имеется таблица юзеров компании. Ежедневно (по 2 - 3 раза...
    от IceB в разделе MS Office и VB(A).
  4. Как в Outlook сделать OpenDialog для папок Outlook'a
    Как в Outlook сделать OpenDialog для папок Outlook'a.
    от namomelkor в разделе MS Office и VB(A).
  5. как обратится произвольной записи в Outlook или к произвольному свойству этой записи.
    Как в outlook обратится к произвольной записи например прочитать адрес отправителя в произвольном письме или фамилию в произвольном контакте без...
    от namomelkor в разделе MS Office и VB(A).

Ваши права

  • Вы не можете создавать новые темы
  • Вы не можете отвечать в темах
  • Вы не можете прикреплять вложения
  • Вы не можете редактировать свои сообщения