I'm trying to update document properties and create new entries if they don't exist
However
this type of thing does not work
Set objDocProps = DSO.GetDocumentProperties(sfilename:=FileName)
With objDocProps
If .CustomProperties("ABC") Is Nothing Then
'create it here
and if I put an error handler in there
it barfs as either being locked or having lost connection
errhandler:
Select Case Err.Number
Case -2147220987 ' missing custom property
Debug.Print "missing custom property"
With objDocProps
.CustomProperties("ABC").Value = "banana!"
Could you use the CustomDocumentProperties collection for the appropriate Excel workbook instead? You could then just iterate through the collection and edit the property if you find it. If it is not present you could then create the property
There appear to be issues when trying to access CustomProperties by name.
The solution I have implemented is to iterate the CustomPropery collection to determine the index of the item (if it exists), then use this to set the value (or add a new one if it does not)
Pass in: your custom properties object, the entry you wish to populate and the value you wish to populate it with
Sub UpsertEntry(objCustomProps, entryname, entryvalue)
'update the custom property with value supplied
On Error Resume Next
Dim icount
Dim iindex
For icount = 1 To objCustomProps.Count
If objCustomProps.Item(icount).name = entryname Then
iindex = icount
Exit For
Else
iindex = 0
End If
Next
If iindex = 0 Then 'no custom property found
objCustomProps.Add entryname, entryvalue
Wscript.Echo " Adding [" & entryname & ":" & entryvalue & "]"
Else
objCustomProps.Item(iindex).Value = entryvalue
Wscript.Echo " Changing [" & entryname & ":" & entryvalue & "]"
End If
On Error GoTo 0
End Sub
Related
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
I have an excel workbook with modeless form. The way it's setup is that: each sheet in the workbook has a tab in the form. Each field in these tabs is Linked to a cell in corresponding sheet. So when a value is changed/updated in the form, it is automatically updated in the relevant cell. The way I am doing this is by using the onChange event for each filed which call's a UDF that does the updating. My question, there are a lot of fields in the form and lots more to be added. Is there a way to update relevant cell when a field in the form is selected without having to add the call to a UDF in onChange event for each field?
I have tried using things like ControlSource but that only one way where it just updates the value in the form but doesn't update the value in the cell when form is updated.
As a side note, unfortunately I cannot share the form or the sheet but am willing to answer any questions
EDIT
Below is the function that updates the field:
Sub UpdateWorksheetValue(ByVal oObj As Object)
Dim oWS As Worksheet
Dim sCurrentValue As String
Dim iC As Long
' Lets check if tag is set
If Len(Trim(oObj.Tag)) = 0 Then
MsgBox "Empty tag found for '" & oObj.Name & "' field. Failed to update field value" & vbCrLf & vbCrLf & "Please contact system administrator with this information", vbCritical + vbOKOnly, "Update Failed"
Exit Sub
ElseIf Len(Trim(Mid(oObj.Tag, InStr(1, oObj.Tag, "¬") + 1))) = 0 Then
MsgBox "Tag for '" & oObj.Name & "' field does not include page title. Failed to update field value" & vbCrLf & vbCrLf & "Please contact system administrator with this information", vbCritical + vbOKOnly, "Update Failed"
Exit Sub
End If
' Set worksheet
Select Case LCase(Trim(Mid(oObj.Tag, InStr(1, oObj.Tag, "¬") + 1)))
Case "client identification"
Set oWS = oWB.Worksheets("Client Identification - Output")
Case "request details"
Set oWS = oWB.Worksheets("Request Details - Output")
Case "db responsible individuals"
Set oWS = oWB.Worksheets("DB Responsible Ind - Output")
Case "additional details"
Set oWS = oWB.Worksheets("Additional Details - Output")
End Select
' Set value
With oWS
' Lets check if tag is set
If Len(Trim(Mid(oObj.Tag, 1, InStr(1, oObj.Tag, "¬") - 1))) = 0 Then
MsgBox "Tag for '" & oObj.Name & "' field does not include corresponding cell information. Failed to update field value in '" & oWS.Name & "' worksheet" & vbCrLf & vbCrLf & "Please contact system administrator with this information", vbCritical + vbOKOnly, "Update Failed"
Exit Sub
End If
' Set the search value
.Range("Z1").Value = Mid(oObj.Tag, 1, InStr(1, oObj.Tag, "¬") - 1)
DoEvents
' If a row with tag text is not found, throw a message and exit sub
If Len(Trim(.Range("Z2").Value)) = 0 Then
MsgBox "Unable to find corresponding cell for '" & oObj.Name & "' field in '" & .Name & "' worksheet. Failed to update field value" & vbCrLf & vbCrLf & "Please ensure that the field's 'Tag' matches a cell in the sheet or contact system administrator", vbCritical + vbOKOnly, "Update Failed"
Exit Sub
End If
' Set field value
Select Case LCase(TypeName(oObj))
Case "textbox", "combobox"
.Range("B" & .Range("Z2").Value).Value = oObj.Value
Case "optionbutton"
If oObj.Value = True Then
.Range("B" & .Range("Z2").Value).Value = oObj.Caption
Else
.Range("B" & .Range("Z2").Value).Value = ""
End If
Case "listbox"
' First lets the current cell value
sCurrentValue = .Range("B" & .Range("Z2").Value).Value
' Now lets build the string for the cell
For iC = 0 To oObj.ListCount - 1
If oObj.Selected(iC) And InStr(1, sCurrentValue, oObj.List(iC)) = 0 Then
sCurrentValue = sCurrentValue & "/" & oObj.List(iC)
ElseIf Not oObj.Selected(iC) And InStr(1, sCurrentValue, oObj.List(iC)) > 0 Then
sCurrentValue = Replace(sCurrentValue, "/" & oObj.List(iC), "")
End If
Next
' And finally, set the value
.Range("B" & .Range("Z2").Value).Value = sCurrentValue
End Select
End With
' Clear object
Set oWS = Nothing
End Sub
EDIT 2
I now have a class called formEventClass as suggested by David. Contents of the class are:
Option Explicit
Public WithEvents tb As MSForms.TextBox
Private Sub tb_Change()
UpdateWorksheetValue (tb)
End Sub
But when I make a change in any given text box, cells are not updated (as per David's suggestion, I've removed the call to UpdateWorksheetValue in text box onChange event. Cells are not updated even when I tab out of the field. As this is working for David, I suspect I am missing something here
If you want to get fancy using WithEvents...
Create a Class Module and name it tbEventClass. Put the following code in this module.
Option Explicit
Public WithEvents tb As MSForms.TextBox
Private Sub tb_Change()
Call UpdateWorksheetValue(tb)
End Sub
This defines a custom class (tbEventClass) which is responsive to the events of it's tb property which is a TextBox. You'll need to map your textboxes to instances of this class during the form's Initialize event:
Public textbox_handler As New Collection
Private Sub UserForm_Initialize()
Dim ctrl As Control, tbEvent As tbEventClass
For Each ctrl In Me.Controls
If TypeName(ctrl) = "TextBox" Then
Set tbEvent = New tbEventClass
Set tbEvent.tb = ctrl
textbox_handler.Add tb
End If
Next
End Sub
Important: You will either need to remove or modify the Change event handlers in the UserForm module to avoid duplicate calls to the "update" procedure. If the only thing going on in those event handlers is the call to your update macro, just get remove the event handlers entirely, they're fully represented by the tbClass. If those events contain other code that does other stuff, just remove or comment out the line(s) that call on your update function.
Update:
This is working for me with the controls within a MultiPage and required ZERO changes to the implemented code above.
I am trying to make my excel macro dynamic. The excel macro essentially looks at only 2 columns, one which contains the name and the other contains the numeric part. I have my macro working perfectly, the only problem is that it is hard coded when I created the program. In my code, I hard coded the name in column 2 and the numeric part in column 3. However, that is not the case in real life. The name and numeric data could appear in column 1 and 5, for example. I've been manually rearranging the data in the columns so that it fits into what hard coded. However, I want to make this process dynamic and less manual work for the user.
There are 5 different versions of spreadsheets this macro will be used on and in each spreadsheet, the name and number columns are different. I am looking to make a user form box of some sort, where the user selects "Vendor XYZ" and since Vendor XYZ always sends their data sheets the same way I know that Vendor XYZ's name column is 2 and number is 4. So I was thinking that the dictionary would be something in the form of {Vendor XYZ: 2,4} (where the first number is the name column and the second number is the numeric columnnumber...I know the syntax is wrong)
I think my work around this would be to hard code the different vendors and then use if statements ( I haven't tried it yet)
I will have a user input/dropdown box of 5 different vendors. Then something like
If userinput="A"
then namecol=2 and numcol=1
If userinput="B"
then namecol="3" and numcol="4"
I don't know if that would even work. The problem with that is that the number of vendors is small now, but will be scaling up and I can't do that if we have 100 or 1000 vendors.
Any ideas?
Depending on how your initial dataset is retrieved, you can use something like this:
Public Function GetHeaderIndices(ByVal InputData As Variant) As Scripting.Dictionary
If IsEmpty(InputData) Then Exit Function
Dim HeaderIndices As Scripting.Dictionary
Set HeaderIndices = New Scripting.Dictionary
HeaderIndices.CompareMode = TextCompare
Dim i As Long
For i = LBound(InputData, 2) To UBound(InputData, 2)
If Not HeaderIndices.Exists(Trim(InputData(LBound(InputData, 1), i))) Then _
HeaderIndices.Add Trim(InputData(LBound(InputData, 1), i)), i
Next
Set GetHeaderIndices = HeaderIndices
End Function
This Function takes an array as an input and gives the user a dictionary with the indices of the headers from the input.
If you are smart (and I say this because too many users just don't use tables) you will have your data in a table, and you will have named that table. If you did, you could do something like this:
Sub DoSomething()
Dim MyData as Variant
MyData = ThisWorkbook.Worksheets("MyDataSheet").ListObjects("MyTableName").Range.Value
End Sub
So, if you data looked like this:
Foo Baz Bar
1 Car Apple
3 Van Orange
2 Truck Banana
The function would give you a dictionary like:
Keys Items
Foo 1
Baz 2
Bar 3
Then your subroutines could do something like this:
Sub DoEverything()
Dim MyData as Variant
MyData = ThisWorkbook.Worksheets("MyDataSheet").ListObjects("MyTableName").Range.Value
DoSomething(MyData)
End Sub
Sub DoSomething(ByRef MyData as Variant)
Dim HeaderIndices as Scripting.Dictionary
Set HeaderIndices = GetHeaderIndices(MyData)
Dim i as Long
' Loop through all the rows after the header row.
For i = LBound(MyData, 1) + 1 to Ubound(MyData, 1)
If MyData(i, HeaderIndices("Baz")) = "Truck" Then
?MyData(i, HeaderIndices("Foo"))
?MyData(i, HeaderIndices("Baz"))
?MyData(i, HeaderIndices("Bar"))
End If
Next
End Sub
This does require a reference to Scripting.Runtime so if you don't want to add a reference you will need to change any reference to As Scripting.Dictionary to As Object and any New Scripting.Dictionary to CreateObject("Scripting.Dictionary").
Alternatively, I use the following code module to take care of adding references programmatically for all my users:
Public Sub PrepareReferences()
If CheckForAccess Then
RemoveBrokenReferences
AddReferencebyGUID "{420B2830-E718-11CF-893D-00A0C9054228}"
End If
End Sub
Public Sub AddReferencebyGUID(ByVal ReferenceGUID As String)
Dim Reference As Variant
Dim i As Long
' Set to continue in case of error
On Error Resume Next
' Add the reference
ThisWorkbook.VBProject.References.AddFromGuid _
GUID:=ReferenceGUID, Major:=1, Minor:=0
' If an error was encountered, inform the user
Select Case Err.Number
Case 32813
' Reference already in use. No action necessary
Case vbNullString
' Reference added without issue
Case Else
' An unknown error was encountered, so alert the user
MsgBox "A problem was encountered trying to" & vbNewLine _
& "add or remove a reference in this file" & vbNewLine & "Please check the " _
& "references in your VBA project!", vbCritical + vbOKOnly, "Error!"
End Select
On Error GoTo 0
End Sub
Private Sub RemoveBrokenReferences()
' Reference is a Variant here since it requires an external reference.
' It isnt possible to ensure that the external reference is checked when this process runs.
Dim Reference As Variant
Dim i As Long
For i = ThisWorkbook.VBProject.References.Count To 1 Step -1
Set Reference = ThisWorkbook.VBProject.References.Item(i)
If Reference.IsBroken Then
ThisWorkbook.VBProject.References.Remove Reference
End If
Next i
End Sub
Public Function CheckForAccess() As Boolean
' Checks to ensure access to the Object Model is set
Dim VBP As Variant
If Val(Application.Version) >= 10 Then
On Error Resume Next
Set VBP = ThisWorkbook.VBProject
If Err.Number <> 0 Then
MsgBox "Please pay attention to this message." _
& vbCrLf & vbCrLf & "Your security settings do not allow this procedure to run." _
& vbCrLf & vbCrLf & "To change your security setting:" _
& vbCrLf & vbCrLf & " 1. Select File - Options - Trust Center - Trust Center Settings - Macro Settings." & vbCrLf _
& " 2. Place a checkmark next to 'Trust access to the VBA project object model.'" _
& vbCrLf & "Once you have completed this process, please save and reopen the workbook." _
& vbCrLf & "Please reach out for assistance with this process.", _
vbCritical
CheckForAccess = False
Err.Clear
Exit Function
End If
End If
CheckForAccess = True
End Function
And I have the following command in each Workbook_Open event (less than ideal, but only good solution I have so far)
Private Sub Workbook_Open()
PrepareReferences
End Sub
I have a value (variant) strCompany in my workbook. I would like to determine if this value exists in column A of another workbook, tmp_workbook. If it does not exist there should be a message box. Does the following code make sense (I define the variables tmp_workbook and strCompany earlier in my code)? If not perhaps you can suggest a better way?
On Error GoTo ErrorHandler
Set value_exists_in_table = tmp_workbook.ActiveSheet.Range("A1:A100000").Find(strCompany)
ErrorHandler:
Select Case Err.Number
Case 9, 91
MsgBox "The company " & strCompany & " was not found."
Exit Sub
End Select
The Range.Find method inherits many parameters from the last time it was used; commonly by the user on the worksheet. You should explicitly specify several more commonly used parameters like LookAt:xlWhole or LookAt:xlPart and LookIn:=xlValues or LookIn:=xlFormulas.
I typically stay away from .Find for exact matches in a single row or column. The Excel Application object's native MATCH function does an excellent job of locating a value.
dim rw as variant
with worksheets("Sheet1")
rw = application.match(strCompany, .Columns(1), 0)
if not iserror(rw) then
value_exists_in_table = .cells(rw, 1).value
debug.print value_exists_in_table & " found in row " & rw
else
debug.print "The company " & strCompany & " was not found."
end if
end with
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!