Is there any way in VBA to determine whether the Scripting-Runtime aka scrrun.dll is disabled on a users system (here's a link on how to do that)?
I know, this is a very rare case, but it could be the case for exactly one client. There is another thread here but it's a little different.
Would you just go something like this?
Dim fso As Object
On Error Resume Next
Set fso = CreateObject("Scripting.FileSystemObject")
On Error Goto 0
If fso Is Nothing then _
MsgBox "Scripting runtime is not available on this system."
Yes, I would use this approach, it's as short as it can be:
Public Function ScriptingRuntimeAvailable() As Boolean
On Error Resume Next
With CreateObject("Scripting.FileSystemObject"): End With
ScriptingRuntimeAvailable = Err.Number = 0
End Function
Related
Nowadays you can work on synchronized sharepoint content via OneDrive even when you are not linked to your company network via e.g. VPN, but logged in to Onedrive via your company account. Strange thing is that the DIR function in that disconnected situation returns an empty value for a directory that certainly exists. I see solutions trying to create mapped drives, but it can be done simpler.
I'll answer this question myself.
Robert, this is exactly your code but a bit more dense.
The With statement takes care of the object reference and ensures its destroyed when it reaches the End With block.
Public Function DirExists(ByVal path As String) As Boolean
On Error Resume Next
With CreateObject("Scripting.FileSystemObject")
DirExists = Not .GetFolder(path) Is Nothing
End With
On Error GoTo 0
End Function
This is nothing more than a different approach on how to write the particular function. There's absolutely nothing wrong with your example.
This is my solution:
Function MyDirExists(ByVal myPath As String) As Boolean
'Dir() doesn't work on directories in synchronized sharepoint
'that appear in your OneDrive folders
'Let's use the FileSystem instead.
'Use Late binding as not everyone has the library FileSystemObject included
Dim objFSO As Object 'Late binding
Dim objfolder As Object 'Late binding
Set objFSO = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
'if directory does not exist GetFolder raises an error
'and we happily use that fact
Set objfolder = objFSO.GetFolder(myPath)
If Not objfolder Is Nothing Then
MyDirExists = True 'Default return value is False
End If
On Error GoTo 0
'Clean up objects
Set objFSO = Nothing
Set objfolder = Nothing
End Function
I like to open Outlook with VBA. It should check if outlook is open and if not then it should open it. I have code but its to big and some times dont work with other macros with Call function. What should be the simple and short code to do this and work with all versions?
#Const LateBind = True
Const olMinimized As Long = 1
Const olMaximized As Long = 2
Const olFolderInbox As Long = 6
#If LateBind Then
Public Function OutlookApp( _
Optional WindowState As Long = olMinimized, _
Optional ReleaseIt As Boolean = False _
) As Object
Static o As Object
#Else
Public Function OutlookApp( _
Optional WindowState As outlook.OlWindowState = olMinimized, _
Optional ReleaseIt As Boolean _
) As outlook.Application
Static o As outlook.Application
#End If
On Error GoTo ErrHandler
Select Case True
Case o Is Nothing, Len(o.Name) = 0
Set o = GetObject(, "Outlook.Application")
If o.Explorers.Count = 0 Then
InitOutlook:
'Open inbox to prevent errors with security prompts
o.session.GetDefaultFolder(olFolderInbox).Display
o.ActiveExplorer.WindowState = WindowState
End If
Case ReleaseIt
Set o = Nothing
End Select
Set OutlookApp = o
ExitProc:
Exit Function
ErrHandler:
Select Case Err.Number
Case -2147352567
'User cancelled setup, silently exit
Set o = Nothing
Case 429, 462
Set o = GetOutlookApp()
If o Is Nothing Then
Err.Raise 429, "OutlookApp", "Outlook Application does not appear to be installed."
Else
Resume InitOutlook
End If
Case Else
MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "Unexpected error"
End Select
Resume ExitProc
Resume
End Function
#If LateBind Then
Private Function GetOutlookApp() As Object
#Else
Private Function GetOutlookApp() As outlook.Application
#End If
On Error GoTo ErrHandler
Set GetOutlookApp = CreateObject("Outlook.Application")
ExitProc:
Exit Function
ErrHandler:
Select Case Err.Number
Case Else
'Do not raise any errors
Set GetOutlookApp = Nothing
End Select
Resume ExitProc
Resume
End Function
Sub open_outlook()
Dim OutApp As Object
Set OutApp = OutlookApp()
'Automate OutApp as desired
End Sub
I think you can try below code.Its shortest code i tried to open in my all VBA coding.
Sub Open_Outlook()
Shell ("OUTLOOK")
End Sub
See How to automate Outlook from another program for the sample code. You can use the GetObject method for getting the running instance of Outlook instead of creating a new one:
Set objOutlook = GetObject(, "Outlook.Application")
However, Outlook is a singleton. Each time you call the CreateObject method you will get the same instance. You can't run two instances of Outlook at the same time. See GetObject in Word VBA script to find Outlook instance fails with 429 error unless both apps running as administrator for more info.
Be aware, Microsoft does not currently recommend, and does not support, Automation of Microsoft Office applications from any unattended, non-interactive client application or component (including ASP, ASP.NET, DCOM, and NT Services), because Office may exhibit unstable behavior and/or deadlock when Office is run in this environment.
If you are building a solution that runs in a server-side context, you should try to use components that have been made safe for unattended execution. Or, you should try to find alternatives that allow at least part of the code to run client-side. If you use an Office application from a server-side solution, the application will lack many of the necessary capabilities to run successfully. Additionally, you will be taking risks with the stability of your overall solution. Read more about that in the Considerations for server-side Automation of Office article.
Dim oOutlook As Object
On Error Resume Next
Set oOutlook = GetObject(, "Outlook.Application")
On Error GoTo 0
If oOutlook Is Nothing Then
Shell ("OUTLOOK")
Else
'already open
End If
You could use something simplier:
Sub EmailMe()
dim mail as object
dim msg as object
set mail= createobject("Outlook.Application")
set msg=mail.createitem(0)
with msg
.to="someone#something.com;...."
.subject="What are you sending this for"
.body="Whatever you want to say"
.attachments.add Activeworkbook.fullname
.send
end with
end sub
I have a module that will automate Outlook but it should be skipped if Outlook isn't available.
Simply checking whether Outlook is installed is not sufficient because if there is a fresh Office install, launching Outlook will simply launch the configuration wizard. From my POV, Outlook is not available for automation so the module shouldn't be used even though it might be installed.
From my tests and the suggestions in this question, I can successfully trap for whether Outlook isn't configured yet but there is an edge case where this fails. This is when there is a dialog that asks to select a profile. In this situation, the check returns true but Outlook is actually not usable for the purposes of automation due to still needing additional configuration (e.g. selecting a profile). Is it possible to also trap this edge case?
To reproduce the "Select Profile" issue, go to Control Panel -> Mail. On the dialog, there is a option to "When starting Microsoft Outlook, use this profile" - select "Prompt for a profile used". When you then launch Outlook, you are asked to choose a profile. That is the case when the code below will fail.
This is my almost-working code so far...
Public Function DetectOutlookProfile() As Boolean
Dim objOutlook As Object
Dim objReg As Object
Dim varSplit As Variant
Dim lngMajor As Long
Dim strPath As String
Dim varSubKeys As Variant
Dim varSubKey As Variant
Const HKEY_CURRENT_USER As Long = &H80000001
On Error GoTo ErrHandler
Set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
'Get an instance of Outlook so that we can determine the version
'being currently used by the current user.
Set objOutlook = CreateObject("Outlook.Application")
varSplit = Split(objOutlook.Version, ".")
lngMajor = varSplit(0)
If lngMajor <= 14 Then
'Outlook profile isn't version specific for Outlook 97-2010
strPath = "Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles"
Else
'Outlook profile is version specific for Outlook 2013+
strPath = "Software\Microsoft\Office\" & lngMajor & ".0\Outlook\Profiles"
End If
objReg.EnumKey HKEY_CURRENT_USER, strPath, varSubKeys
For Each varSubKey In varSubKeys
DetectOutlookProfile = True
Exit For
Next
ExitProc:
On Error Resume Next
Exit Function
ErrHandler:
'Silently fail and return false
Select Case Err.Number
Case Else
DetectOutlookProfile = False
Debug.Print Err.Number & " (" & Err.Description & ")"
End Select
Resume ExitProc
Resume
End Function
Thanks to #David Zemens' suggestions, I found a solution that seems to work.
It seems that I don't even need to bother with registry checks. I can simply do this instead:
Set objOutlook = CreateObject("Outlook.Application")
DetectOutlookProfile = Len(objOutlook.GetNamespace("MAPI").CurrentProfileName)
Which will return 0 whether the Outlook has no profiles or is requiring a manual profile selection.
I suppose the registry check is needed to determine whether the Outlook has any profiles configured so that one's code could be then written to manually prompt the user for profile to be passed into Login method. For my case, I just don't want to run the module in either case, so the checking Len() of the current profile name suffices.
For example, the following function is used for checking whether a workbook is open:
Function BookOpen(Bk As String) As Boolean
Dim T As Excel.Workbook
Err.Clear
On Error Resume Next
Set T = Application.Workbooks(Bk)
BookOpen = Not T Is Nothing
Err.Clear
On Error GoTo 0
End Function
Are these two Err.Clear statements necessary?
In this example
Function BookOpen(Bk As String) As Boolean
Dim T As Excel.Workbook
Err.Clear
On Error Resume Next
Set T = Application.Workbooks(Bk)
BookOpen = Not T Is Nothing
Err.Clear
On Error GoTo 0
End Function
none of the uses is appropriate, because On Error resets the last error, so Err.Clear is redundant.
It's appropriate after actually handling a failed statement.
Function BookOpen(Bk As String) As Boolean
Dim T As Excel.Workbook
On Error Resume Next
Set T = Application.Workbooks(Bk) ' this can fail...
' so handle a possible failure
If Err.Number <> 0 Then
MsgBox "The workbook named """ & Bk & """ does not exist."
Err.Clear
End If
BookOpen = Not T Is Nothing
End Function
If you have On Error Resume Next in effect, the program will continue after an error as if nothing had happened. There is no exception thrown, there is no warning, this is not structured error handling (i.e. it's nothing like try/catch blocks). Your program might end up in a very weird state if you don't do rigorous error checks.
This means you must check errors after. every. statement. that. can. fail. Be prepared to write a lot of If Err.Number <> 0 Then checks. Note that this is harder to get right than it seems.
Better is: Avoid long sections of code that have On Error Resume Next in effect like the plague. Break up operations into smaller functions/subs that do only one thing instead of writing a big function that does it all but can fail halfway through.
In short: Err.Clear makes your program behave predictably after a failed statement in an On Error Resume Next block. It marks the error as handled. That's its purpose.
Of course in your sample it's easy to avoid error handling by using the commonly accepted way of checking whether a workbook (i.e. member of a collection) exists.
Function BookOpen(Bk As String) As Boolean
Dim wb As Variant
BookOpen = False ' not really necessary, VB inits Booleans to False anyway
For Each wb In Application.Workbooks
If LCase(wb.Name) = LCase(Bk) Then
BookOpen = True
Exit For
End If
Next
End Function
I apologize in advance for the newbie question -- most of my VBA experience is in Excel, or Word to Excel. In this case, I am going from Excel to Word. I am trying to capture some data off of some Word forms and store it in an Excel file.
Right now, my code works for the first document in the folder, but after that, it hoses up with an automation error "the server threw an exception" (goo!)
Here is my code:
Dim objWordApp As Object
strCurFileName = Dir(strFilePath)
Set objWordApp = CreateObject("word.application")
objWordApp.Visible = True
Do While strCurFileName <> ""
objWordApp.documents.Open strFilePath & strCurFileName
objWordApp.activedocument.Unprotect password:="testcode"
{EXCEL PROCESSING HERE}
strCurFileName = Dir
objWordApp.activedocument.Close 0
Loop
objWordApp.Quit
Set objWordApp = Nothing
I notice that the code works fine if I quit the app and set the object = nothing within the loop. But the way it is now, it bombs-out on the second file in the folder on the "objWordApp.documents.Open strFilePath & strCurFileName" line.
Can I open and close Word documents in a loop without having to create the object over and over? It's really slow when I do it that way.
Thanks for the help -- I like your way much better. Unfortunately, I get the same result. The program dies the second time through the loop on the line that reads:
Set objWordDoc = objWordApp.Documents.Open(objFile.Path)
The error that I get is:
Run-time Error -2147417851 (80010105)
Automation Error
The server threw an exception.
I tried your code on regular word docs (not the ones I'm processing) and it worked fine. The docs I'm running have form fields and macros -- not sure if that makes a difference. I have set the macro security in Word to both "low" and "very high" to make sure the other macros don't interfere.
I just can't figure it out why it works for the first doc and then not the next. I even cloned the first doc but it made no difference.
Still no luck, though. The only thing I can get to work is if I completely wipe the objects and re-create them every time I want to open a file.
Set objFolder = FSO.GetFolder(strFilePath)
For Each objFile In objFolder.Files
Set objWordApp = CreateObject("word.application")
objWordApp.Visible = True
If Right(objFile.Name, 4) = ".doc" Then
Set objWordDoc = objWordApp.documents.Open(Filename:=objFile.Path, ConfirmConversions:=False, _
ReadOnly:=True, AddToRecentFiles:=False, PasswordDocument:="", _
PasswordTemplate:="", Revert:=False, WritePasswordDocument:="", _
WritePasswordTemplate:="", Format:=wdOpenFormatAuto)
[Process DOC]
objWordDoc.Close 0, 1
End If
Set objWordDoc = Nothing
objWordApp.Quit
Set objWordApp = Nothing
Next
I'm not sure why that works and why it won't work the other way. If I have to go this route, I can -- it just seems really slow and inefficient. Is this a bad idea?
I changed the Dir to a FileSystemObject (go to Tools\References and add Microsoft Scripting Runtime) and I was able to successfully open multiple files. If you are having problems, please describe the error you see in the debugger. Also, if you need to recurse into subdirectories, you will need to refactor this.
Private mobjWordApp As Word.Application
Sub Test()
ProcessDirectory "PathName"
End Sub
Property Get WordApp() As Word.Application
If mobjWordApp Is Nothing Then
Set mobjWordApp = CreateObject("Word.Application")
mobjWordApp.Visible = True
End If
Set WordApp = mobjWordApp
End Property
Sub CloseWordApp()
If Not (mobjWordApp Is Nothing) Then
On Error Resume Next
mobjWordApp.Quit
Set mobjWordApp = Nothing
End If
End Sub
Function GetWordDocument(FileName As String) As Word.Document
On Error Resume Next
Set GetWordDocument = WordApp.Documents.Open(FileName)
If Err.Number = &H80010105 Then
CloseWordApp
On Error GoTo 0
Set GetWordDocument = WordApp.Documents.Open(FileName)
End If
End Function
Sub ProcessDirectory(PathName As String)
Dim fso As New FileSystemObject
Dim objFile As File
Dim objFolder As Folder
Dim objWordDoc As Object
On Error Goto Err_Handler
Set objFolder = fso.GetFolder(PathName)
For Each objFile In objFolder.Files
If StrComp(Right(objFile.Name, 4), ".doc", vbTextCompare) = 0 Then
Set objWordDoc = GetWordDocument(objFile.Path)
' objWordDoc.Unprotect Password:="testcode" ' Need to check if it has Password?
ProcessDocument objWordDoc
objWordDoc.Close 0, 1
Set objWordDoc = Nothing
End If
Next
Exit_Handler:
CloseWordApp
Exit Sub
Err_Handler:
MsgBox "Error " & Err.Number & ": " & Err.Description
Resume Exit_Handler
'Resume Next ' or as above
End Sub
Sub ProcessDocument(objWordDoc As Document)
'{EXCEL PROCESSING HERE}'
End Sub
EDIT: I've added some error handling and a little refactoring although there is quite a bit more refactoring that could be done.
There must be something special about the documents you are opening. You might try using different parameters for opening the documents, such as:
Set objWordDoc = objWordApp.Documents.Open( _
FileName:=objFile.Path, ReadOnly:=True)
You may need to add Microsoft Word as a Reference, and if you do that then start using the Word constants (wdDoNotSaveChanges, etc.). Check out the help on Documents.Open and test different parameters.
Also, use the "Set Next Statement" from the Context Menu during debugging and maybe skip the first document and open the second document directly and see if there are issues.
EDIT: I've changed the code to close and reopen Word if you get the automation error you described. You may have to adjust the error numbers, or simply close Word on any error (If Err.Number <> 0 Then ...).
Again, something must be special about your documents (macros, protection, etc.) because this code works on the test cases I have tried. Have you tried manually opening the documents in Word in the same order as the script, updating information similar to your process script, and then closing the documents to see if Word does anything strange?
Closing the Word.Application won't hurt anything, but it will obviously significantly slower.