Sub Call_SaveAttachment_UserForm()SaveAttachment_UserForm.Show FalseEnd Sub
Private Sub cmdCancel_Click()
Unload Me
End Sub
--------------------------------------------------------
Private Sub UserForm_Initialize()
ComboBox1.AddItem "Delhi_Ncr"
ComboBox1.AddItem "Outstation"
End Sub
-----------------------------------------------------------
Private Sub cmdMailDelete_Click()
If ComboBox1.Value = "Delhi_Ncr" Then
Call cmdMailDeleteDelhiNcr_Click
Else
Call cmdMailDeleteOutstation_Click
End If
End Sub
-----------------------------------------------------------------------
Private Sub cmdMailDeleteDelhiNcr_Click()
Dim out_app As Outlook.Application
Dim folders As Outlook.NameSpace
Dim myfolder As Outlook.MAPIFolder
Dim oOlResults As Object
Set out_app = New Outlook.Application
Set folders = out_app.GetNamespace("mapi")
Set myfolder = folders.GetDefaultFolder(olFolderInbox)
Set myfolder = myfolder.folders("Delhi_NCR")
Dim dStart As Date
dStart = InputBox("Enter Start date ")
Dim d As Date
d = dStart
Dim f As String
f = "([ReceivedTime] <= '" & Day(d) & "-" & Month(d) & "-" & Year(d) & "')"
Set oOlResults = myfolder.Items.Restrict(f)
Set Item = oOlResults.Find(f)
While Not (Item Is Nothing)
Item.Delete
Set Item = oOlResults.FindNext
Wend
End Sub
-----------------------------------------------------------
Private Sub cmdMailDeleteOutstation_Click()
Dim out_app As Outlook.Application
Dim folders As Outlook.NameSpace
Dim myfolder As Outlook.MAPIFolder
Dim oOlResults As Object
Set out_app = New Outlook.Application
Set folders = out_app.GetNamespace("mapi")
Set myfolder = folders.GetDefaultFolder(olFolderInbox)
Set myfolder = myfolder.folders("Outstation")
Dim dStart As Date
dStart = InputBox("Enter Start date ")
Dim d As Date
d = dStart
Dim f As String
f = "([ReceivedTime] <= '" & Day(d) & "-" & Month(d) & "-" & Year(d) & "')"
Set oOlResults = myfolder.Items.Restrict(f)
Set Item = oOlResults.Find(f)
While Not (Item Is Nothing)
Item.Delete
Set Item = oOlResults.FindNext
Wend
End Sub
-------------------------------------------------------------------------------
Private Sub cmdSaveAttachmentDelhiNcr_Click()
Dim myOlApp As Outlook.Application 'For Outlook
Dim myNameSpace As Outlook.NameSpace 'For Outlook
Dim myfolder As Outlook.MAPIFolder 'For Outlook
Dim myItem As Outlook.MailItem 'For Outlook
Dim myAttachment As Outlook.Attachment 'For Outlook
Dim dStart As Date 'For Date
Dim dEnd As Date 'For Date
Dim TheDate As String 'For Date
TheDate = Format(Date, "DD-MM-YYYY") 'For Date
'TheDate = Format((Date) - 1, "DD-MM-YYYY") 'For Back Date
Set myOlApp = CreateObject("Outlook.Application") 'For Outlook
Set myNameSpace = myOlApp.GetNamespace("MAPI") 'For Outlook
Set myfolder = myNameSpace.GetDefaultFolder(olFolderInbox) 'For Outlook
Set myfolder = myfolder.folders("Delhi_NCR") 'For Outlook
Set myItems = myfolder.Items 'For Outlook
'dStart = InputBox("Enter date to filter the email subject", "Extract Outlook email attachments") 'For Particular Date
'dStart = "2018/11/08 17:00"
'dEnd = InputBox("Enter date to filter the email subject", "Extract Outlook email attachments") 'For Particular Date
'dEnd = "2018/11/08"
dEnd = TheDate 'For Date
dStart = TheDate 'For Date
Dim sFilterLower As String
Dim sFilterUpper As String
Dim oOlResults As Object
sFilterLower = "[ReceivedTime]>'" & Format(dStart, "DDDDD HH:NN") & "'"
Set oOlResults = myfolder.Items.Restrict(sFilterLower)
'sFilterUpper = "[ReceivedTime]>'" & Format(dStart, "DDDDD HH:NN") & "'"
'Set oOlResults = myFolder.Items.Restrict(sFilterUpper)
Debug.Print oOlResults.Count & " items."
'create folder of today
Dim fsoObj As Object
enddir = ("\\OutlookSaveDSRAttachment\Delhi_Ncr\" & TheDate & "\")
Set fsoObj = CreateObject("Scripting.FileSystemObject")
With fsoObj
If Not .FolderExists(enddir) Then
.CreateFolder (enddir)
End If
End With
'Outlook coding
Dim myfile As String
Dim ReceivedHour As Date
Dim myPath As String
Dim OutlookMail As Variant
Dim name As Object
Dim j As Long
Dim i, c, l As Long
Dim aa As Variant
Dim strEmail As String
If oOlResults.Count > 0 Then
oOlResults.Sort "[ReceivedTime]", True 'For Latest Updated attachment
For j = 1 To oOlResults.Count
strEmail = oOlResults(j).SenderEmailAddress
Set name = oOlResults(j)
For Each myAttachment In name.Attachments
aa = myAttachment
ReceivedHour = name.ReceivedTime
i = i + 1
myAttachment.SaveAsFile enddir & aa
myfile = enddir & aa
'myAttachment.SaveAsFile "\Desktop\Save_attachment\Out_of_station\" & aa
'myfile = "\Desktop\Save_attachment\Out_of_station\" & aa
'NewName = "\Desktop\Save_attachment\Out_of_station\" & strEmail & Format(ReceivedHour, "DD-MMM-YYYY hh mm AMPM") & ".xlsx"
NewName = enddir & strEmail & ".xls"
myPath = "\OutlookSaveDSRAttachment\Delhi_Ncr\" & TheDate & "\"
'NewName = enddir & strEmail & Format(ReceivedHour, "DD-MMM-YYYY hh mm AMPM") & ".xls"
OutlookMail = NewName
On Error Resume Next
If Dir(myfile) <> "" Then
Name myfile As OutlookMail
Else
MsgBox "File not found"
End If
Next
Next j
MsgBox "Delhi_NCR Process Complete"
End If
End Sub
--------------------------------------------------------------------
Private Sub cmdSaveAttachmentOutstation_Click()
Dim myOlApp As Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim myfolder As Outlook.MAPIFolder
Dim myItem As Outlook.MailItem
Dim myAttachment As Outlook.Attachment
Dim name As Object
Dim i, c, l As Long
Dim aa As Variant
Dim dStart As Date
Dim dEnd As Date
Dim sFilterLower As String
Dim sFilterUpper As String
Dim oOlResults As Object
Dim j As Long
Dim strEmail As String
Dim gg As String
Dim File$
Dim fsoObj As Object, TheDate As String
TheDate = Format(Date, "DD-MM-YYYY")
'TheDate = Format((Date) - 1, "MM-DD-YYYY")
Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myfolder = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myfolder = myfolder.folders("Outstation")
Set myItems = myfolder.Items
'dStart = InputBox("Enter date to filter the email subject", "Extract Outlook email attachments")
'dStart = "2018/11/08 17:00"
'dEnd = InputBox("Enter date to filter the email subject", "Extract Outlook email attachments")
'dEnd = "2018/11/08"
dEnd = TheDate
dStart = TheDate
sFilterLower = "[ReceivedTime]>'" & Format(dStart, "DDDDD HH:NN") & "'"
Set oOlResults = myfolder.Items.Restrict(sFilterLower)
Debug.Print oOlResults.Count & " items."
'create folder of today
enddir = ("\\OutlookSaveDSRAttachment\Outstation\" & TheDate & "\")
Set fsoObj = CreateObject("Scripting.FileSystemObject")
With fsoObj
If Not .FolderExists(enddir) Then
.CreateFolder (enddir)
End If
End With
Dim myfile As String
Dim ReceivedHour As Date
Dim myPath As String
Dim xExcelFile As Object
Dim xWs As Object
Dim xWb As Object
Dim xExcelApp As Object
'Outlook coding
Dim OutlookMail As Variant
If oOlResults.Count > 0 Then
oOlResults.Sort "[ReceivedTime]", True 'For Latest Updated attachment
For j = 1 To oOlResults.Count
strEmail = oOlResults(j).SenderEmailAddress
Set name = oOlResults(j)
For Each myAttachment In name.Attachments
aa = myAttachment
ReceivedHour = name.ReceivedTime
i = i + 1
myAttachment.SaveAsFile enddir & aa
myfile = enddir & aa
'myAttachment.SaveAsFile "\Desktop\Save_attachment\Out_of_station\" & aa
'myfile = "\Desktop\Save_attachment\Out_of_station\" & aa
'NewName = "\Desktop\Save_attachment\Out_of_station\" & strEmail & Format(ReceivedHour, "DD-MMM-YYYY hh mm AMPM") & ".xlsx"
NewName = enddir & strEmail & ".xls"
myPath = "\OutlookSaveDSRAttachment\Outstation\" & TheDate & "\"
'NewName = enddir & strEmail & Format(ReceivedHour, "DD-MMM-YYYY hh mm AMPM") & ".xls"
OutlookMail = NewName
On Error Resume Next
If Dir(myfile) <> "" Then
Name myfile As OutlookMail
Else
MsgBox "File not found"
End If
Next
Next j
MsgBox "Outstation Process Complete"
End If
End Sub
Comments
Post a Comment
Your advice or suggestions will be much appreciated and welcomed....