Related
I have this database and it was working perfect, but today it started hating me. I started getting a Compile error: Can't find project or library. I looked around and found that when using the front end on a different computer, under VBA and references, it was missing a reference for Microsoft Word 15.0 Object Library.
My computer I have the Microsoft Word 16.0 Object Library checked. How can I get this to work on other computers with 15.0 and 16.0?
Here is the code
Private Sub cmd_LocateFile_Click()
On Error GoTo Error_Handler
Dim sFile As String
Dim sFolder As String
Dim ID As Long
Dim sTarget As String
sFile = FSBrowse("", msoFileDialogFilePicker, "All Files (*.*),*.*")
If sFile <> "" Then
sFolder = ("\\aiowima23fp1\Ecological Sciences and Engineering\Cultural Resources\New - Cultural Resources Request Database") & "\" & sAttachmentFolderName & "\"
If FolderExist(sFolder) = False Then MkDir (sFolder)
ID = RequestID_FK ' Set current record id.
sTarget = sFolder & CStr(ID) & "-" & GetFileName(sFile)
If CopyFile(sFile, sFolder & GetFileName(sTarget)) = True Then
Me!FullFileName.Value = sTarget
Else
End If
End If
Error_Handler_Exit:
On Error Resume Next
Exit Sub
Error_Handler:
MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: " & sModName & "\cmd_LocateFile_Click" & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occured!"
Resume Error_Handler_Exit
End Sub
Adding references to Word during development has the advantage to be able to use strongly typed word objects and thus being able to take advantage of IntelliSense. But these references are, as you have experienced, sensible to versioning. Therefore, I suggest you remove the reference to Word once development is achieved. You will also have to replace all Word-related types by Object, i.e. use late binding. This makes the application more robust with respect to versioning.
You can get an existing Word instance which is already open or open a new one with this code snippet, without any references to Word DLLs.
Public Function GetWordApplication() As Object
'Gets an active Word application or opens a new Word instance.
'Raises Error No. 8 if word cannot be opened.
On Error Resume Next
'Find existing instance of Word
Set GetWordApplication = GetObject(, "Word.Application")
If Err.Number <> 0 Then 'Not found, create new instance.
Set GetWordApplication = CreateObject("Word.Application")
End If
'Following code is optional. You can instead test for Nothing at the call site
On Error Goto 0
If GetWordApplication Is Nothing Then
Err.Raise 8, "YourApp.GetWordApplication", "Word could not be opened."
End If
End Function
I have VBA function in Access that should return the path of the special folder (MyDocuments, Desktop, etc) based on a string variable I passed it. However, I'm always getting the public desktop "C:\Users\Public\Desktop" instead of what I pass in. Here is the function code:
Function SpecialFolderPath(whichFolder As String) As String
Debug.Print whichFolder
Dim objWSHShell As Object
Dim strSpecialFolderPath
Set objWSHShell = CreateObject("WScript.Shell")
SpecialFolderPath = objWSHShell.SpecialFolders(whichFolder)
Debug.Print SpecialFolderPath
Set objWSHShell = Nothing
Exit Function
ErrorHandler:
MsgBox "Error finding " & strSpecialFolder, vbCritical + vbOKOnly, "Error"
End Function
So, no matter what I pass in as whichFolder, I always get C:\Users\Public\Desktop. How can I correct this?
EDIT:
I'm calling this function in the following ways:
- DoCmd.OutputTo acOutputQuery, "BoxForecasting_Jobs", "ExcelWorkbook(*.xlsx)", SpecialFolderPath("MyDocuments") & "\BoxForecastByJobs.xlsx", False, "", , acExportQualityPrint
-Set oWB = oXL.Workbooks.Open(SpecialFolderPath("MyDocuments") & "\BoxForecastByJobs.xlsx")
Change this line:
SpecialFolderPath = objWSHShell.SpecialFolders(whichFolder)
to:
SpecialFolderPath = objWSHShell.SpecialFolders("" & whichFolder & "")
I've tweaked your code a bit. Added WhichFolder = "Templates", made it a sub and returned the result through a msgbox.
My end result:
It is a collection. See what's in it using a for each loop.
Set wshshell = CreateObject("WScript.Shell")
For each thing in wshshell.SpecialFolders
wscript.echo thing
Next
These are the names it accepts.
AllUsersDesktop
AllUsersStartMenu
AllUsersPrograms
AllUsersStartup
Desktop
Favorites
Fonts
MyDocuments
NetHood
PrintHood
Programs
Recent
SendTo
StartMenu
Startup
Templates
I have a button in my Access 2007 form. On click, I need to open filedialog. I dont know how to attach the file selected to the 'Memo' field of a table using DAO.
Form details
Form : OrderForm
Field: txtManagerProfile
Button : btnFileBrowse
Table details
Table :ManagersProfile
Memo field : Profile
Requirement:
'Profile' in table should accept any file and save it. Once the user selects the file, I need to show a open icon near to the 'txtManagerProfile' field in the form. On clicking the open button , I need to open any file. I am not used to this requirement before. Someone pls help. I am using DAO for populating other fields in the form.
In the below code I have a form with a text box named txtManagerProfile and a button named btnFileBrowse. When I click on the btnFileBrowse button a browser pops up that lets you browse to the file. When you select the file, the path is stored in the txtManagerProfile text box. If you double click on the txtManagerProfile text box the file gets opened up.
Here is the code behind the form:
'the open filename api
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As gFILE) As Long
' the gFILE type needed by the open filename api
Private Type gFILE
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Private Function FileToOpen(Optional StartLookIn) As String
'Purpose: Calls the open file api to let the user select the file to open
'returns: string value which contains the path to the file selected. "" = no file seleted
Dim ofn As gFILE, Path As String, filename As String, a As String
ofn.lStructSize = Len(ofn)
ofn.lpstrFilter = "All Files (*.*)"
ofn.lpstrFile = Space$(254)
ofn.nMaxFile = 255
ofn.lpstrFileTitle = Space$(254)
ofn.nMaxFileTitle = 255
If Not IsMissing(StartLookIn) Then ofn.lpstrInitialDir = StartLookIn Else ofn.lpstrInitialDir = "f:\Quoting"
ofn.lpstrTitle = "SELECT FILE"
ofn.Flags = 0
a = GetOpenFileName(ofn)
If (a) Then
Path = Trim(ofn.lpstrFile)
filename = Trim(ofn.lpstrFileTitle)
If Dir(Path) <> "" Then
FileToOpen = -1
FileToOpen = Trim(ofn.lpstrFile)
Else
FileToOpen = ""
Path = ""
filename = ""
End If
End If
FileToOpen = Path
End Function
Private Sub btnFileBrowse_Click()
Dim MyPath As String
MyPath = FileToOpen
If (VBA.Strings.Len(MyPath & "") > 0) Then txtManagerProfile = MyPath
End Sub
Private Sub txtManagerProfile_DblClick(Cancel As Integer)
On Error GoTo Err_My_Click
Dim fso As Scripting.FileSystemObject
Set fso = New Scripting.FileSystemObject
'IF THE FILE DOES NOT EXIST THEN DISPLAY THE MESSAGE AND EXIT THE SUBROUTINE
If (fso.FileExists(txtManagerProfile) = False) Then
MsgBox "THE FILE PATH IS INCORRECT.", , "ERROR: INVALID FILE PATH"
Exit Sub
End If
'USED TO CHECK IF THE FILE IS ALREADY OPENED AND LOCKED BY ANOTHER USER.
Open txtManagerProfile For Binary Access Read Write Lock Read Write As #1
Close #1
Application.FollowHyperlink txtManagerProfile
Exit_My_Click:
Exit Sub
Err_My_Click:
If Err.Number = 486 Then
MsgBox "YOU DO NOT HAVE THE PROGRAM INSTALLED THAT " & vbNewLine & _
"IS USED TO VIEW THIS FILE. CONTACT YOUR IT " & vbNewLine & _
"MANAGER AND HAVE HIM/HER INSTALL THE NEEDED " & vbNewLine & _
"APPLICATION.", , "ERROR: MISSING APPLCIATION"
ElseIf Err.Number = 490 Then
MsgBox "THE FILE PATH IS INCORRECT.", , "ERROR: INVALID FILE PATH"
ElseIf Err.Number = 70 Or Err.Number = 75 Then
MsgBox "THE FILE IS OPENED/LOCKED BY ANOTHER USER." & vbNewLine & _
"THEY WILL HAVE TO CLOSE IT BEFORE YOU CAN " & vbNewLine & _
"OPEN IT THROUGH PDC.", , "ERROR: FILE ALREADY OPEN"
Else
MsgBox ("ERROR MESSAGE: " & Err.Description & vbNewLine & _
"ERROR NUMBER: " & Err.Number & vbNewLine & _
"ERROR SOURCE: " & Err.Source)
End If
Resume Exit_My_Click
End Sub
EDIT:
You could do something like the following to save the path into a table somewhere:
Private Sub cmdSave_Click()
If (VBA.Strings.Len(txtManagerProfile & "") <> 0) Then
DoCmd.SetWarnings False
DoCmd.RunSQL "INSERT INTO MyTable (linkfile) VALUES ('" & _
txtManagerProfile & "')"
DoCmd.SetWarnings True
MsgBox "SUCCESSFULLY SAVED", , "SUCCESS"
Else
MsgBox "YOU MUST SELECT A FILE FIRST BEFORE SAVING", , "ERROR: NO FILE"
End If
End Sub
I want to click a button on my access form that opens a folder in Windows Explorer.
Is there any way to do this in VBA?
You can use the following code to open a file location from vba.
Dim Foldername As String
Foldername = "\\server\Instructions\"
Shell "C:\WINDOWS\explorer.exe """ & Foldername & "", vbNormalFocus
You can use this code for both windows shares and local drives.
VbNormalFocus can be swapper for VbMaximizedFocus if you want a maximized view.
The easiest way is
Application.FollowHyperlink [path]
Which only takes one line!
Thanks to PhilHibbs comment (on VBwhatnow's answer) I was finally able to find a solution that both reuses existing windows and avoids flashing a CMD-window at the user:
Dim path As String
path = CurrentProject.path & "\"
Shell "cmd /C start """" /max """ & path & """", vbHide
where 'path' is the folder you want to open.
(In this example I open the folder where the current workbook is saved.)
Pros:
Avoids opening new explorer instances (only sets focus if window exists).
The cmd-window is never visible thanks to vbHide.
Relatively simple (does not need to reference win32 libraries).
Cons:
Window maximization (or minimization) is mandatory.
Explanation:
At first I tried using only vbHide. This works nicely... unless there is already such a folder opened, in which case the existing folder window becomes hidden and disappears! You now have a ghost window floating around in memory and any subsequent attempt to open the folder after that will reuse the hidden window - seemingly having no effect.
In other words when the 'start'-command finds an existing window the specified vbAppWinStyle gets applied to both the CMD-window and the reused explorer window. (So luckily we can use this to un-hide our ghost-window by calling the same command again with a different vbAppWinStyle argument.)
However by specifying the /max or /min flag when calling 'start' it prevents the vbAppWinStyle set on the CMD window from being applied recursively. (Or overrides it? I don't know what the technical details are and I'm curious to know exactly what the chain of events is here.)
Here is some more cool knowledge to go with this:
I had a situation where I needed to be able to find folders based on a bit of criteria in the record and then open the folder(s) that were found. While doing work on finding a solution I created a small database that asks for a search starting folder gives a place for 4 pieces of criteria and then allows the user to do criteria matching that opens the 4 (or more) possible folders that match the entered criteria.
Here is the whole code on the form:
Option Compare Database
Option Explicit
Private Sub cmdChooseFolder_Click()
Dim inputFileDialog As FileDialog
Dim folderChosenPath As Variant
If MsgBox("Clear List?", vbYesNo, "Clear List") = vbYes Then DoCmd.RunSQL "DELETE * FROM tblFileList"
Me.sfrmFolderList.Requery
Set inputFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
With inputFileDialog
.Title = "Select Folder to Start with"
.AllowMultiSelect = False
If .Show = False Then Exit Sub
folderChosenPath = .SelectedItems(1)
End With
Me.txtStartPath = folderChosenPath
Call subListFolders(Me.txtStartPath, 1)
End Sub
Private Sub cmdFindFolderPiece_Click()
Dim strCriteria As String
Dim varCriteria As Variant
Dim varIndex As Variant
Dim intIndex As Integer
varCriteria = Array(Nz(Me.txtSerial, "Null"), Nz(Me.txtCustomerOrder, "Null"), Nz(Me.txtAXProject, "Null"), Nz(Me.txtWorkOrder, "Null"))
intIndex = 0
For Each varIndex In varCriteria
strCriteria = varCriteria(intIndex)
If strCriteria <> "Null" Then
Call fnFindFoldersWithCriteria(TrailingSlash(Me.txtStartPath), strCriteria, 1)
End If
intIndex = intIndex + 1
Next varIndex
Set varIndex = Nothing
Set varCriteria = Nothing
strCriteria = ""
End Sub
Private Function fnFindFoldersWithCriteria(ByVal strStartPath As String, ByVal strCriteria As String, intCounter As Integer)
Dim fso As New FileSystemObject
Dim fldrStartFolder As Folder
Dim subfldrInStart As Folder
Dim subfldrInSubFolder As Folder
Dim subfldrInSubSubFolder As String
Dim strActionLog As String
Set fldrStartFolder = fso.GetFolder(strStartPath)
' Debug.Print "Criteria: " & Replace(strCriteria, " ", "", 1, , vbTextCompare) & " and Folder Name is " & Replace(fldrStartFolder.Name, " ", "", 1, , vbTextCompare) & " and Path is: " & fldrStartFolder.Path
If fnCompareCriteriaWithFolderName(fldrStartFolder.Name, strCriteria) Then
' Debug.Print "Found and Opening: " & fldrStartFolder.Name & "Because of: " & strCriteria
Shell "EXPLORER.EXE" & " " & Chr(34) & fldrStartFolder.Path & Chr(34), vbNormalFocus
Else
For Each subfldrInStart In fldrStartFolder.SubFolders
intCounter = intCounter + 1
Debug.Print "Criteria: " & Replace(strCriteria, " ", "", 1, , vbTextCompare) & " and Folder Name is " & Replace(subfldrInStart.Name, " ", "", 1, , vbTextCompare) & " and Path is: " & fldrStartFolder.Path
If fnCompareCriteriaWithFolderName(subfldrInStart.Name, strCriteria) Then
' Debug.Print "Found and Opening: " & subfldrInStart.Name & "Because of: " & strCriteria
Shell "EXPLORER.EXE" & " " & Chr(34) & subfldrInStart.Path & Chr(34), vbNormalFocus
Else
Call fnFindFoldersWithCriteria(subfldrInStart, strCriteria, intCounter)
End If
Me.txtProcessed = intCounter
Me.txtProcessed.Requery
Next
End If
Set fldrStartFolder = Nothing
Set subfldrInStart = Nothing
Set subfldrInSubFolder = Nothing
Set fso = Nothing
End Function
Private Function fnCompareCriteriaWithFolderName(strFolderName As String, strCriteria As String) As Boolean
fnCompareCriteriaWithFolderName = False
fnCompareCriteriaWithFolderName = InStr(1, Replace(strFolderName, " ", "", 1, , vbTextCompare), Replace(strCriteria, " ", "", 1, , vbTextCompare), vbTextCompare) > 0
End Function
Private Sub subListFolders(ByVal strFolders As String, intCounter As Integer)
Dim dbs As Database
Dim fso As New FileSystemObject
Dim fldFolders As Folder
Dim fldr As Folder
Dim subfldr As Folder
Dim sfldFolders As String
Dim strSQL As String
Set fldFolders = fso.GetFolder(TrailingSlash(strFolders))
Set dbs = CurrentDb
strSQL = "INSERT INTO tblFileList (FilePath, FileName, FolderSize) VALUES (" & Chr(34) & fldFolders.Path & Chr(34) & ", " & Chr(34) & fldFolders.Name & Chr(34) & ", '" & fldFolders.Size & "')"
dbs.Execute strSQL
For Each fldr In fldFolders.SubFolders
intCounter = intCounter + 1
strSQL = "INSERT INTO tblFileList (FilePath, FileName, FolderSize) VALUES (" & Chr(34) & fldr.Path & Chr(34) & ", " & Chr(34) & fldr.Name & Chr(34) & ", '" & fldr.Size & "')"
dbs.Execute strSQL
For Each subfldr In fldr.SubFolders
intCounter = intCounter + 1
sfldFolders = subfldr.Path
Call subListFolders(sfldFolders, intCounter)
Me.sfrmFolderList.Requery
Next
Me.txtListed = intCounter
Me.txtListed.Requery
Next
Set fldFolders = Nothing
Set fldr = Nothing
Set subfldr = Nothing
Set dbs = Nothing
End Sub
Private Function TrailingSlash(varIn As Variant) As String
If Len(varIn) > 0& Then
If Right(varIn, 1&) = "\" Then
TrailingSlash = varIn
Else
TrailingSlash = varIn & "\"
End If
End If
End Function
The form has a subform based on the table, the form has 4 text boxes for the criteria, 2 buttons leading to the click procedures and 1 other text box to store the string for the start folder. There are 2 text boxes that are used to show the number of folders listed and the number processed when searching them for the criteria.
If I had the Rep I would post a picture... :/
I have some other things I wanted to add to this code but haven't had the chance yet. I want to have a way to store the ones that worked in another table or get the user to mark them as good to store.
I can not claim full credit for all the code, I cobbled some of it together from stuff I found all around, even in other posts on stackoverflow.
I really like the idea of posting questions here and then answering them yourself because as the linked article says, it makes it easy to find the answer for later reference.
When I finish the other parts I want to add I will post the code for that too. :)
You can use command prompt to open explorer with path.
here example with batch or command prompt:
start "" explorer.exe (path)
so In VBA ms.access you can write with:
Dim Path
Path="C:\Example"
shell "cmd /c start """" explorer.exe " & Path ,vbHide
Here is what I did.
Dim strPath As String
strPath = "\\server\Instructions\"
Shell "cmd.exe /c start """" """ & strPath & """", vbNormalFocus
Pros:
Avoids opening new explorer instances (only sets focus if window
exists).
Relatively simple (does not need to reference win32 libraries).
Window maximization (or minimization) is not mandatory. Window will open with normal size.
Cons:
The cmd-window is visible for a short time.
This consistently opens a window to the folder if there is none open and switches to the open window if there is one open to that folder.
Thanks to PhilHibbs and AnorZaken for the basis for this. PhilHibbs comment didn't quite work for me, I needed to the command string to have a pair of double quotes before the folder name. And I preferred having a command prompt window appear for a bit rather than be forced to have the Explorer window maximized or minimized.
I may not use shell command because of security in the company so the best way I found on internet.
Sub OpenFileOrFolderOrWebsite()
'Shows how to open files and / or folders and / or websites / or create emails using the FollowHyperlink method
Dim strXLSFile As String, strPDFFile As String, strFolder As String, strWebsite As String
Dim strEmail As String, strSubject As String, strEmailHyperlink As String
strFolder = "C:\Test Files\"
strXLSFile = strFolder & "Test1.xls"
strPDFFile = strFolder & "Test.pdf"
strWebsite = "http://www.blalba.com/"
strEmail = "mailto:YourEmailHere#Website.com"
strSubject = "?subject=Test"
strEmailHyperlink = strEmail & strSubject
'**************FEEL FREE TO COMMENT ANY OF THESE TO TEST JUST ONE ITEM*********
'Open Folder
ActiveWorkbook.FollowHyperlink Address:=strFolder, NewWindow:=True
'Open excel workbook
ActiveWorkbook.FollowHyperlink Address:=strXLSFile, NewWindow:=True
'Open PDF file
ActiveWorkbook.FollowHyperlink Address:=strPDFFile, NewWindow:=True
'Open VBAX
ActiveWorkbook.FollowHyperlink Address:=strWebsite, NewWindow:=True
'Create New Email
ActiveWorkbook.FollowHyperlink Address:=strEmailHyperlink, NewWindow:=True
'******************************************************************************
End Sub
so actually its
strFolder = "C:\Test Files\"
and
ActiveWorkbook.FollowHyperlink Address:=strFolder, NewWindow:=True
Shell "C:\WINDOWS\explorer.exe /select,""" & ActiveWorkbook.Name & "", vbNormalFocus
Here's an answer that gives the switch-or-launch behaviour of Start, without the Command Prompt window. It does have the drawback that it can be fooled by an Explorer window that has a folder of the same name elsewhere opened. I might fix that by diving into the child windows and looking for the actual path, I need to figure out how to navigate that.
Usage (requires "Windows Script Host Object Model" in your project's References):
Dim mShell As wshShell
mDocPath = whatever_path & "\" & lastfoldername
mExplorerPath = mShell.ExpandEnvironmentStrings("%SystemRoot%") & "\Explorer.exe"
If Not SwitchToFolder(lastfoldername) Then
Shell PathName:=mExplorerPath & " """ & mDocPath & """", WindowStyle:=vbNormalFocus
End If
Module:
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
(ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" _
(ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" _
(ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function BringWindowToTop Lib "user32" _
(ByVal lngHWnd As Long) As Long
Function SwitchToFolder(pFolder As String) As Boolean
Dim hWnd As Long
Dim mRet As Long
Dim mText As String
Dim mWinClass As String
Dim mWinTitle As String
SwitchToFolder = False
hWnd = FindWindowEx(0, 0&, vbNullString, vbNullString)
While hWnd <> 0 And SwitchToFolder = False
mText = String(100, Chr(0))
mRet = GetClassName(hWnd, mText, 100)
mWinClass = Left(mText, mRet)
If mWinClass = "CabinetWClass" Then
mText = String(100, Chr(0))
mRet = GetWindowText(hWnd, mText, 100)
If mRet > 0 Then
mWinTitle = Left(mText, mRet)
If UCase(mWinTitle) = UCase(pFolder) Or _
UCase(Right(mWinTitle, Len(pFolder) + 1)) = "\" & UCase(pFolder) Then
BringWindowToTop hWnd
SwitchToFolder = True
End If
End If
End If
hWnd = FindWindowEx(0, hWnd, vbNullString, vbNullString)
Wend
End Function
Private Sub Command0_Click()
Application.FollowHyperlink "D:\1Zsnsn\SusuBarokah\20151008 Inventory.mdb"
End Sub
I just used this and it works fine:
System.Diagnostics.Process.Start("C:/Users/Admin/files");
Thanks to many of the answers above and elsewhere, this was my solution to a similar problem to the OP. The problem for me was creating a button in Word that asks the user for a network address, and pulls up the LAN resources in an Explorer window.
Untouched, the code would take you to \\10.1.1.1\Test, so edit as you see fit. I'm just a monkey on a keyboard, here, so all comments and suggestions are welcome.
Private Sub CommandButton1_Click()
Dim ipAddress As Variant
On Error GoTo ErrorHandler
ipAddress = InputBox("Please enter the IP address of the network resource:", "Explore a network resource", "\\10.1.1.1")
If ipAddress <> "" Then
ThisDocument.FollowHyperlink ipAddress & "\Test"
End If
ExitPoint:
Exit Sub
ErrorHandler:
If Err.Number = "4120" Then
GoTo ExitPoint
ElseIf Err.Number = "4198" Then
MsgBox "Destination unavailable"
GoTo ExitPoint
End If
MsgBox "Error " & Err.Number & vbCrLf & Err.Description
Resume ExitPoint
End Sub
I have a subroutine in my errorhandling function that attempts to close every workbook open in every instance of Excel. Otherwise, it might stay in memory and break my next vbscript. It should also close every workbook without saving any changes.
Sub CloseAllExcel()
On Error Resume Next
Dim ObjXL As Excel.Application
Set ObjXL = GetObject(, "Excel.Application")
If Not (ObjXL Is Nothing) Then
Debug.Print "Closing XL"
ObjXL.Application.DisplayAlerts = False
ObjXL.Workbooks.Close
ObjXL.Quit
Set ObjXL = Nothing
Else
Debug.Print "XL not open"
End If
End Sub
This code isn't optimal, however. For example, it can close 2 workbooks in one instance of Excel, but if you open 2 instances of excel, it will only close out 1.
How can I rewrite this to close all Excel without saving any changes?
Extra Credit:
How to do this for Access as well without closing the Access file that is hosting this script?
You should be able to use window handles for this.
Public Sub CloseAllOtherAccess()
Dim objAccess As Object
Dim lngMyHandle As Long
Dim strMsg As String
On Error GoTo ErrorHandler
lngMyHandle = Application.hWndAccessApp
Set objAccess = GetObject(, "Access.Application")
Do While TypeName(objAccess) = "Application"
If objAccess.hWndAccessApp <> lngMyHandle Then
Debug.Print "found another Access instance: " & _
objAccess.hWndAccessApp
objAccess.Quit acQuitSaveNone
Else
Debug.Print "found myself"
Exit Do
End If
Set objAccess = GetObject(, "Access.Application")
Loop
ExitHere:
Set objAccess = Nothing
On Error GoTo 0
Exit Sub
ErrorHandler:
strMsg = "Error " & Err.Number & " (" & Err.Description _
& ") in procedure CloseAllOtherAccess"
MsgBox strMsg
GoTo ExitHere
End Sub
It appears to me GetObject returns the "oldest" Access instance. So that sub closes all Access instances started before the one which is running the sub. Once it finds itself, it stops. Maybe that's fine for your situation. But if you need to also close Access instances started after the one which is running the code, look to Windows API window handle functions.
I didn't try this approach for Excel. But I did see Excel provides Application.Hwnd and Application.Hinstance ... so I suspect you can do something similar there.
Also, notice I got rid of On Error Resume Next. GetObject will always return an Application object in this sub, so it didn't serve any purpose. Additionally, I try to avoid On Error Resume Next in general.
Update: Since GetObject won't do the job for you, use a different method to get the window handles of all the Access instances. Close each of them whose window handle doesn't match the one you want to leave running (Application.hWndAccessApp).
Public Sub CloseAllAccessExceptMe()
'FindWindowLike from: '
'How To Get a Window Handle Without Specifying an Exact Title '
'http://support.microsoft.com/kb/147659 '
'ProcessTerminate from: '
'Kill a Process through VB by its PID '
'http://en.allexperts.com/q/Visual-Basic-1048/Kill-Process-VB-its-1.htm '
Dim lngMyHandle As Long
Dim i As Long
Dim hWnds() As Long
lngMyHandle = Application.hWndAccessApp
' get array of window handles for all Access top level windows '
FindWindowLike hWnds(), 0, "*", "OMain", Null
For i = 1 To UBound(hWnds())
If hWnds(i) = lngMyHandle Then
Debug.Print hWnds(i) & " -> leave myself running"
Else
Debug.Print hWnds(i) & " -> close this one"
ProcessTerminate , hWnds(i)
End If
Next i
End Sub
Differentiating open instances of an application is a very old problem, and it is not unique to VBA.
I've tried to figure this out myself over the years, never with greater success than the time before.
I think the long and short of it is that you can never know if the application instance you're referencing is the one in which the code is executing (so terminating it might leave other instances open).
I just tried the following with both Excel and Access :
Dim sKill As String
sKill = "TASKKILL /F /IM msaccess.exe"
Shell sKill, vbHide
If you change the msaccess.exe to excel.exe, excel will be killed.
If you want a bit more control over the process, check out:
http://www.vbaexpress.com/kb/getarticle.php?kb_id=811
I know this is an old post but for those who visit here from searches may find it helpful.
This code was found and modified. It will give you every SHEET in every WORKBOOK in every INSTANCE. From there you can determine the active instance.
Module..............
Declare Function FindWindowEx Lib "User32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Declare Function GetClassName Lib "User32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Declare Function IIDFromString Lib "ole32" (ByVal lpsz As Long, ByRef lpiid As UUID) As Long
Declare Function AccessibleObjectFromWindow Lib "oleacc" (ByVal hWnd As Long, ByVal dwId As Long, ByRef riid As UUID, ByRef ppvObject As Object) As Long
Type UUID 'GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Code…………………...
Const IID_IDispatch As String = "{00020400-0000-0000-C000-000000000046}"
Const OBJID_NATIVEOM As Long = &HFFFFFFF0
Sub ListAll()
Dim I As Integer
Dim hWndMain As Long
On Error GoTo MyErrorHandler
hWndMain = FindWindowEx(0&, 0&, "XLMAIN", vbNullString)
I = 1
Do While hWndMain <> 0
Debug.Print "Excel Instance " & I
GetWbkWindows hWndMain
hWndMain = FindWindowEx(0&, hWndMain, "XLMAIN", vbNullString)
I = I + 1
Loop
Exit Sub
MyErrorHandler:
MsgBox "GetAllWorkbookWindowNames" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description
End Sub
Sub GetWbkWindows(ByVal hWndMain As Long)
Dim hWndDesk As Long
Dim hWnd As Long
Dim strText As String
Dim lngRet As Long
On Error GoTo MyErrorHandler
hWndDesk = FindWindowEx(hWndMain, 0&, "XLDESK", vbNullString)
If hWndDesk <> 0 Then
hWnd = FindWindowEx(hWndDesk, 0, vbNullString, vbNullString)
Do While hWnd <> 0
strText = String$(100, Chr$(0))
lngRet = GetClassName(hWnd, strText, 100)
If Left$(strText, lngRet) = "EXCEL7" Then
GetExcelObjectFromHwnd hWnd
Exit Sub
End If
hWnd = FindWindowEx(hWndDesk, hWnd, vbNullString, vbNullString)
Loop
On Error Resume Next
End If
Exit Sub
MyErrorHandler:
MsgBox "GetWbkWindows" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description
End Sub
Function GetExcelObjectFromHwnd(ByVal hWnd As Long) As Boolean
Dim fOk As Boolean
Dim I As Integer
Dim obj As Object
Dim iid As UUID
Dim objApp As Excel.Application
Dim myWorksheet As Worksheet
On Error GoTo MyErrorHandler
fOk = False
Call IIDFromString(StrPtr(IID_IDispatch), iid)
If AccessibleObjectFromWindow(hWnd, OBJID_NATIVEOM, iid, obj) = 0 Then 'S_OK
Set objApp = obj.Application
For I = 1 To objApp.Workbooks.Count
Debug.Print " " & objApp.Workbooks(I).Name
For Each myWorksheet In objApp.Workbooks(I).Worksheets
Debug.Print " " & myWorksheet.Name
DoEvents
Next
fOk = True
Next I
End If
GetExcelObjectFromHwnd = fOk
Exit Function
MyErrorHandler:
MsgBox "GetExcelObjectFromHwnd" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description
End Function
I hope this helps someone :)
This is a response to an old post, but same as the poster in 2012, hopefully it helps someone who may come here based on a generic web search.
Background
My company uses XLSX "models" to turn our data into "pretty" automatically. The data exports from SAS as XLS; we do not have the licensing or add-ons to export as XLSX. The normal process is to copy/paste each of the 14 SAS outputs into the XLSX. The code below iterates through the first two exports where data is copied from the XLS, pasted into the XLSX, and the XLS closed.
Please note: The XLSX file is saved to the hard drive. The XLS files are NOT SAVED, i.e. the path goes to "My Documents/" but there is no file name or file visible there.
Sub Get_data_from_XLS_to_XLSX ()
Dim xlApp1 As Excel.Application
Dim xlApp2 As Excel.Application
'Speed up processing by turning off Automatic Calculations and Screen Updating
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
'Copies data from Book1 (xls) and pastes into ThisWorkbook (xlsx), then closes xls file
Set xlApp1 = GetObject("Book1").Application
xlApp1.Workbooks("Book1").Sheets("Sheet1").Range("A2:E2").Copy
Application.ThisWorkbook.Worksheets("Data1").Cells(5, 2).PasteSpecialPaste:=xlPasteValues
'Clears the clipboard, turns off the "do you want to save" alert, closes xls file
xlApp1.CutCopyMode = False
xlApp1.DisplayAlerts = False
xlApp1.Quit
xlApp1.DisplayAlerts = True
'Same as the first one above, but now it's a second/different xls file, i.e. Book2
Set xlApp2 = GetObject("Book2").Application
xlApp2.Workbooks("Book2").Sheets("Sheet1").Range("A2:E2").Copy
Application.ThisWorkbook.Sheets("Data2").Cells(10, 2).PasteSpecial Paste:=xlPasteValues
'Clears the clipboard, turns off the "do you want to save" alert, closes xls file
xlApp2.CutCopyMode = False
xlApp2.DisplayAlerts = False
xlApp2.Quit
xlApp2.DisplayAlerts = True
'Sub continues for 12 more iterations of similar code
End Sub
You need to be explicit in qualifying your statements. i.e. instead of Workbooks("Book_Name") make sure you identify the application you are referring to, be it Application.Workbooks("Book_Name") or xlApp1.Workbooks("Book_Name")
try putting it in a loop
Set ObjXL = GetObject(, "Excel.Application")
do until ObjXL Is Nothing
Debug.Print "Closing XL"
ObjXL.Application.DisplayAlerts = False
ObjXL.Workbooks.Close
ObjXL.Quit
Set ObjXL = Nothing
Set ObjXL = GetObject(, "Excel.Application") ' important!
loop