I am using a script to download my Outlook calendar in Excel format to my hard drive. Every time I use it I get a prompt saying that the file already exists as the previously downloaded file is still there.
Is there a way to suppress this prompt? I want to overwrite without having to manually click yes.
Sub calendar_download()
Dim myNameSpace As Outlook.NameSpace
Dim tdystart As Date
Dim tdyend As Date
Dim myAppointments As Outlook.Items
Dim currentAppointment As Outlook.AppointmentItem
Dim xlApp As Object
Dim xlWorkbook As Object
Dim xlWorksheet As Object
Dim i As Long
Set xlApp = CreateObject("Excel.Application")
Set xlWorkbook = xlApp.Workbooks.Add
Set xlWorksheet = xlWorkbook.Worksheets(1)
With xlWorksheet
.Cells(1, 1).Value = "Body"
.Cells(1, 2).Value = "Start"
.Cells(1, 3).Value = "End"
.Cells(1, 4).Value = "Subject"
End With
Set myNameSpace = Application.GetNamespace("MAPI")
tdystart = VBA.Format(Now, "Short Date")
tdyend = VBA.Format(Now + 1, "Short Date")
Set myAppointments = myNameSpace.GetDefaultFolder(olFolderCalendar).Items
myAppointments.Sort "[Start]"
myAppointments.IncludeRecurrences = True
Set currentAppointment = myAppointments.Find("[Start] >= """ & tdystart & """ and [Start] <= """ & tdyend & """")
i = 2
While TypeName(currentAppointment) <> "Nothing"
Debug.Print currentAppointment.Subject
xlWorksheet.Cells(i, 1).Value = currentAppointment.Body
xlWorksheet.Cells(i, 2).Value = currentAppointment.Start
xlWorksheet.Cells(i, 3).Value = currentAppointment.End
xlWorksheet.Cells(i, 4).Value = currentAppointment.Subject
i = i + 1
Set currentAppointment = myAppointments.FindNext
Wend
xlWorksheet.Columns("A:D").EntireColumn.AutoFit
xlWorkbook.SaveAs "C:\calendar\Calendardownload.xlsx" ' <------- Change this Path to the location you want to save the file to
xlWorkbook.Close
End Sub
You can delete the existing file before saving. Insert the following lines before xlWorkbook.SaveAs ...:
If Len(Dir("C:\calendar\Calendardownload.xlsx")) <> 0 Then
Kill "C:\calendar\Calendardownload.xlsx"
End If
It will first test if the file exists.
DisableAlerts, then re-enable Alerts
Application.DisplayAlerts = False
"YOUR CODE WHICH CAUSES THE ALERT"
Application.DisplayAlerts = True
Related
I created a VBA-macro to send my Outlook-calendar from my Work-account to my private Mail to import the appointments to my private calendar.
Now i realised that only the first appointment of a recurring appointment is exported.
Only if i use this configuration, all appointments are exported:
CalendarDetail = olFreeBusyOnly
Is there a way to export all appointments including the recurrences, but using "olFreeBusyAndSubject" or "olFullDetails" as setting?
I used this code:
Sub CalenderExport()
Dim ol As Outlook.Application
Dim cal As Folder
Dim exporter As CalendarSharing
Dim FirstDayInMonth, LastDayInMonth As Variant
Dim dtmDate As Date
Dim mi As MailItem
dtmDate = Date
FirstDayInMonth = DateSerial(Year(Date), Month(Date), 0)
LastDayInMonth = DateSerial(Year(Date), Month(Date) + 1, 0)
Set ol = Application
Set cal = ol.Session.GetDefaultFolder(olFolderCalendar)
Set exporter = cal.GetCalendarExporter
With exporter
.CalendarDetail = olFullDetails
.IncludeAttachments = False
.IncludePrivateDetails = False
.RestrictToWorkingHours = False
.IncludeWholeCalendar = False
.StartDate = FirstDayInMonth
.EndDate = LastDayInMonth
Set mi = .ForwardAsICal(olCalendarMailFormatEventList)
End With
With mi
.Body = "Kalenderexport"
.To = "my_mail#live.de"
.Subject = Date & " " & Time & " Calendar"
.Send
End With
End Sub
And this site for reference:
https://learn.microsoft.com/de-de/office/vba/api/outlook.calendarsharing.calendardetail
Thanks in advance
The code looks good, I don't see anything suspicious.
But to make sure that everything is exported correctly you may try to get all items for a specific date range by using the Find/FindNext or Restrict methods of the Items class. So, try to run the following code sample and then compare the results:
Sub DemoFindNext()
Dim myNameSpace As Outlook.NameSpace
Dim tdystart As Date
Dim tdyend As Date
Dim myAppointments As Outlook.Items
Dim currentAppointment As Outlook.AppointmentItem
Set myNameSpace = Application.GetNamespace("MAPI")
tdystart = VBA.Format(Now, "Short Date")
tdyend = VBA.Format(Now + 1, "Short Date")
Set myAppointments = myNameSpace.GetDefaultFolder(olFolderCalendar).Items
myAppointments.Sort "[Start]"
myAppointments.IncludeRecurrences = True
Set currentAppointment = myAppointments.Find("[Start] >= """ & _
tdystart & """ and [Start] <= """ & tdyend & """")
While TypeName(currentAppointment) <> "Nothing"
MsgBox currentAppointment.Subject
Set currentAppointment = myAppointments.FindNext
Wend
End Sub
As the title suggests, is it possible to have a script pickup all todays outlook calendar appointments and exports them into excel to a specific location
And this would happen every day automatically
This Macro gets all appoitments for the current day and writes it to an excel File:
Needs to be run from Outlook-VBA.
Sub FindAppointments()
Dim myNameSpace As Outlook.NameSpace
Dim tdystart As Date
Dim tdyend As Date
Dim myAppointments As Outlook.Items
Dim currentAppointment As Outlook.AppointmentItem
Dim xlApp As Object
Dim xlWorkbook As Object
Dim xlWorksheet As Object
Dim i As Long
Set xlApp = CreateObject("Excel.Application")
Set xlWorkbook = xlApp.Workbooks.Add
Set xlWorksheet = xlWorkbook.Worksheets(1)
With xlWorksheet
.Cells(1, 1).Value = "Subject"
.Cells(1, 2).Value = "Body"
.Cells(1, 3).Value = "Start"
.Cells(1, 4).Value = "End"
End With
Set myNameSpace = Application.GetNamespace("MAPI")
tdystart = VBA.Format(Now, "Short Date")
tdyend = VBA.Format(Now + 1, "Short Date")
Set myAppointments = myNameSpace.GetDefaultFolder(olFolderCalendar).Items
myAppointments.Sort "[Start]"
myAppointments.IncludeRecurrences = True
Set currentAppointment = myAppointments.Find("[Start] >= """ & tdystart & """ and [Start] <= """ & tdyend & """")
i = 2
While TypeName(currentAppointment) <> "Nothing"
Debug.Print currentAppointment.Subject
xlWorksheet.Cells(i, 1).Value = currentAppointment.Subject
xlWorksheet.Cells(i, 2).Value = currentAppointment.Body
xlWorksheet.Cells(i, 3).Value = currentAppointment.Start
xlWorksheet.Cells(i, 4).Value = currentAppointment.End
i = i + 1
Set currentAppointment = myAppointments.FindNext
Wend
xlWorksheet.Columns("A:D").EntireColumn.AutoFit
xlWorkbook.SaveAs "C:\temp\test.xlsx" ' <------- Change this Path to the location you want to save the file to
xlWorkbook.Close
End Sub
Yes, it is possible to develop a VBA macro where you can get all appointment for a specific date and export them to an Excel spreadsheet. But Outlook doesn't provide anything for running your script on a daily basis, the code can be run only when Outlook is launched. So, you can run your code when Outlook is launched and create a timer for any further launches. By the timer tick event you may check whether the current day data was already exported or not. You may find the Outlook VBA - Run a code every half an hour thread helpful.
To get the appointment for a specific date you need to use the Find/FindNext or Restrict methods of the Items class. You can read more about these methods in the following articles:
How To: Retrieve Outlook calendar items using Find and FindNext methods
How To: Use Restrict method in Outlook to get calendar items
I'm trying to extract information from unread e-mails in a specific folder and paste it in a structured Excel file.
I need the subject, the body, the sender, received time, conversation ID and the attachment names.
Important: it has to be an Outlook macro and not an Excel macro.
I have the following code but it is giving me
"runtime error '9': subscript out of range.
Sub WriteTextFile()
Dim wkb As Workbook
Set wkb = Workbooks.Open("C:\Users\bebxadvypat\Desktop\Test VBA Macros.xlsx")
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
Set Workbook = objExcel.Workbooks.Open("C:\Users\bebxadvypat\Desktop\Test VBA Macros.xlsx")
Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Dim row As Integer
row = 2
objExcel.Worksheets("Sheet1").Cells(1, 1).Value = "Sender"
objExcel.Worksheets("Sheet1").Cells(1, 2).Value = "Subject"
objExcel.Worksheets("Sheet1").Cells(1, 3).Value = "Date"
objExcel.Worksheets("Sheet1").Cells(1, 4).Value = "ID"
objExcel.Worksheets("Sheet1").Cells(1, 5).Value = "Body"
Set objNS = GetNamespace("MAPI")
Set objFolder = objNS.Folders.GetLast
Set objFolder = objFolder.Folders("Deleted Items")
For Each item In objFolder.Items
objExcel.Worksheets("Sheet1").Cells(row, 1).Value = item.sender
objExcel.Worksheets("Sheet1").Cells(row, 2).Value = item.Subject
objExcel.Worksheets("Sheet1").Cells(row, 3).Value = item.ReceivedTime
objExcel.Worksheets("Sheet1").Cells(row, 4).Value = item.ConversationID
objExcel.Worksheets("Sheet1").Cells(row, 5).Value = item.Body
Next
Workbook.Save
Workbook.Saved = True
Workbook.Close
objExcel.Quit
Set Workbook = Nothing
Set objExcel = Nothing
End Sub
According to test your code, you could try to add row = row+1 and use this method to get Delete Items:
Set olNs = Application.GetNamespace("MAPI")
Set DeletedFolder = olNs.GetDefaultFolder(olFolderDeletedItems)
For Each Item In objFolder.Items
objExcel.Worksheets("Sheet1").Cells(row, 1).Value = Item.Sender
objExcel.Worksheets("Sheet1").Cells(row, 2).Value = Item.Subject
objExcel.Worksheets("Sheet1").Cells(row, 3).Value = Item.ReceivedTime
objExcel.Worksheets("Sheet1").Cells(row, 4).Value = Item.ConversationID
objExcel.Worksheets("Sheet1").Cells(row, 5).Value = Item.Body
row = row + 1
Next
I have a form in ms word with some of the fields are content control and some (which are the radio buttons) are ActiveX control. I want to automatically transfer hundred word forms to an excel file. I use the following vba code:
Sub getWordFormData()
Dim wdApp As New Word.Application
Dim myDoc As Word.Document
Dim CCtl As Word.ContentControl
Dim myFolder As String, strFile As String
Dim myWkSht As Worksheet, i As Long, j As Long
myFolder = "C:\Users\alarfajal\Desktop\myform"
Application.ScreenUpdating = False
If myFolder = "" Then Exit Sub
Set myWkSht = ActiveSheet
ActiveSheet.Cells.Clear
Range("A1") = "name"
Range("a1").Font.Bold = True
Range("B1") = "age"
Range("B1").Font.Bold = True
Range("C1") = "gender"
Range("C1").Font.Bold = True
Range("D1") = "checkbox1"
Range("D1").Font.Bold = True
Range("E1") = "checkbox2"
Range("E1").Font.Bold = True
Range("F1") = "singlechoice1"
Range("F1").Font.Bold = True
Range("G1") = "singlechoice2"
Range("G1").Font.Bold = True
i = myWkSht.Cells(myWkSht.Rows.Count, 1).End(xlUp).Row
strFile = Dir(myFolder & "\*.docx", vbNormal)
While strFile <> ""
i = i + 1
Set myDoc = wdApp.Documents.Open(Filename:=myFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
With myDoc
j = 0
For Each CCtl In .ContentControls
j = j + 1
myWkSht.Cells(i, j) = CCtl.Range.Text
Next
myWkSht.Columns.AutoFit
End With
myDoc.Close SaveChanges:=False
strFile = Dir()
Wend
wdApp.Quit
Set myDoc = Nothing: Set wdApp = Nothing: Set myWkSht = Nothing
Application.ScreenUpdating = True
End Sub
all the data (text fields, checkbox) are transferred successfully but, the radio button (which is ActiveX) is not transferred.
This is the word doc:
This is the excel result:
How can I solve this problem?
You can refer to an ActiveX control on a Word document by it's name
myDoc.singlechoice1.Value
It is better to refer to the ContentControls by their tag names.
myDoc.SelectContentControlsByTag("name").Item(1).Range.Text
Refactored Code
Sub getWordFormData()
Dim wdApp As Object, myDoc As Object
Dim myFolder As String, strFile As String
Dim i As Long, j As Long
myFolder = "C:\Users\alarfajal\Desktop\myform"
If Len(Dir(myFolder)) = 0 Then
MsgBox myFolder & vbCrLf & "Not Found", vbInformation, "Cancelled - getWordFormData"
Exit Sub
End If
Application.ScreenUpdating = False
Set wdApp = CreateObject("Word.Application")
With ActiveSheet
.Cells.Clear
With .Range("A1:G1")
.Value = Array("name", "age", "gender", "checkbox1", "checkbox2", "singlechoice1", "singlechoice2")
.Font.Bold = True
End With
strFile = Dir(myFolder & "\*.docx", vbNormal)
i = 1
While strFile <> ""
i = i + 1
Set myDoc = wdApp.Documents.Open(Filename:=myFolder & "\" & strFile, ReadOnly:=True, AddToRecentFiles:=False, Visible:=False)
.Cells(i, 1).Value = myDoc.SelectContentControlsByTag("name").Item(1).Range.Text
.Cells(i, 2).Value = myDoc.SelectContentControlsByTag("age").Item(1).Range.Text
.Cells(i, 3).Value = myDoc.SelectContentControlsByTag("gender").Item(1).Range.Text
.Cells(i, 4).Value = myDoc.SelectContentControlsByTag("checkbox1").Item(1).Checked
.Cells(i, 5).Value = myDoc.SelectContentControlsByTag("checkbox2").Item(1).Checked
.Cells(i, 6).Value = myDoc.singlechoice1.Value
.Cells(i, 7).Value = myDoc.singlechoice2.Value
myDoc.Close SaveChanges:=False
strFile = Dir()
Wend
wdApp.Quit
Application.ScreenUpdating = True
End With
End Sub
Your radiobuttons are inlineshapes so you need a separate loop for them
to keep in line with your current code, it would be something like
Dim shp As InlineShape
For Each shp In .InlineShapes
j = j + 1
myWkSht.Cells(i, j) = shp.OLEFormat.Object.Value
Next shp
However I wouldn't want to rely on Word always giving me the right order and there could be other inlineshapes so it might be better to check the controls first:
With myDoc
'content controls
For Each CCtl In .ContentControls
Select Case CCtl.Title
Case "name"
myWkSht.Cells(i, 1) = CCtl.Range.Text
'similar for age and gender
Case "checkbox1"
myWkSht.Cells(i, 4) = CCtl.Checked 'true and false are easier to evaluate in Excel than the checkmark symbols
'same for checkbox 2
End Select
Next CCtl
'option buttons
For Each shp In .InlineShapes
If shp.Type = wdInlineShapeOLEControlObject Then 'skip other inlineshapes
Select Case shp.OLEFormat.Object.Name
Case "singleSelectQuestionOption1" 'name it something unique
myWkSht.Cells(i, 6) = shp.OLEFormat.Object.Value
'similar for option button 2
End Select
End If
Next shp
End With
I have the below code that I am trying to modify to split a subject line into to six columns to view in Excel.
Sub subject2excel()
On Error Resume Next
Set myOlApp = Outlook.Application
Set mynamespace = myOlApp.GetNamespace("mapi")
Set myfolder = myOlApp.ActiveExplorer.CurrentFolder
Set xlobj = CreateObject("excel.application.14")
xlobj.Visible = True
xlobj.Workbooks.Add
'Set Heading
xlobj.Range("a" & 1).Value = "From"
xlobj.Range("b" & 1).Value = "Subject"
For i = 1 To myfolder.Items.Count
Set myitem = myfolder.Items(i)
msgtext = myitem.Body
xlobj.Range("a" & i + 1).Value = myitem.Sender
xlobj.Range("b" & i + 1).Value = myitem.Subject
Next
End Sub
My data is in the below format
SLWP Moncton | Cable Service Eng. | 21-Jul-15 | Shift End: 0:00 | Leave Time: entire day | SLWP (Unpaid)
So in total 7 columns I plan to leave is below.
Sender
Location
LOB
Date
Shift End Time
Shift Leave Time
Leave Type
In it's current state as you can see it only produces two columns and I do not know how to break the subject line apart.
Any help will be most appreciated.
Thanks
Use Split.
Sub subject2excel()
Dim myOlApp As Outlook.Application
Dim myFolder As folder
Dim xlobj As Object
Dim i As Long
Dim j As Long
Dim myitem As Object
Dim Words() As String
'On Error Resume Next
Set myOlApp = Outlook.Application
'Set myNameSpace = myOlApp.GetNamespace("mapi")
Set myFolder = myOlApp.ActiveExplorer.currentFolder
Set xlobj = CreateObject("excel.application.14")
xlobj.Visible = True
xlobj.Workbooks.Add
'Set Heading
xlobj.Range("a" & 1).Value = "From"
xlobj.Range("b" & 1).Value = "Subject"
For i = 1 To myFolder.Items.count
Set myitem = myFolder.Items(i)
If TypeOf myitem Is MailItem Then
'msgText = myitem.body
xlobj.Range("a" & i + 1).Value = myitem.Sender
'xlobj.Range("b" & i + 1).Value = myitem.Subject
Words = Split(myitem.Subject, " | ")
For j = 0 To UBound(Words)
Debug.Print Words(j)
Next j
End If
Next i
exitRoutine:
Set myOlApp = Nothing
Set myFolder = Nothing
Set xlobj = Nothing
Set myitem = Nothing
End Sub
I was able to solve the issue
Sub subject2excel()
Dim olFolder As Outlook.Folder
Dim olItem As Outlook.MailItem
Dim olNS As Outlook.NameSpace
Dim xlApp As Object
Dim xlWB As Object
Dim i As Long
Dim j As Long
Dim vSubject As Variant
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Set xlApp = CreateObject("Excel.Application")
End If
On Error GoTo 0 'err_Handler
xlApp.Visible = True
Set xlWB = xlApp.Workbooks.Add
'Set Heading
With xlWB.Sheets(1)
.Range("A" & 1).Value = "Sender"
.Range("B" & 1).Value = "Location"
.Range("C" & 1).Value = "LOB"
.Range("D" & 1).Value = "Date"
.Range("E" & 1).Value = "Shift End Time"
.Range("F" & 1).Value = "Requested Leave Time"
.Range("G" & 1).Value = "Paid/Unpaid"
End With
'Fill sheet
Set olNS = GetNamespace("MAPI")
Set olFolder = olNS.PickFolder
For i = 1 To olFolder.Items.Count
Set olItem = olFolder.Items(i)
If InStr(1, olItem.Subject, "|") > 0 Then
vSubject = Split(olItem.Subject, "|")
With xlWB.Sheets(1)
.Range("A" & i + 1).Value = olItem.Sender
.Range("B" & i + 1).Value = vSubject(0)
.Range("C" & i + 1).Value = vSubject(1)
.Range("D" & i + 1).Value = vSubject(2)
.Range("E" & i + 1).Value = Trim(Mid(vSubject(3), InStr(1, vSubject(3), Chr(58)) + 1))
.Range("F" & i + 1).Value = Trim(Mid(vSubject(4), InStr(1, vSubject(4), Chr(58)) + 1))
.Range("F" & i + 1).HorizontalAlignment = -4152 'align right
.Range("G" & i + 1).Value = Replace(Trim(Mid(vSubject(5), InStrRev(vSubject(5), Chr(40)) + 1)), Chr(41), "")
End With
End If
Next i
xlWB.Sheets(1).UsedRange.Columns.Autofit
exitRoutine:
Set olFolder = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
Set olItem = Nothing
lbl_Exit:
Exit Sub
err_Handler:
GoTo lbl_Exit
End Sub