How to remove missing references? - vba

I am using Outlook 2016 and Word 2016.
I have users with Outlook and Word 2013 which requires them to have a reference to the Outlook Library.
I have code that should check for and remove broken references and then add the references that I specified.
It does not remove the missing references so I remove the missing libraries manually and then run the code to add them.
This is the code, found on a MS Community Forum, which works under other circumstances:
Sub AddReference()
Dim strGUID(1 To 7) As String, theRef As Variant, i As Long
strGUID(1) = "{00062FFF-0000-0000-C000-000000000046}" ' Reference for Outlook library (see below reference printer to get more codes)
strGUID(2) = "{00020905-0000-0000-C000-000000000046}" ' Reference for Word library (see below reference printer to get more codes)
strGUID(3) = "{000204EF-0000-0000-C000-000000000046}" ' Reference for VBA library (see below reference printer to get more codes)
strGUID(4) = "{00020813-0000-0000-C000-000000000046}" ' Reference for Excel library (see below reference printer to get more codes)
strGUID(5) = "{2DF8D04C-5BFA-101B-BDE5-00AA0044DE52}" ' Reference for Office library (see below reference printer to get more codes)
strGUID(6) = "{0D452EE1-E08F-101A-852E-02608C4D0BB4}" ' Reference for MS Forms (see below reference printer to get more codes)
strGUID(7) = "{420B2830-E718-11CF-893D-00A0C9054228}" ' Reference for scripting (see below reference printer to get more codes)
On Error Resume Next
'Remove any missing references
For i = ThisWorkbook.VBProject.References.Count To 1 Step -1
Set theRef = ThisWorkbook.VBProject.References.Item(i)
If theRef.isbroken = True Then
ThisWorkbook.VBProject.References.Remove theRef
End If
Next i
For i = 1 To 7
'Clear any errors so that error trapping for GUID additions can be evaluated
Err.Clear
'Add the reference
ThisWorkbook.VBProject.References.AddFromGuid _
GUID:=strGUID(i), Major:=1, Minor:=0
'If an error was encountered, inform the user
Select Case Err.Number
Case Is = 32813
'Reference already in use. No action necessary
Case Is = 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
Next i
On Error GoTo 0
End Sub

This isn't the answer you're after as it doesn't deal with removing VBA references, etc.
It does show how to get MS Applications talking to each other without setting references though.
I've tested this on Word 2010, Outlook 2010 (had to change Application.PathSeparator to \), Excel 2003 and Excel 2010.
'Create an instance of Word & Outlook.
'Create a Word document and save it.
'Create an email and attach Word document to it.
Public Sub Test()
Dim oL As Object
Dim oW As Object
Dim nS As Object
Dim oMsg As Object
Dim oDoc As Object
Dim sDesktop As String
'Find the desktop.
sDesktop = CreateObject("WScript.Shell").specialfolders("Desktop")
'Create and save a Word document to the desktop.
Set oW = CreateWD
Set oDoc = oW.Documents.Add(DocumentType:=0) 'wdNewBlankDocument
oDoc.SaveAs sDesktop & Application.PathSeparator & "TempDoc"
'Create and save an email message, attach the Word doc to it.
Set oL = CreateOL
Set nS = oL.GetNamespace("MAPI")
Set oMsg = oL.CreateItem(0)
With oMsg
.To = "someaddress#somedomain"
.Body = "My Message"
.Subject = "My Subject"
.Attachments.Add sDesktop & Application.PathSeparator & "TempDoc.docx"
.Display 'or .Send
.Save
End With
End Sub
' Purpose : Creates an instance of Outlook and passes the reference back.
Public Function CreateOL() As Object
Dim oTmpOL As Object
On Error GoTo ERROR_HANDLER
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Creating an instance of Outlook is different from Word. '
'There can only be a single instance of Outlook running, '
'so CreateObject will GetObject if it already exists. '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set oTmpOL = CreateObject("Outlook.Application")
Set CreateOL = oTmpOL
On Error GoTo 0
Exit Function
ERROR_HANDLER:
Select Case Err.Number
Case Else
MsgBox "Error " & Err.Number & vbCr & _
" (" & Err.Description & ") in procedure CreateOL."
Err.Clear
End Select
End Function
' Purpose : Creates an instance of Word and passes the reference back.
Public Function CreateWD(Optional bVisible As Boolean = True) As Object
Dim oTmpWD As Object
'''''''''''''''''''''''''''''''''''''''''''''''''''''
'Defer error trapping in case Word is not running. '
'''''''''''''''''''''''''''''''''''''''''''''''''''''
On Error Resume Next
Set oTmpWD = GetObject(, "Word.Application")
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
'If an error occurs then create an instance of Word. '
'Reinstate error handling. '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
If Err.Number <> 0 Then
Err.Clear
On Error GoTo ERROR_HANDLER
Set oTmpWD = CreateObject("Word.Application")
End If
oTmpWD.Visible = bVisible
Set CreateWD = oTmpWD
On Error GoTo 0
Exit Function
ERROR_HANDLER:
Select Case Err.Number
Case Else
MsgBox "Error " & Err.Number & vbCr & _
" (" & Err.Description & ") in procedure CreateWD."
Err.Clear
End Select
End Function

Related

How to pass Outlook AppointmenItem data to Access form textbox

I have an Access form which will create an Outlook AppointmentItem for the current record.
The .Start and .Categories of the AppointmentItem are derived from user-input on the form.
I have a command button which will find and open the AppointmentItem so that the user may edit it.
After the user makes the edits I want to pass the edited information to the form controls so that the user can see the updated start time and category without having to open the AppointmentItem.
I am storing Public variables for the two bits of data. I cannot figure out the process by which the variables are updated with the data from the AppointmentItem.
Code for finding the existing AppointmentItem:
Option Compare Database
Public gdtStart As Date
Public gstrCat As String
Option Explicit
Function FindExistingAppt(strPath As String)
Dim OApp As Object
Dim OAppt As Object
Dim ONS As Object
Dim ORecipient As Outlook.Recipient
Dim OFolder As Object
Dim sFilter As String
Const olAppointmentItem = 1
Dim bAppOpened As Boolean
'Initiate our instance of the oApp object so we can interact with Outlook
On Error Resume Next
Set OApp = 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 OApp = CreateObject("Outlook.Application")
bAppOpened = False 'Outlook was not already running, we had to start it
Else
bAppOpened = True 'Outlook was already running
End If
On Error GoTo Error_Handler
Set OApp = GetObject(, "Outlook.Application")
Set ONS = OApp.GetNamespace("MAPI")
Set ORecipient = ONS.CreateRecipient("xxxxxxxxxxxxx")
'my example uses a shared folder but you can change it to your defaul
Set OFolder = ONS.GetSharedDefaultFolder(ORecipient, olFolderCalendar)
'use your ID here
sFilter = "[Mileage] = " & strPath & ""
If Not OFolder Is Nothing Then
Set OAppt = OFolder.Items.Find(sFilter)
If OAppt Is Nothing Then
MsgBox "Could not find appointment"
Else
With OAppt
.Display
End With
End If
End If
gdtStart = OAppt.Start
gstrCat = OAppt.Categories
Error_Handler_Exit:
On Error Resume Next
If Not OAppt Is Nothing Then Set OAppt = Nothing
If Not OApp Is Nothing Then Set OApp = Nothing
Exit Function
Error_Handler:
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Number: " & err.Number & vbCrLf & _
"Error Source: FindExistingAppt" & vbCrLf & _
"Error Description: " & err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl), _
vbOKOnly + vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Function
Here is the code from the command button which opens the AppointmentItem.
Private Sub cmdFindAppt_Click()
'Goes to the OutlookApp module and uses the FindExistingAppt function to look for an appointment that has
'already been created to the Warrants Outlook calendar, and if it found, opens the appointment. After edits are
'made the Appointment Date and Category are updated on the form.
Call FindExistingAppt(Me.ID)
Me.ApptDate = gdtStart
Me.Category = gstrCat
End Sub
How do I update the form controls with the Public variables?
After the code runs the form controls do not reflect the values of the stored Public variables.
If I open the AppointmentItem one more time (using the FindExistingAppt code - not by opening the AppointmentItem in Outlook proper), and close either by saving or not, then the form controls update.
This probably doesn't work because the VBA code continues to run after OAppt.Display.
So any changes you make and save to OAppt won't be read to your variables, because the function is already finished.
Try using the Modal parameter, this may halt the code until OAppt is closed.
With OAppt
.Display True
https://learn.microsoft.com/en-us/office/vba/api/outlook.appointmentitem.display
Also add Debug.Print commands and/or breakpoints before and after .Display to see what's happening.
The way you update those form controls should be working fine.
Try to check if the FindExistingAppt function really does assign values into public variables by debugging the function.
Use locals window to watch the variables values (gdtStart and gstrCat) while debugging.
Just sharing common practice:
If your procedure/routine does not return the value then you can declare it with Sub keyword instead Function keyword.

Using Excel VBA to Copy MS Word bookmark range and Paste into Excel

I am writing a macro in Excel (2010) to copy the value of 3 bookmarks from Word (2010) and paste them into a certain Excel Range.
I've found several similar questions here and on other various forums however most are macros in Word and don't have the correct references for what I need.
Please note I will be using this to grab a Name, Date and Integer from multiple documents (approx. 200) which all have the same bookmarks. This will be run at different times depending on when I assess the contents of the document and mark them as completed.
To give a quick rundown of what the macro should do:
Check how many Word documents are open and return a MsgBox if too many or none are open.
If Only 1 word document is open, it should then reference the word document, select the relevant bookmark Range and copy the data.
It should then return to Excel and paste the data in the specified range and cell reference.
Here is my current code (and below this is my list of issues):
Private Sub cmdImport_Click()
Dim intDocCount As Integer
Dim wdApp As Word.Application, wdDoc As Word.Document, xlWb As Excel.Workbook, xlWs As Excel.Worksheet
Set wdApp = Word.Application
Set wdDoc = ActiveDocument
Set xlWb = ThisWorkbook 'Edited from ActiveWorkbook
Set xlWs = ActiveWorkbook.Sheets("Sheet1")
intDocCount = Word.Application.Documents.Count
If intDocCount = 1 Then
GoTo Import
ElseIf intDocCount > 1 Then
MsgBox "There are " & intDocCount & " Word Documents open." & vbNewLine & vbNewLine & _
"Please close the additional MS Word Documents", vbCritical, "Too many Word Documents open!"
Exit Sub
ElseIf intDocCount < 1 Then 'Currently shows Runtime Error 462 rather than MsgBox
MsgBox "There are no MS Word Documents open.", vbInformation, "No Word Documents open"
Exit Sub
End If
Import:
With wdApp
wdDoc.Activate
wdDoc.Bookmarks("test").Range.Select
wdDoc.Copy 'Run-time error '438' here
End With
With xlWb
xlWs.Activate
xlWs.Cells(2, 1) = Selection
xlWs.Paste
End With
End Sub
So as indicated in the code, the second ElseIf statement returns Runtime Error '462' "The remote server machine does not exist or is unavailable" rather than the vbInformation message,
AND
As long as there is 1 word document open I receive the following:
"Run-time error '13': Type mismatch".
Also a Run-time error '438' is present on the wdDoc.Copy line
Unfortunatley I haven't found any other questions/answers that cover this specific scenario nor have I been able to Frankenstein some code together.
EDIT: Set xlWb = ThisWorkbook was changed from Set xlWb = ActiveWorkbook which fixed Run-time error '13'.
Added info regarding Run-time error '438'.
Please try it like this...
Private Sub cmdImport_Click()
Dim intDocCount As Integer
Dim wdApp As Word.Application, wdDoc As Word.Document, xlWb As Excel.Workbook, xlWs As Excel.Worksheet
Dim BookmarkText As String
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
On Error GoTo 0
If wdApp Is Nothing Then
MsgBox "There are no MS Word Documents open.", vbInformation, "No Word Documents open"
Exit Sub
End If
Set xlWb = ThisWorkbook 'Edited from ActiveWorkbook
Set xlWs = ActiveWorkbook.Sheets("Sheet1")
intDocCount = wdApp.Documents.Count
If intDocCount > 1 Then
MsgBox "There are " & intDocCount & " Word Documents open." & vbNewLine & vbNewLine & _
"Please close the additional MS Word Documents", vbCritical, "Too many Word Documents open!"
Set wdApp = Nothing
Exit Sub
End If
With wdApp
Set wdDoc = wdApp.ActiveDocument
wdDoc.Activate
BookmarkText = wdDoc.Bookmarks("test").Range.Text
End With
xlWs.Cells(2, 1) = BookmarkText
End Sub

Opening Outlook through VBA crashes for unknown reason

I am using this code to open a list of email-adresses directly in outlook. The email list consists of roughly 100 email-adresses.
If I let the code run for only parts of the list it works just fine for all different parts, but as soon as I let it run for the whole list I get a runtime error '5. Does anyone have a suggestion what causes this problem? I would be very thankful.
If ActiveWorkbook.Worksheets("Output").Range("I10").Value = "Wahr" Then
Dim strAddress As String
Dim lastCell As Long
Dim i As Integer
Worksheets("Output").Activate
lastCell = Range("B" & Rows.Count).End(xlUp).Row
For i = 13 To lastCell
If strAddress = "" Then
strAddress = Cells(i, 2).Value
Else
strAddress = strAddress & ";" & Cells(i, 2).Value
End If
Next i
ActiveWorkbook.FollowHyperlink Address:="mailto:" & strAddress 'this line gives me the error
End If
EDIT: The weird thing is, that it doesnt really matter which "groups" I choose. It seems to be a question of how many adresses I pick.
Not sure what you mean by I am using this code to open a list of email-adresses directly in outlook.
The code appears to create a single blank email with each cell in B13 downwards providing the email addresses?
Maybe this code below will help.
It uses late binding (so no references needed) to get a reference to Outlook, it then creates an email and adds the email addresses to it as recipients before finally displaying it. You can change the .Display to .Send to send the email rather than just display it.
Public Sub Test()
Dim oOL As Object
Dim oMail As Object
Dim rLastCell As Range
Dim rAddRange As Range
Dim rCell As Range
Set oOL = CreateOL
With ThisWorkbook.Worksheets("Output")
Set rLastCell = .Cells(.Rows.Count, 2).End(xlUp)
Set rAddRange = .Range("B13", rLastCell)
End With
Set oMail = oOL.CreateItem(0)
With oMail
For Each rCell In rAddRange
.Recipients.Add rCell.Value
Next rCell
.Display
End With
End Sub
Public Function CreateOL() As Object
Dim oTmpOL As Object
On Error GoTo ERROR_HANDLER
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Creating an instance of Outlook is different from Excel. '
'There can only be a single instance of Outlook running, '
'so CreateObject will GetObject if it already exists. '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set oTmpOL = CreateObject("Outlook.Application")
Set CreateOL = oTmpOL
On Error GoTo 0
Exit Function
ERROR_HANDLER:
Select Case Err.Number
Case Else
MsgBox "Error " & Err.Number & vbCr & _
" (" & Err.Description & ") in procedure CreateOL."
Err.Clear
End Select
End Function

Excel 2013 Outlook Recipient Resolve fails

I have the following code that worked fine in Excel 2007 but fails in Excel 2013.
Dim lappOutlook As Outlook.Application
Dim lappNamespace As Outlook.Namespace
Dim lappRecipient As Outlook.RECIPIENT
Set lappOutlook = CreateObject("Outlook.Application")
Set lappNamespace = lappOutlook.GetNamespace("MAPI")
Set lappRecipient = lappNamespace.CreateRecipient("smithj1")
lappRecipient.Resolve
What I'm doing is parsing emails from a folder in my inbox. However, I need to resolve the recipient but that fails. The code you see starts out the sub and the remainder of the code follows the resolve method.
The error returned is:
Run-time error '287':
Application-defined or object-defined error
The error help really does not provide any useful information. Especially since this worked perfectly in Excel 2007 but now fails after an "upgrade" to Excel 2013.
I have tried "smithj1#company.org" and "John Smith" and "John A. Smith", etc. (those are not the real name) but nothing works. When I copied this to a laptop that still had Office 2007 on it, the code ran perfectly. Within the hour, the laptop was "upgraded" automatically to Office 2013 and the code failed.
Any help would be greatly appreciated.
Try waiting to see if there is a delayed response.
Private Sub openOutlook2()
Dim lappOutlook As Outlook.Application
Dim lappNamespace As Outlook.Namespace
Dim lappRecipient As Outlook.Recipient
Dim strAcc As String
Dim maxTries As Long
Dim errCount As Long
Set lappOutlook = CreateObject("Outlook.Application")
Set lappNamespace = lappOutlook.GetNamespace("MAPI")
strAcc = "smithj1"
Set lappRecipient = lappNamespace.CreateRecipient(strAcc)
maxTries = 2000
On Error GoTo errorResume
Retry:
DoEvents
' For testing error logic. No error with my Excel 2013 Outlook 2013 setup.
' Should normally be commented out
'Err.Raise 287
lappRecipient.Resolve
On Error GoTo 0
If lappRecipient.Resolved Then
Debug.Print strAcc & " resolved."
MsgBox strAcc & " resolved."
Else
Debug.Print strAcc & " not resolved."
MsgBox "No error: " & strAcc & " not resolved."
End If
ExitRoutine:
Set lappOutlook = Nothing
Set lappNamespace = Nothing
Set lappRecipient = Nothing
Debug.Print "Done."
Exit Sub
errorResume:
errCount = errCount + 1
' Try until Outlook responds
If errCount > maxTries Then
' Check if Outlook is there and Resolve is the issue
lappNamespace.GetDefaultFolder(olFolderInbox).Display
GoTo ExitRoutine
End If
Debug.Print errCount & " - " & Err.Number & ": " & Err.Description
Resume Retry
End Sub

Reference Excel cell in PowerPoint macro for filename

I can't get SaveAsFixedFormat working from Excel VBA to export a PowerPoint file as PDF. I have resorted to starting a macro in the preset-powerpoint from Excel VBA that exports the presentation as pdf directly from PowerPoint.
Is there any way to reference a cell in the Excel file in this macro that is running in PowerPoint to get the filename?
Sub pppdf()
ActivePresentation.ExportAsFixedFormat "M:\random\test.pdf", 32
End Sub
I can save the PowerPoint file as .pptx from Excel and use varying filenames and paths but now I would like to reference those same paths and filenames in the PowerPoint macro that is exporting to pdf.
In the end I'd like the code to look somewhat like this but this obviously needs some work to function from PowerPoint:
Dim FName As String
Dim FPath As String
FPath = Range("SavingPath").Value
FName = Sheets("randomworksheet").Range("A1").Text
ActivePresentation.ExportAsFixedFormat FPath & FName & " Development" & ".pdf", 32
This PowerPoint macro would be started from Excel and both the PowerPoint file and the Excel Workbook and sheet will be open when this is executed.
Why not open the presentation and save it as a PDF from Excel if the main bulk of the code is in Excel anyway?
Sub SavePPTXasPDF()
Dim PPT As Object
Dim PP As Object
Set PPT = CreatePPT
Set PP = PPT.Presentations.Open("<FullPathToPresentation>")
PP.SaveAs ThisWorkbook.Path & Application.PathSeparator & "ABC", 32 'ppSaveAsPDF
End Sub
Public Function CreatePPT(Optional bVisible As Boolean = True) As Object
Dim oTmpPPT As Object
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Defer error trapping in case Powerpoint is not running. '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
On Error Resume Next
Set oTmpPPT = GetObject(, "Powerpoint.Application")
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'If an error occurs then create an instance of Powerpoint. '
'Reinstate error handling. '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If Err.Number <> 0 Then
Err.Clear
On Error GoTo ERROR_HANDLER
Set oTmpPPT = CreateObject("Powerpoint.Application")
End If
oTmpPPT.Visible = bVisible
Set CreatePPT = oTmpPPT
On Error GoTo 0
Exit Function
ERROR_HANDLER:
Select Case Err.Number
Case Else
MsgBox "Error " & Err.Number & vbCr & _
" (" & Err.Description & ") in procedure CreatePPT."
Err.Clear
End Select
End Function
or if you want to run the code in Powerpoint:
Public Sub Test()
Dim oXL As Object
Dim oWB As Object
Dim FName As String
Dim FPath As String
Set oXL = CreateXL
Set oWB = oXL.workbooks.Open("<Path&FileName>")
'Or if Workbook is already open:
'Set oWB = oXL.workbooks("<FileName>")
FPath = oWB.worksheets("Sheet1").Range("A1")
FName = oWB.worksheets("Sheet1").Range("A3")
ActivePresentation.ExportAsFixedFormat FPath & FName & " Development" & ".pdf", 32
End Sub
Public Function CreateXL(Optional bVisible As Boolean = True) As Object
Dim oTmpXL As Object
'''''''''''''''''''''''''''''''''''''''''''''''''''''
'Defer error trapping in case Excel is not running. '
'''''''''''''''''''''''''''''''''''''''''''''''''''''
On Error Resume Next
Set oTmpXL = GetObject(, "Excel.Application")
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
'If an error occurs then create an instance of Excel. '
'Reinstate error handling. '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
If Err.Number <> 0 Then
Err.Clear
On Error GoTo ERROR_HANDLER
Set oTmpXL = CreateObject("Excel.Application")
End If
oTmpXL.Visible = bVisible
Set CreateXL = oTmpXL
On Error GoTo 0
Exit Function
ERROR_HANDLER:
Select Case Err.Number
Case Else
MsgBox "Error " & Err.Number & vbCr & _
" (" & Err.Description & ") in procedure CreateXL."
Err.Clear
End Select
End Function
Or you could, as you requested, open the presentation from within Excel and execute code stored in the presentation:
Sub SavePPTXasPDF()
Dim PPT As Object
Dim PP As Object
Set PPT = CreatePPT
Set PP = PPT.Presentations.Open("<FullPath>")
PPT.Run PP.Name & "!Test"
End Sub
This would use the Test macro and use the Set oWB = oXL.workbooks("<FileName>") line of code which is currently commented out in my example above.
What problem are you facing using ExportAsFixedFormat directly from the Excel VBE? According to the documentation (which seems to be incorrect) and the PowerPoint VBE IntelliSense, the second argument, FixedFormatType can only be one of two values:
ExportAsFixedFormat(Path, FixedFormatType, Intent, FrameSlides, _
HandoutOrder, OutputType, PrintHiddenSlides, PrintRange, _
RangeType, SlideShowName, IncludeDocProperties, KeepIRMSettings)
FixedFormatType:
ppFixedFormatTypePDF = 2
ppFixedFormatTypeXPS = 1