Я не эксперт VBA, но друг написал макрос, который при отправке электронной почты человеку из списка (MoveList) автоматически переместит электронное письмо с «Отправленные элементы» в другую папку.Outlook VBA не работает
До сегодняшнего дня это сработало нормально - я проверил параметры макроса в Outlook (изменен для запуска всех макросов), и он все еще не работает.
Любые идеи? (Я изо всех сил, чтобы вставить макрос, он продолжал жаловаться на форматирование, так ив загрузил его здесь)
Option Explicit
Dim objXL As Object
Dim objWB As Object
Dim objWS As Object
Dim objRange As Object
Private Function InList(ByVal ToList As String, ByVal DistList As Outlook.DistListItem) As Boolean
###################################################
## this function checks if the To list contains #
## Any of the names in the supplied Distribution #
## list using a string compare #
###################################################
Dim i As Integer
Dim test As String
InList = False
For i = 1 To DistList.MemberCount # check if each name is in the to list
test = DistList.GetMember(i).Name
If InStr(1, ToList, test) Then
InList = True # if name is in the to list then set function to true
End If
Next i
End Function
Private Function TwoMonths() As String
###################################################
## this function returns the date 2 months before #
## today. This does not return the time elelment #
## #
###################################################
Dim today As String
Dim day As Integer
Dim month As Integer
Dim year As Integer
today = Now #now returns todays date in the format dd/mm/yyyy hh:mm:ss
day = Left(today, 2)
month = Mid(today, 4, 2)
year = Mid(today, 7, 4)
If month < 2 Then # checks if 2 months ago is in previous year and corrects for this
year = year - 1
month = 10 + month
Else
month = month - 2
End If
TwoMonths = day & "/" & month & "/" & year
End Function
Sub MoveEmails() #(ByVal MoveFrom As String, ByVal MoveTo As String, Distributionlist As String)
####################################################
## This subroutine will move any mail that is sent #
## any person in the distribution list MoveList in #
## the last 2 months from the Sent folders #
####################################################
Dim DefaultInbox As Outlook.Folder
Dim folDefaultSentItems As Outlook.Folder
Dim folDestFolder As Outlook.Folder
Dim DefaultContacts As Outlook.Folder
Dim dlContactList As Outlook.DistListItem
Dim TopFolder As Outlook.Folder
Dim itSentEmails As Outlook.Items
Dim myItem As Object
Dim i As Long
Dim counter As Integer
Dim filterCriteria As String
Dim filteredItemsCollection As Outlook.Items
Dim Last2Months As String
Dim imail
Dim mynamespace
Set mynamespace = Application.GetNamespace("MAPI")
Set DefaultInbox = mynamespace.Folders("my [email protected]") # Change for your primary inbox name
Set DefaultContacts = mynamespace.GetDefaultFolder(olFolderContacts)
Set folDefaultSentItems = DefaultInbox.Folders("Sent Items") #selects "Sent Items" folder to move from
Set TopFolder = mynamespace.Folders("Misc") # Change for your Second inbox name
Set folDestFolder = TopFolder.Folders("Sent (Other)") # Set destination folder
Set dlContactList = DefaultContacts.Items("MoveList") # Selects the distribution list to use for check
Set itSentEmails = folDefaultSentItems.Items # select all items in "Sent Items"
# the next section restricts search to only items sent in the last 2 months
# This is to limit the number of emails checked. Assumes that
# this macro is run at a frequency less than 2 months
Last2Months = TwoMonths
filterCriteria = "[ReceivedTime] > """ & Last2Months & " 12:00 AM"""
Set filteredItemsCollection = itSentEmails.Restrict(filterCriteria)
#loop until all emails are checked
i = 1
While i <= filteredItemsCollection.Count
#loop until all emails are checked
# check if it is a mail item
If filteredItemsCollection(i).Class = olMail Then
# check if to list contains one of the emails in the distribution list
If InList(filteredItemsCollection(i).To, dlContactList) Then
# If it is in the list move the email to the destination folder
filteredItemsCollection(i).Move folDestFolder
# Reset the restricted list. When the email list is moved it changes the indexing
# in the restricted list so the index loop needs to be decramented and the restriction
# list reset. (Error cataching)
Set filteredItemsCollection = itSentEmails.Restrict(filterCriteria)
i = i - 1
End If
End If
i = i + 1 # incrament index reference
Wend
End Sub
Добро пожаловать в StackOverflow! Появляется ли в скрипте какие-либо ошибки? Возможно ли, что региональные настройки (например, формат даты) изменились? – Lyth
Хэши не являются индикаторами комментариев в VBA, поэтому это не будет компилироваться. Что меня немного смущает. В Outlook есть модуль под названием «ThisOutlookSession». Что там? Я предполагаю, что вы использовали событие «ItemSend» для запуска всего этого другого кода, и с ним что-то случилось. –
@Lyth настройки не менялись, все все еще в одном формате (dd/MM/yyyy и h: mm: ss tt – metaljay