I want to display Outlook Calendar appointments from a given date in a MessageBox. Unfortunately the code I am using does not show any appointments for today. If i change my code to
sfilter = "[Start] >= '" & startDate & "' "
then i get todays appointments with all future appointments for other dates. I want to only show appointments for the specified date.
The date selection is from a UserForm called cmDates.srtDate.Value
sFilter is the variable I am using the hold the date filter throughout the code
Code
Public Function getOutlookAppointments() As String
Dim oOutlook As Object
Dim oNS As Object
Dim oAppointments As Object
Dim oFilterAppointments As Object
Dim oAppointmentItem As Object
Dim bOutlookOpened As Boolean
' Dim rslt As String
Dim sfilter As String
Dim startDate As Date
Dim displayText As String
Dim start As Date
Const olFolderCalendar = 9
On Error Resume Next
Set oOutlook = GetObject(, "Outlook.Application") 'Bind to existing instance of Outlook
If Err.Number <> 0 Then 'Could not get instance of Outlook, so create a new one
Err.Clear
Set oOutlook = CreateObject("Outlook.Application")
bOutlookOpened = False 'Outlook was not already running, we had to start it
Else
bOutlookOpened = True 'Outlook was already running
End If
On Error GoTo Error_Handler
DoEvents
Set oNS = oOutlook.GetNamespace("MAPI")
Set oAppointments = oNS.GetDefaultFolder(olFolderCalendar)
startDate = cmDates.srtDate.value
'Apply a filter so we don't waste our time going through old stuff if we don't need to.
sfilter = "[Start] = '" & startDate & "' "
Set oFilterAppointments = oAppointments.Items.Restrict(sfilter)
For Each oAppointmentItem In oFilterAppointments
getOutlookAppointments = getOutlookAppointments & oFilterAppointments.Count & " appointment(s) found" & vbCrLf & vbCrLf & oAppointmentItem.Subject & vbCrLf & oAppointmentItem.start & vbCrLf & oAppointmentItem.End & vbCrLf & vbCrLf
'displayText = displayText & oAppointmentItem.Subject
Next
MsgBox prompt:=getOutlookAppointments, _
Title:="Appointments for"
If bOutlookOpened = False Then 'Since we started Outlook, we should close it now that we're done
oOutlook.Quit 'There seems to be a delay in this action taking place, but does eventually take place
End If
Error_Handler_Exit:
On Error Resume Next
Set oAppointmentItem = Nothing
Set oFilterAppointments = Nothing
Set oAppointments = Nothing
Set oNS = Nothing
Set oOutlook = Nothing
Exit Function
Error_Handler:
MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: GetFutureOutlookEvents" & vbCrLf & _
"Error Description: " & Err.Description _
, vbOKOnly + vbCritical, "An Error has Occured!"
Resume Error_Handler_Exit
outlookDates = False
End Function
Your restriction should have two parts - Start > today's midnight, and Start < tomorrow's midnight. You only have the first part.
Also keep in mind that if you want instances of the recurring activities (and not just the master appointments), you need to use the Items.IncludeRecurrences property - see https://learn.microsoft.com/en-us/office/vba/api/outlook.items.includerecurrences
There are several aspects:
To retrieve all Outlook appointment items from the folder that meets the predefined condition, you need to sort the items in ascending order and set the IncludeRecurrences to true. You will not catch recurrent appointments if you don’t do this before using the Restrict method!
Microsoft doesn’t recommend using the Count property in case you set the IncludeRecurrences property. The Count property may return unexpected results and cause an infinite loop.
Although dates and times are typically stored with a Date format, the Find and Restrict methods require that the date and time be converted to a string representation. To make sure that the date is formatted as Microsoft Outlook expects, use the Format function available in VBA. So, you must specify the date in the format which Outlook understand.
Format(youDate, "ddddd h:nn AMPM")
For example, here is a sample VB.NET code:
Imports System.Text
Imports System.Diagnostics
' ...
Private Sub RestrictCalendarItems(folder As Outlook.MAPIFolder)
Dim dtEnd As DateTime = New DateTime(DateTime.Now.Year, DateTime.Now.Month, _
DateTime.Now.Day, 23, 59, 0, 0)
Dim restrictCriteria As String = "[Start]<=""" + dtEnd.ToString("g") + """" + _
" AND [End]>=""" + DateTime.Now.ToString("g") + """"
Dim strBuilder As StringBuilder = Nothing
Dim folderItems As Outlook.Items = Nothing
Dim resultItems As Outlook.Items = Nothing
Dim appItem As Outlook._AppointmentItem = Nothing
Dim counter As Integer = 0
Dim item As Object = Nothing
Try
strBuilder = New StringBuilder()
folderItems = folder.Items
folderItems.IncludeRecurrences = True
folderItems.Sort("[Start]")
resultItems = folderItems.Restrict(restrictCriteria)
item = resultItems.GetFirst()
Do
If Not IsNothing(item) Then
If (TypeOf (item) Is Outlook._AppointmentItem) Then
counter = counter + 1
appItem = item
strBuilder.AppendLine("#" + counter.ToString() + _
" Start: " + appItem.Start.ToString() + _
" Subject: " + appItem.Subject + _
" Location: " + appItem.Location)
End If
Marshal.ReleaseComObject(item)
item = resultItems.GetNext()
End If
Loop Until IsNothing(item)
If (strBuilder.Length > 0) Then
Debug.WriteLine(strBuilder.ToString())
Else
Debug.WriteLine("There is no match in the " _
+ folder.Name + " folder.")
End If
catch ex As Exception
System.Windows.Forms.MessageBox.Show(ex.Message)
Finally
If Not IsNothing(folderItems) Then Marshal.ReleaseComObject(folderItems)
If Not IsNothing(resultItems) Then Marshal.ReleaseComObject(resultItems)
End Try
End Sub
You may find the following articles helpful:
How To: Use Restrict method in Outlook to get calendar items
How To: Retrieve Outlook calendar items using Find and FindNext methods
Related
I'm trying to import all data from 3 columns in an access database (.mdb) into my Excel file, which is working, however the numbers that I'm importing aren't coming in correct. You can see in the images supplied what exactly is happening. I am wanting it to import exactly as it is in the database (to 1 decimal place). Now I've tried with changing the numberformat for the Excel columns but of course that only hides the true value with a shortened version so I'd like to avoid doing that.
Dealing with SQL in VBA is something new to me and I don't know Access very well either so I'm wondering if there is something I can add to the query that could affect why the numbers are changing when they get copied into my Excel sheet.
I'm going to be adding a lot more to the code later but just testing connection for now to get it working properly first.
Here is my code (Got the basis for it from a youtube video I found):
Sub GetDataFromAccess()
Application.screenupdating = False
On Error GoTo SubError
Dim db As DAO.Database, rs As DAO.Recordset, xlSheet As Worksheet, recCount As Long, SQL As String, _
TableName As String, FldrLoc As String, FileName As String, ImpSh As Worksheet
Set ImpSh = Sheets("Import")
FldrLoc = ImpSh.Range("D10").Value
FileName = ImpSh.Range("Q15").Value
If Right(FldrLoc, 1) = "\" Then
DbLoc = FldrLoc & FileName
Else
DbLoc = FldrLoc & "\" & FileName
End If
Set xlSheet = Sheets("CAL-53 INC")
If InStr(ImpSh.Range("Q15").Value, ".mdb") > 0 Then
TableName = ImpSh.Range("R5").Value & Left(ImpSh.Range("Q15").Value, Len(ImpSh.Range("Q15")) - 4)
Else
TableName = ImpSh.Range("R5").Value & ImpSh.Range("Q15").Value
End If
xlSheet.Range("G3:I5000").ClearContents
Application.StatusBar = "Connecting to the database..."
Application.Cursor = xlWait
Set db = OpenDatabase(DbLoc)
SQL = "SELECT LRP_CHAINAGE, LEFT_DEPTH, RIGHT_DEPTH" & _
" FROM " & TableName & " ORDER BY LRP_CHAINAGE "
Set rs = db.OpenRecordset(SQL, dbOpenSnapshot)
Application.StatusBar = "Writing to spreadsheet..."
If rs.RecordCount = 0 Then
MsgBox "No data from that table"
GoTo SubExit
Else
rs.MoveLast
recCount = rs.RecordCount
rs.MoveFirst
End If
xlSheet.Range("G3").CopyFromRecordset rs
'xlSheet.Range("G:I").NumberFormat = "0.0"
Application.StatusBar = "Update complete."
SubExit:
On Error Resume Next
Application.Cursor = xlDefault
rs.Close
Set rs = Nothing
Set xlSheet = Nothing
Application.screenupdating = True
Exit Sub
SubError:
Application.StatusBar = ""
MsgBox "Error: " & vbCrLf & Err.Number & " = " & Err.Description
Resume SubExit
End Sub
Here are the pictures of what is in the database and what it's coming in as:
As a quick work around you may set the SQL statement as follows:
SQL = "SELECT Fix(10*[" & TableName & "]![LRP_CHAINAGE])/10 AS LRP_CHAINAGE, Fix(10*[" & TableName & "]![LEFT_DEPTH])/10 AS LEFT_DEPTH, Fix(10*[" & TableName & "]![RIGHT_DEPTH])/10 AS RIGHT_DEPTH" & _
" FROM " & TableName & " ORDER BY LRP_CHAINAGE "
This will give you only one digit after decimal. If you need two digits just change multiplier and divider to 100 :)
SQL = "SELECT LRP_CHAINAGE*10, LEFT_DEPTH*10, RIGHT_DEPTH*10" & _
" FROM " & TableName & " ORDER BY LRP_CHAINAGE "
I'm not running access or windows, but I remember I've done something like this with sql server and excel since vba truncate decimal values
After this query, you can use an update query on the worksheet
UPDATE [IMPORT$]
SET LRP_CHAINAGE=LRP_CHAINAGE/10, LEFT_DEPTH/10, RIGHT_DEPTH/10
The code when run manually (right click and run) it works perfectly, but the issue arises when it is automated using schedule.
When automated the code runs fine but right at the end of running the code it fails with the above error message.
The code looks fine, variables are set as they should and the code runs fine when done manually.
Sub processJobs(dbCurrent As NotesDatabase)
Dim vwLookup As NotesView
Dim docReq As NotesDocument
Dim dtMonthAgo As New NotesDateTime(Today)
Dim dtDelDate As NotesDateTime
Dim itmDelDate As NotesItem
Dim sender As NotesName
Dim receiver As NotesName
Dim nmServer As NotesName
Dim lngNoOfDays As Long
Dim mail As Email
Dim intCount As Integer
Dim intCountFailed As Integer
Dim strSendTo As String
On Error GoTo ErrorHandler
On Error 4000 GoTo RecipientNameBlank
On Error 4294 GoTo RecipientNotInNAB
Call AgentLog.LogAction("--------- Process Job ---------")
Call dtMonthAgo.AdjustMonth( -1 ) ' set the dtMonthAgo date to one month ago
Call dtMonthAgo.Setanytime() ' remove the time component from the date
Set vwLookup = dbCurrent.Getview("JobView")
vwLookup.Autoupdate = False
Set docReq = vwLookup.Getfirstdocument()
intCount = 0
intCountFailed = 0
Do Until docReq Is Nothing
Set itmDelDate = docReq.GetFirstItem("DeliveryDate")
If itmDelDate.Type = 1024 Then
Set dtDelDate = itmDelDate.DateTimeValue
Call dtDelDate.SetAnyTime
If dtMonthAgo.TimeDifference(dtDelDate) > 0 Then
intCount = intCount + 1
Set mail = New Email ' send email...
mail.Subject = "Processed Job"
mail.HTML = getCompletionHTML(docReq, mail.WebURL)
Set sender = New NotesName(docReq.JobBy(0))
Set receiver = New NotesName(docReq.DespatchTo(0))
Set nmServer = New NotesName(dbCurrent.Server)
If receiver.Organization = nmServer.Organization Then
strSendTo = receiver.Abbreviated
' send a copy to..
If sender.Abbreviated <> receiver.Abbreviated Then
mail.CopyTo = docReq.JobBy(0)
End If
Else
strSendTo = sender.Abbreviated
End If
mail.Send(strSendTo)
Call agentLog.LogAction(strSendTo & " - Job No: " & docReq.JobNo(0))
flagDoc:
' flag the job...
Call docReq.Replaceitemvalue("CompletionJob", "Y")
Call docReq.Replaceitemvalue("CompletionJobDate", Now)
Call docReq.Save(True, False)
End If
End If
Set docReq = vwLookup.Getnextdocument(docReq)
Loop
Call AgentLog.LogAction("")
Call AgentLog.LogAction("Attempted to send " & CStr(intCount) & " Job")
Call AgentLog.LogAction("Failed to send " & CStr(intCountFailed) & " Job")
Call AgentLog.LogAction("--------- End of job process ---------")
ErrorHandler:
If Not AgentLog Is Nothing Then
Call AgentLog.LogError(Err, "errorHandler: " & CStr(Err) & " " & Error$ & " in " & LSI_Info(2))
End If
Resume getOut
23/05/2019 00:00:05 errorHandler: 91 Object variable not set in PROCESSJOBS(Object variable not set)
The agent was supposed to loop through the view, get names of recipients, set the variables and then send the email automatically.
By automation, it does loop through the view and get/set names of recipient but fails straight after getting the last name that the object variable is not set.
Running the code manually does not pose any problem at all, but this code needs to be run automatically.
In your ErrorHandler, log (or print) the line where the error occured.
ErrHandler:
Print "Got error " & Error$ & " on line " & cstr(Erl)
example copied from IBM
You need an Exit Sub statement to prevent your code from falling through into your error handler.
Call AgentLog.LogAction("")
Call AgentLog.LogAction("Attempted to send " & CStr(intCount) & " Job")
Call AgentLog.LogAction("Failed to send " & CStr(intCountFailed) & " Job")
Call AgentLog.LogAction("--------- End of job process ---------")
Exit Sub ' **** You need this
ErrorHandler:
If Not AgentLog Is Nothing Then
Call AgentLog.LogError(Err, "errorHandler: " & CStr(Err) & " " & Error$ & " in " & LSI_Info(2))
End If
Resume getOut
You also don't appear to be initializing AgentLog, though that might be a global.Is it successfully writing those lines to the agent log when you run it scheduled? If not, perhaps there's a problem with accessing the agent log database on the server where it is scheduled.
I wanted to extract list of defects using a filter criteria. I tried the VBA code from OTA here, but compile fails on the following declarations with User defined type not defined:
Dim BugFact As BugFactory
Dim BugFilter As TDFilter
Dim bugList As List
Dim theBug As Bug
Note: I do not have administrative privileges on ALM.
The full VBA code:
Sub BugFilter()
Dim BugFact As BugFactory
Dim BugFilter As TDFilter
Dim bugList As List
Dim theBug As Bug
Dim i%, msg$
' Get the bug factory filter.
'tdc is the global TDConnection object.
Set BugFact = tdc.BugFactory
Set BugFilter = BugFact.Filter
' Set the filter values.
BugFilter.Filter("BG_STATUS") = "Closed"
BugFilter.order("BG_PRIORITY") = 1
MsgBox BugFilter.Text
'Create a list of defects from the filter
' and show a few of them.
Set bugList = BugFilter.NewList
msg = "Number of defects = " & bugList.Count & Chr(13)
For Each theBug In bugList
msg = msg & theBug.ID & ", " & theBug.Summary & ", " _
& theBug.Status & ", " & theBug.Priority & Chr(13)
i = i + 1
If i > 10 Then Exit For
Next
MsgBox msg
End Sub
You need to add a reference to the OTA COM Type library (see here); otherwise your program will not know about the OTA types such as BugFactory and TDFilter.
I want to open an attachment from Lotus Notes with VBA.
The Problem is that I don't get the path out of Lotus Notes.
I would be very thankful if you can give me a code, with how I can open this path without hardcoding it.
Here is the complete Code which does not work...
Function OpenURL(URL As String, WindowState As W32_Window_State) As Boolean
'Opens passed URL with default application, or Error Code (<32) upon error
Dim lngHWnd As Long
Dim lngReturn As Long
lngReturn = ShellExecute(lngHWnd, "open", URL, vbNullString, _
vbNullString, WindowState)
OpenURL = (lngReturn > 32)
End Function
Sub OpenLotusNotes()
Dim objNotesSession As Object
Dim objNotesFile As Object
Dim objNotesDocument As Object
Dim objNotesField As Object
Dim objNotesUIWorkSpace As Object
Dim objNotesView As Object
Set objNotesSession = CreateObject("Notes.NotesSession")
Set objNotesFile = objNotesSession.GETDATABASE("ATLAS40", "ACITF\PRODUCTION\USN\ePayable.nsf")
'("Server", "Datenbank")
Set objNotesUIWorkSpace = CreateObject("Notes.NotesUIWorkSpace")
Set i = Sheet1.Range("B20")
Dim DocNum As Variant
Dim DocName As Variant
Set objNotesView = objNotesFile.GetView("1.CheckView")
Set objNotesDocument = objNotesView.GetFirstDocument
Dim body As Variant
Dim ms As String
ms = ""
If Not objNotesDocument Is Nothing Then
'initial set
DocNum = objNotesDocument.InvoiceNumber
DocName = objNotesDocument.InvoiceDocumentNumber
Dim DocFound As Boolean
DocFound = False
While Not DocFound = True
DocNum = objNotesDocument.InvoiceNumber
DocName = objNotesDocument.InvoiceDocumentNumber
If DocNum(0) = i Then
ms = "You are about to open the attachement located in " & DocNum(0) & " " & DocName(0) & " in The Way we do things database from Database Server " & objNotesFile.server & " with Database File name " & objNotesFile.Filename & "."
MsgBox (ms)
DocFound = True
Set body = objNotesDocument.getfirstitem("$FILE")
'subject der mail ermitteln
For Each obj In body.embeddedobjects
'MsgBox (Environ("TEMP") & "\" & obj.Name)
'MsgBox (obj.Name)
Call obj.ExtractFile(Environ("TEMP") & "\" & obj.Name)
OpenURL "file://" & Environ("TEMP") & "\" & obj.Name, Show_Maximized
Next
End If
Set objNotesDocument = objNotesView.GetNextDocument(objNotesDocument)
Wend
End If
You can't open the file by accessing the $File item, so even if you had the correct syntax (using GetFirstItem("$File)) it would still not work.
You need to use objNotesDocument.EmbeddedObjects() This will return an array of NotesEmbeddedObject objects. If there's only one file attachment in the document, there will be only one element in the array. You can use the ExtractFile method of the NotesEmbeddedObject class to save a copy of the file to the filesystem, and you can open it from there.
I'm trying to import relevant information from Excel report which is not specifically designed to import data. Basically it is formatted report with other information. Please see the attached image to get an idea. This is huge report and contains hundreds of rows.
I'm thinking to import data by reading Excel file reading line by line, based on the information on that particular row and then inserting that row into Access table.
I've attached simplified version of report to give you an idea about the report layout and also Access table structure, the information I want to store in table DailyTranaction.
Example Report Image here:
Access Table Structure Image here:
I'm not sure the best way to do the above task using Access VBA, a working simple example will be highly appreciated.
Insert new code module then copy and paste below code:
Option Compare Database
Option Explicit
Public Function GetDataFromReport(ByVal sRepFileName As String) As Integer
Dim xlApp As Object, xlWbk As Object, xlWsh As Object
Dim retVal As Integer, sRepDate As String, r As Integer, sBranch As String, sQry As String, rs As Integer
On Error GoTo Err_GetDataFromReport
DoCmd.SetWarnings False
Set xlApp = CreateObject("Excel.Application")
Set xlWbk = xlApp.Workbooks.Open(sRepFileName)
Set xlWsh = xlWbk.Worksheets(1) 'or pass the name, ex: "Sheet1"
sRepDate = xlWsh.Range("A1")
r = InStr(1, sRepDate, "th")
sRepDate = Replace(sRepDate, Left(sRepDate, InStr(r - 3, sRepDate, " ")), "")
sRepDate = Replace(sRepDate, "th", "")
'find the last row;
rs = xlWsh.Range("A" & xlWsh.Rows.Count).End(-4162).Row
r = 3
Do While r <= rs
Select Case UCase(Trim(xlWsh.Range("A" & r)))
Case "", UCase("CustId")
'skip empty row and header of data
GoTo SkipRow
Case UCase("Branch:")
sBranch = xlWsh.Range("B" & r)
Case Else
'proceed if the value is numeric
If Not IsNumeric(xlWsh.Range("A" & r)) Then GoTo SkipRow
sQry = "INSERT INTO Reports([ReportDate],[BranchCode],[CustId],[AccountNo],[Transaction])" & vbCr & _
"VALUES(#" & sRepDate & "#," & sBranch & ", " & xlWsh.Range("A" & r) & _
", " & xlWsh.Range("B" & r) & ", " & xlWsh.Range("C" & r) & ")"
'Debug.Print sQry
DoCmd.RunSQL sQry
'get the number of rows affected ;)
retVal = retVal +1
End Select
SkipRow:
r = r + 1
Loop
Exit_GetDataFromReport:
On Error Resume Next
DoCmd.SetWarnings True
Set xlWsh = Nothing
xlWbk.Close SaveChanges:=False
Set xlWbk = Nothing
xlApp.Quit
Set xlApp = Nothing
'return value
GetDataFromReport = retVal
Exit Function
Err_GetDataFromReport:
MsgBox Err.Description, vbExclamation, Err.Number
Resume Exit_GetDataFromReport
End Function
To use this, you need to create macro, which action should refer to above function:
GetDataFromReport ("C:\report.xls")
As you can see, you need to define full path to the source workbook.
Alternativelly, you can run above code by creating procedure:
Sub Test()
MsgBox GetDataFromReport("D:\Report Daily Transaction.xls") & " records have been imported!", vbInformation, "Message..."
End Sub
Alternativelly, you can create macro which open form. Sample database and report
Good luck!