Question

我不是VBA专家，但朋友写了一个宏，在从列表（MoveList）向个人发送电子邮件时，它会自动将电子邮件从“已发送邮件”移动到另一个文件夹。

直到今天，这个工作正常 - 我已经检查了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@email.com") # 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

Answer 1

2月份，月份在TwoMonths函数中计算为零

添加：

If month = 0 Then
    month = 12
    year = year - 1
End If

Outlook VBA未运行

1 个答案: