auto_mach
07-16-2015, 11:27 AM
Hey, all!
I was hoping I could alter my macro to save data to a spreadsheet directly. Below is the macro I have already, where it simply display's a message box with the count. I'd like to save that on a specific cell in a specific sheet that would be open at the time.
This is for a task that has to be ran multiple times a day and the excel workbook will have a different name every time, but the sheet and cell position are always the same.
I've been trying for a while, but I can't get it to run in either Excel or Outlook. This was the original VB script.
Sub WNL()
Dim objOutlook As Object, objnSpace As Object, objFolder As MAPIFolder
Dim EmailCount As Integer, CompCount As Integer, totCount As Integer
Dim strFolder As String
Dim olMailItem As Outlook.MailItem
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
CompCount = 0
On Error Resume Next
Set objFolder = Application.GetNamespace("MAPI").Folders("WNL").Folders("Inbox")
If Err.Number <> 0 Then
Err.Clear
MsgBox "No such folder."
Exit Sub
End If
strFolder = objFolder.Parent
EmailCount = objFolder.Items.Count
For Each olMailItem In objFolder.Items
If olMailItem.TaskCompletedDate = "1/1/4501" Then
GoTo Line1
Else
CompCount = CompCount + 1
End If
Line1:
Next olMailItem
totCount = (EmailCount - CompCount)
MsgBox "Number of emails in " & strFolder & ": " & totCount, , "email count"
Dim dateStr As String
Dim myItems As Outlook.Items
Dim dict As Object
Dim msg As String
Set dict = CreateObject("Scripting.Dictionary")
Set myItems = objFolder.Items
myItems.SetColumns ("ReceivedTime")
' Determine date of each message:
For Each myItem In myItems
dateStr = GetDate(myItem.ReceivedTime)
If Not dict.Exists(dateStr) Then
dict(dateStr) = 0
End If
dict(dateStr) = CLng(dict(dateStr)) + 1
Next myItem
' Output counts per day:
msg = ""
For Each o In dict.Keys
msg = msg & o & ": " & dict(o) & " items" & vbCrLf
Next
Dim fso As Object
Dim fo As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set fo = fso.CreateTextFile("Z:\WNL.txt")
fo.Write msg
fo.Close
Set fo = Nothing
Set fso = Nothing
Set objFolder = Nothing
Set objnSpace = Nothing
Set objOutlook = Nothing
End Sub
Function GetDate(dt As Date) As String
GetDate = Year(dt) & "-" & Month(dt) & "-" & Day(dt)
End Function
:thumb
I was hoping I could alter my macro to save data to a spreadsheet directly. Below is the macro I have already, where it simply display's a message box with the count. I'd like to save that on a specific cell in a specific sheet that would be open at the time.
This is for a task that has to be ran multiple times a day and the excel workbook will have a different name every time, but the sheet and cell position are always the same.
I've been trying for a while, but I can't get it to run in either Excel or Outlook. This was the original VB script.
Sub WNL()
Dim objOutlook As Object, objnSpace As Object, objFolder As MAPIFolder
Dim EmailCount As Integer, CompCount As Integer, totCount As Integer
Dim strFolder As String
Dim olMailItem As Outlook.MailItem
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
CompCount = 0
On Error Resume Next
Set objFolder = Application.GetNamespace("MAPI").Folders("WNL").Folders("Inbox")
If Err.Number <> 0 Then
Err.Clear
MsgBox "No such folder."
Exit Sub
End If
strFolder = objFolder.Parent
EmailCount = objFolder.Items.Count
For Each olMailItem In objFolder.Items
If olMailItem.TaskCompletedDate = "1/1/4501" Then
GoTo Line1
Else
CompCount = CompCount + 1
End If
Line1:
Next olMailItem
totCount = (EmailCount - CompCount)
MsgBox "Number of emails in " & strFolder & ": " & totCount, , "email count"
Dim dateStr As String
Dim myItems As Outlook.Items
Dim dict As Object
Dim msg As String
Set dict = CreateObject("Scripting.Dictionary")
Set myItems = objFolder.Items
myItems.SetColumns ("ReceivedTime")
' Determine date of each message:
For Each myItem In myItems
dateStr = GetDate(myItem.ReceivedTime)
If Not dict.Exists(dateStr) Then
dict(dateStr) = 0
End If
dict(dateStr) = CLng(dict(dateStr)) + 1
Next myItem
' Output counts per day:
msg = ""
For Each o In dict.Keys
msg = msg & o & ": " & dict(o) & " items" & vbCrLf
Next
Dim fso As Object
Dim fo As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set fo = fso.CreateTextFile("Z:\WNL.txt")
fo.Write msg
fo.Close
Set fo = Nothing
Set fso = Nothing
Set objFolder = Nothing
Set objnSpace = Nothing
Set objOutlook = Nothing
End Sub
Function GetDate(dt As Date) As String
GetDate = Year(dt) & "-" & Month(dt) & "-" & Day(dt)
End Function
:thumb