Searching Email between Month Dates

H

Handyman84

New Member
Joined
May 5, 2018
Messages
17
Hi Below is the code from a userform for a listbox that returns emails from outlook, I'm having trouble searching between 2 dates when I search a date between months, searching within the same month works OK.

When clicking on the list box it displays the message in the below textbox and then the user can copy to a another textbox on another userform.

I've done a debug print to try get my head around it but can't see how the dates need to be formatted to work, the preferred date format is dd/mm/yyyy.

It needs tidying up and I had a bit of a mare trying to clean the body up of the email for chr(13) and chr (10), but is ok for now. (Alot of stuff is commented out)

Code: 
Private Sub PreviewMail()
    Dim strng As String
    Dim lCol As Long, lRow As Long
'https://stackoverflow.com/questions/39244444/how-to-get-selected-value-in-multicolumn-listbox
    With Me.ListBox1 '<--| refer to your listbox: change "ListBox1" with your actual listbox name
        For lRow = 0 To .ListCount - 1 '<--| loop through listbox rows
            If .Selected(lRow) Then '<--| if current row selected
                For lCol = 0 To .ColumnCount - 1 '<--| loop through listbox columns
                    
                strng = strng & .List(lRow, lCol) & " | " '<--| build your output string


                
                    'https://bytes.com/topic/access/answers/205460-remove-multiple-chr-13-chr-10-a
                    'Do While InStr(1, strng, vbCrLf & vbCrLf)
                    'strng = Replace(strng, vbCrLf & vbCrLf, vbCrLf)
                    'Loop
                    
                Next lCol
                
                TextBox1.Value = Left(strng, (Len(strng) - 3)) '<--| show output string (after removing its last character ("|"))
                Exit For '<-_| exit loop
            End If
        Next lRow
    End With
End Sub


Private Sub CommandButton5_Click()
Unload Me
End Sub


Private Sub ExportMailStr_Click()
 Dim FirstIndexNo As Integer
    Dim i As Integer
    FirstIndexNo = -1
    With Me.ListBox1
        For i = 0 To .ListCount - 1
            If .Selected(i) Then
                FirstIndexNo = i
                Exit For
            End If
        Next i
    End With
    
    If IsUserFormLoaded("TextEntry") <> True Then GoTo FormNotLoaded
    
    If FirstIndexNo <> -1 Then
    
        'MsgBox ListBox1.List(FirstIndexNo, 5)
        TextEntry.TextBox1.Value = TextEntry.TextBox1.Value & vbNewLine & ExportMail.ListBox1.List(FirstIndexNo, 5)
        TextEntry.Show
        ExportMail.Hide
        
    Else
        MsgBox "No selection was made...", vbInformation
    End If
    
    Exit Sub
    
FormNotLoaded:
    MsgBox "TextEntry not loaded, must be loaded to import mail", vbOKOnly + vbInformation, "Load Email Error"
    
End Sub


Private Sub Label6_Click()


End Sub


Private Sub ListBox1_Change()


  Dim N As Long
  '
  '  Lead-in code, if any
  '
  For N = 0 To ListBox1.ListCount - 1
    If (ListBox1.Selected(N) And IsUserFormLoaded("TextEntry")) Then GoTo FoundSomething
  Next
ExportMailStr.Enabled = False
  Exit Sub
FoundSomething:
  '
  '  Following code, if any
  '
ExportMailStr.Enabled = True


End Sub


Private Sub ListBox1_Click()
PreviewMail


 Dim N As Long
  '
  '  Lead-in code, if any
  '
  For N = 0 To ListBox1.ListCount - 1
    If (ListBox1.Selected(N) And IsUserFormLoaded("TextEntry")) Then GoTo FoundSomething
  Next
ExportMailStr.Enabled = False
  Exit Sub
FoundSomething:
  '
  '  Following code, if any
  '
ExportMailStr.Enabled = True


End Sub
Private Sub LoadMails_Click()
'Add Tools->References->"Microsoft Outlook nn.n Object Library"
'nn.n varies as per our Outlook Installation


'https://stackoverflow.com/questions/22542834/how-to-use-regular-expressions-regex-in-microsoft-excel-both-in-cell-and-loops


Dim folder As Object
Dim iRow As Integer
Dim Radd As Long
Dim olApp As Object
Dim BodyStr As String


Dim MIN_DATE As Date
Dim MAX_DATE As Date
Dim MONTH_FMT As Date


Dim X As Long
Dim mailstext As String


ListBox1.Clear
Label8.Caption = ""
TextBox1.Value = ""
Me.Caption = "Import EMail As Text"


'https://stackoverflow.com/questions/28941582/exporting-emails-from-an-outlook-subfolder-to-excel
     
    'http://www.vbaexpress.com/forum/showthread.php?40495-Check-date-is-between-2-dates
    
    
    MIN_DATE = Format(Me.sDate.Value, "dd/mm/yyyy")
    MAX_DATE = Format(Me.eDate.Value, "dd/mm/yyyy")
    
    If IsDate(MIN_DATE) = False Then MIN_DATE = Format([Today()], "dd/mm/yyyy")
    If IsDate(MAX_DATE) = False Then MAX_DATE = Format([Today()], "dd/mm/yyyy")
    
    If Day(MIN_DATE) < 13 Then
    dateformats = "mm/dd/yyyy"
    Else
    dateformats = "dd/mm/yyyy"
    End If
    
    If Day(MAX_DATE) < 13 Then
    dateformate = "mm/dd/yyyy"
    Else
    dateformate = "dd/mm/yyyy"
    End If


'//Create instance of Outlook
Set olApp = CreateObject("Outlook.Application")


Set folder = olApp.GetNamespace("MAPI").PickFolder


If folder Is Nothing Then
   MsgBox "No folder selected", vbOKOnly + vbInformation, "File Select"
   Exit Sub
End If


i = 0
X = 0


Label5.Caption = "Searching Email Folder: " & folder & ", Double Click email to view entry"
Me.Caption = "Import EMail As Text" & " - " & "Searching Email Folder: " & folder & ", Double Click email to view entry"


If folder = "Inbox" Then GoTo Overload 'Inbox will have way to many


For iRow = 1 To folder.Items.Count


MONTH_FMT = Format(folder.Items.Item(iRow).ReceivedTime, "dd/mm/yyyy")


    If Day(MONTH_FMT) < 13 Then
    dateformatm = "mm/dd/yyyy"
    Else
    dateformatm = "dd/mm/yyyy"
    End If




'On Error GoTo errorexit
On Error Resume Next 'Allow mails missing details




'Debug.Print Format(folder.Items.Item(iRow).ReceivedTime, "YYYY") & " < " & Format(MIN_DATE, "YYYY")
'Debug.Print Format(folder.Items.Item(iRow).ReceivedTime, "YYYY") & " > " & Format(MAX_DATE, "YYYY")


'Debug.Print Format(folder.Items.Item(iRow).ReceivedTime, "MM") & " < " & Format(MIN_DATE, "MM")
'Debug.Print Format(folder.Items.Item(iRow).ReceivedTime, "DD") & " < " & Format(MIN_DATE, "DD")


'Debug.Print Format(folder.Items.Item(iRow).ReceivedTime, "MM") & " > " & Format(MAX_DATE, "MM")
'Debug.Print Format(folder.Items.Item(iRow).ReceivedTime, "DD") & " > " & Format(MAX_DATE, "DD")


'If Format(folder.Items.Item(iRow).ReceivedTime, "YYYY") < Format(MIN_DATE, "YYYY") Then GoTo skipedit
'If Format(folder.Items.Item(iRow).ReceivedTime, "YYYY") > Format(MAX_DATE, "YYYY") Then GoTo skipedit


'If Format(folder.Items.Item(iRow).ReceivedTime, "MM") < Format(MIN_DATE, "MM") Then GoTo skipedit
'If Format(folder.Items.Item(iRow).ReceivedTime, "DD") < Format(MIN_DATE, "DD") Then GoTo skipedit


'If Format(folder.Items.Item(iRow).ReceivedTime, "MM") > Format(MAX_DATE, "MM") Then GoTo skipedit
'If Format(folder.Items.Item(iRow).ReceivedTime, "DD") > Format(MAX_DATE, "DD") Then GoTo skipedit






'Rules
If Format(folder.Items.Item(iRow).ReceivedTime, "yyyy") < Format(MIN_DATE, "yyyy") Then GoTo skipedit
If Format(folder.Items.Item(iRow).ReceivedTime, "yyyy") > Format(MAX_DATE, "yyyy") Then GoTo skipedit
If folder.Items.Item(iRow).Subject Like "Undeliverable*" Then GoTo skipedit




'This if statement is not working
If (Format(folder.Items.Item(iRow).ReceivedTime, dateformatm) >= Format(MIN_DATE, dateformats) And Format(folder.Items.Item(iRow).ReceivedTime, dateformatm) <= Format(MAX_DATE, dateformate)) Then
         


         On Error Resume Next
                  
         With Me.ListBox1
        .ColumnCount = 6
        .ColumnWidths = "100;100;100;30;100;60;" '"60;60;60;60;60;60"
        .AddItem
        .List(i, 0) = folder.Items.Item(iRow).SenderName
        .List(i, 1) = folder.Items.Item(iRow).Subject
        .List(i, 2) = Format(folder.Items.Item(iRow).ReceivedTime, "dd/mm/yyyy hh:mm:ss")
        '.List(i, 2) = folder.Items.Item(iRow).ReceivedTime
        .List(i, 3) = FormatMsgSize(folder.Items.Item(iRow).Size)
        .List(i, 4) = folder.Items.Item(iRow).SenderEmailAddress
        
        BodyStr = folder.Items.Item(iRow).Body
        
        'https://stackoverflow.com/questions/2516702/getting-around-the-max-string-size-in-a-vba-function
        If Len(BodyStr) > 1000 Then
        BodyStr = TrimWords(BodyStr, 950)
        ElseIf Len(BodyStr) > 5 Then
        BodyStr = Left(BodyStr, InStr(BodyStr, "Regards") - 1)
        BodyStr = Left(BodyStr, InStr(BodyStr, "Kind") - 1)


        Else
        BodyStr = "No Email Available"
        End If
        
        '.List(i, 5) = vbNewLine & replaceBreaks(BodyStr)
        '.List(i, 5) = vbNewLine & replaceBreaks(RemoveExtra(RemoveExtra(BodyStr, Chr(13), 1), Chr(10), 1))
         .List(i, 5) = vbNewLine & JustTwo(BodyStr)
        '.List(i, 5) = vbNewLine & RemoveExtra(BodyStr, Chr(13) & Chr(10), 1) '160
        '.List(i, 5) = ReplaceDot(BodyStr)
        '.List(i, 5) = RemoveBlankLines(BodyStr)
        '.List(i, 5) = simpleCellRegex(BodyStr)
        '.List(i, 5) = BodyStr
        '.List(i, 5) = ReplaceDot(BodyStr)
        '.List(i, 5) = CleanTrim(BodyStr)
        
         End With
        i = i + 1
              'Debug.Print (Format(folder.Items.Item(iRow).ReceivedTime, dateformatm) & " >= " & Format(MIN_DATE, dateformats) & " And " & Format(folder.Items.Item(iRow).ReceivedTime, dateformatm) & " <= " & Format(MAX_DATE, dateformate))


     End If
     'This if statement is not working
     
skipedit:
              'Debug.Print (Format(folder.Items.Item(iRow).ReceivedTime, dateformatm) & " >= " & Format(MIN_DATE, dateformats) & " And " & Format(folder.Items.Item(iRow).ReceivedTime, dateformatm) & " <= " & Format(MAX_DATE, dateformate))


     X = X + 1 'Mails count
     
        'Debug.Print folder.Items.Item(iRow).SenderName
        'Debug.Print folder.Items.Item(iRow).Subject
        'Debug.Print folder.Items.Item(iRow).ReceivedTime
        'Debug.Print folder.Items.Item(iRow).Size
        'Debug.Print folder.Items.Item(iRow).SenderEmailAddress
        'Debug.Print folder.Items.Item(iRow).Body
        
'Found Mails
If ListBox1.ListCount > 0 And ListBox1.ListCount < 1 Then
mailstext = ", " & ListBox1.ListCount & " EMail"
ElseIf ListBox1.ListCount > 0 And ListBox1.ListCount > 1 Then
mailstext = ", " & ListBox1.ListCount & " EMails"
Else
mailstext = ", " & "No EMail Loaded"
End If
     
'Show status
Label8.Caption = Format((iRow / folder.Items.Count) * 100, "#") & "% Loaded & Scanning Mail " & X & " of " & folder.Items.Count & mailstext
Me.Caption = Format((iRow / folder.Items.Count) * 100, "#") & "% Loaded & Scanning Mail " & X & " of " & folder.Items.Count & mailstext


Next iRow


'Done
MsgBox ListBox1.ListCount & " Outlook Mails Extracted to Excel", vbOKOnly + vbInformation, ListBox1.ListCount & " Found Mails"


If ListBox1.ListCount > 0 And ListBox1.ListCount < 1 Then
mailstext = ListBox1.ListCount & " EMail Loaded"
Label8.Caption = mailstext
Me.Caption = mailstext
ElseIf ListBox1.ListCount > 0 And ListBox1.ListCount > 1 Then
mailstext = ListBox1.ListCount & " EMails Loaded"
Label8.Caption = mailstext
Me.Caption = mailstext
Else
mailstext = "No EMail Loaded"
Label8.Caption = mailstext
Me.Caption = mailstext
Application.Wait (Now + TimeValue("00:00:02"))
ListBox1.Clear
Label8.Caption = ""
TextBox1.Value = ""
Me.Caption = "Import EMail As Text"
End If




Exit Sub


errorexit:
MsgBox "Unable to find emails", vbOKOnly + vbInformation, "Search Error"


Exit Sub


Overload:
MsgBox "Please select user folder, Inbox to large to search", vbOKOnly + vbInformation, "Search Error"


End Sub
Function replaceBreaks(Breakit As String) As String
'http://asciivalue.com/index.php
'replaceBreaks = Replace(Replace(Breakit, Chr(160), ""), Chr(32), "") '<--| build your output string
replaceBreaks = Replace(Breakit, Chr(160), "") '<--| build your output string
'replaceBreaks = RemoveExtra(replaceBreaks, Chr(13) + Chr(10), 1)
End Function
Function ReplaceDot(InString As String) As String
ReplaceDot = Application.WorksheetFunction.Clean(InString)
End Function
Function CleanTrim(ByVal S As String, Optional ConvertNonBreakingSpace As Boolean = True) As String
'http://www.excelfox.com/forum/showthread.php/155-Trim-all-Cells-in-a-Worksheet-VBA#post1092
  Dim X As Long, CodesToClean As Variant
  CodesToClean = Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, _
                       21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 127, 129, 141, 143, 144, 157)
  If ConvertNonBreakingSpace Then S = Replace(S, Chr(160), " ")
  For X = LBound(CodesToClean) To UBound(CodesToClean)
    If InStr(S, Chr(CodesToClean(X))) Then S = Replace(S, Chr(CodesToClean(X)), "")
  Next
  CleanTrim = WorksheetFunction.Trim(S)
End Function
Function JustTwo(parmString As String) As String
    '====================================
    'Replace all double space strings with a single space.
    'Iterate until there are no more double space character
    'strings
    'https://www.experts-exchange.com/articles/17559/Efficient-String-Clean-up-Removing-Internal-Duplicate-Spaces.html
    '====================================
    Dim strTemp As String
    strTemp = parmString
    Do Until InStr(strTemp, Chr(13) & Chr(160)) = 0
        strTemp = Replace(strTemp, Chr(13) & Chr(160), Chr(10))
    Loop
    JustTwo = strTemp
End Function


Private Sub iDate1_Click()
    With Me.sDate
        .Text = my_date_selection(.Value)
    End With
End Sub


Private Sub iDate2_Click()
    With Me.eDate
        .Text = my_date_selection(.Value)
    End With
End Sub


Private Sub SelText_Click()


    If IsUserFormLoaded("TextEntry") <> True Then GoTo FormNotLoaded
    
    If Len(ExportMail.TextBox1.SelText) > 0 Then
    
        TextEntry.TextBox1.Value = TextEntry.TextBox1.Value & vbNewLine & ExportMail.TextBox1.SelText
        TextEntry.Show
        ExportMail.Hide
        
    Else
        MsgBox "No selection was made...", vbInformation
    End If
    
    Exit Sub
    
FormNotLoaded:
    MsgBox "TextEntry not loaded, must be loaded to import mail", vbOKOnly + vbInformation, "Load Email Error"
End Sub


Private Sub TextBox1_Change()


If Len(ExportMail.TextBox1.SelText) > 0 Then
Me.SelText.Enabled = True
Else
Me.SelText.Enabled = False
End If


End Sub


Private Sub TextBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Len(ExportMail.TextBox1.SelText) > 0 Then
Me.SelText.Enabled = True
Else
Me.SelText.Enabled = False
End If


End Sub


Private Sub UserForm_Activate()
'Works if anchor not on
Call HookMouseWheelScroll(Me)
End Sub
Private Sub UserForm_Initialize()
        
Label5.Caption = "Select Oulook folder to search mail"
Me.Caption = "Import EMail As Text"
ExportMailStr.Enabled = False
Me.SelText.Enabled = False
Label8.Caption = ""
sDate.Value = Format(CDate([Today()]), "dd/mm/yyyy")
eDate.Value = Format(CDate([Today()]), "dd/mm/yyyy")


'sDate.Value = CDate([TODAY()])
'eDate.Value = CDate([TODAY()])


Label6.Caption = "Choose Dates as optional, default is todays Date: " & Format([Today()], "dd/mm/yyyy")
End Sub
Public Function TrimWords(sValue As String, lMaxLength As Long) As String
'https://www.ozgrid.com/forum/forum/help-forums/excel-general/71357-trim-words-to-meet-character-length
    Dim sRet As String
    
    If Len(sValue) > lMaxLength Then
        sRet = Left(sValue, InStrRev(sValue, Chr(32), lMaxLength))
    Else
        sRet = sValue
    End If


    TrimWords = sRet
    
End Function
Function FormatMsgSize(SizeStr As Long)


Select Case SizeStr
        
        Case 0 To 1023
            FormatMsgSize = Format(SizeStr, "0") & "B"
        Case 1024 To 104875
            FormatMsgSize = Format(SizeStr / 1024, "0") & "KB"
        Case 104876 To 1073741823
            FormatMsgSize = Format(SizeStr / 104876, "0") & "MB"
        Case 1073741824 To 1.11111111111074E+20
            FormatMsgSize = Format(SizeStr / 1073741823, "0.00") & "GB"
End Select
    
End Function


Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    'Works if anchor not on
    Call RemoveMouseWheelHook
End Sub

 

Excel Facts

Links? Where??
If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.
Sort by date Sort by votes
Ended up fixing with this..

Code: 
'RulesIf folder.Items.Item(iRow).Subject Like "Undeliverable*" Then GoTo skipedit


MIN_DATE = Me.sDate.Value
MAX_DATE = Me.eDate.Value


dtmMyDate = Int(folder.Items.Item(iRow).ReceivedTime)


'http://www.vbaexpress.com/forum/showthread.php?40495-Check-date-is-between-2-dates
If dtmMyDate >= MIN_DATE And dtmMyDate <= MAX_DATE Then
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question Question
Outlook office 365, search between dates
Replies
2
Views
88
Peter_SSs
Peter_SSs
O
  • Question Question
Add Signature to Email Macro
Replies
1
Views
370
starl
starl
J
  • Question Question
Send bulk email attachment error
Replies
3
Views
113
JOHATUP
J
R
  • Question Question
Compose Email VBA Help
Replies
1
Views
138
Logit
Logit
I
  • Question Question
Unable to run VBA code
Replies
6
Views
165
RoryA
RoryA

Forum statistics

Threads
1,224,813
Messages
6,181,117
Members
453,021
Latest member
Justyna P

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top