I have a database and when it opens code runs which hides everything in Access apart from a form.
This looks great for the user but I believe this is preventing me from displaying Reports in acViewPreview view.
If I prevent the On Load code from running then I am able to view reports in acViewPreview view.
I do not fully understand the code that hides everything on the form On Load event (I copied it years ago and it worked but I cannot recall from where so cannot credit the actual creator).
The code that hides Access:
Private Sub Form_Load()
Call fSetAccessWindow(0)
End Sub
Option Compare Database
Option Explicit
Global Const SW_HIDE = 0
Global Const SW_SHOWNORMAL = 1
Global Const SW_SHOWMINIMIZED = 2
Global Const SW_SHOWMAXIMIZED = 3
Private Declare Function apiShowWindow Lib "user32" _
Alias "ShowWindow" (ByVal hwnd As Long, _
ByVal nCmdShow As Long) As Long
Function fSetAccessWindow(nCmdShow As Long)
Dim loX As Long
Dim loForm As Form
On Error Resume Next
Set loForm = Screen.ActiveForm
If Err <> 0 Then
loX = apiShowWindow(hWndAccessApp, nCmdShow)
Err.Clear
End If
If nCmdShow = SW_SHOWMINIMIZED And loForm.Modal = True Then
MsgBox "Cannot minimize Access with " _
& (loForm.Caption + " ") _
& "form on screen"
ElseIf nCmdShow = SW_HIDE And loForm.PopUp <> True Then
MsgBox "Cannot hide Access with " _
& (loForm.Caption + " ") _
& "form on screen"
Else
loX = apiShowWindow(hWndAccessApp, nCmdShow)
End If
fSetAccessWindow = (loX <> 0)
End Function
How do I either temporarily reverse/disable the On Load code but only when a Report is run or perhaps there is an alternative way of viewing the Report that would work whilst Access is hidden by the On Load code?
Comment out the code line (the single-quote) to prevent the call of the function:
Private Sub Form_Load()
' Call fSetAccessWindow(0)
End Sub
or call it to "show the window normal":
Private Sub Form_Load()
Call fSetAccessWindow(1)
End Sub
I've been trying to set a outlook task item through Access and replace a runtime error 440 with a custom message.
This error popped when a certain field (me.dueBy) was empty.
Currently the code I have is successful with creating a task for records with dueBy data, but when I click on the button for a record with no due date, then nothing happens. No message box, no error, nothing.
I just need a message box telling me that I require a due date to set a task when that field is empty.
Private Sub Command15_Click()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim DataErr As Integer
Dim Response As Integer
On Error GoTo err_handler
Set db = CurrentDb
Set rs = db.OpenRecordset("tblActions")
Set outLookApp = CreateObject("outlook.application")
Set OutlookTask = outLookApp.CreateItem(olTaskItem)
With OutlookTask
.Subject = "Action Due Date: " & Me.dueBy & " for Contract ID " & Me.contractID
.Body = "Due date for Action: < " & Me.actionNote & " > is " & Me.dueBy & "."
.ReminderSet = True
.ReminderTime = Me.dueBy + TimeValue("8:00:00 AM")
.Save
End With
MsgBox "Action Task has been set in Outlook successfully."
exit_err_handler: Exit Sub
err_handler:
If DataErr = 440 Then
Response = acDataErrContinue
MsgBox "Due date is required.", vbOKOnly, "Due date Error"
End If
Resume exit_err_handler
Set rs = Nothing
Set db = Nothing
End Sub
DataErr and Response are arguments to the Form_Error-Event. They have no effect in error handling in general. In your procedure DataErr is simply an integer variable and will always have the value 0 unless you explicitly assign another value.
You need to check for Err.Number in the error handler to identify specific error conditions.
I have an access report that updates 4 image controls based on a table that is sourcing images from a directory. The report generates a page per record, however the image controls are not changing after page 1 (just showing same images for all the other pages). Appartently, the code worked fine on Windows XP and now does not work on Windows 7 OS (both used Office 07). Here is the code:
Private Sub Report_Current()
UpdateImages
End Sub
Private Sub Report_Load()
UpdateImages
End Sub
Private Sub Report_Page()
UpdateImages
End Sub
Private Sub UpdateImages()
On Error GoTo errHandler
Dim RS As DAO.Recordset
Set RS = CurrentDb.OpenRecordset("SELECT Image_Loc, Image_Name FROM HH_Media WHERE InspectionID = " & CInt(Me.InspectionID.Value) & " ORDER BY MediaID ASC")
If Not RS.BOF And Not RS.EOF Then
Dim i As Integer
For i = 1 To 4
If Not RS.EOF Then
Dim pictureCtrl As Image
Set pictureCtrl = GetControl("Image" & i)
Dim strImage As String
strImage = RS.Fields("Image_Loc").Value & "\" & RS.Fields("Image_Name").Value
If Not pictureCtrl Is Nothing Then
If FileExists(strImage) Then
pictureCtrl.Picture = strImage
SetLabel "lblImage" & i, RS.Fields("Image_Name").Value
Else
pictureCtrl.Picture = ""
SetLabel "lblImage" & i, "Does not exist"
End If
End If
RS.MoveNext
Else
Exit For
End If
Next
End If
RS.Close
Set RS = Nothing
Exit Sub
errHandler:
MsgBox "An error occurred while updating the form display." & vbNewLine & Err.Description, vbApplicationModal + vbCritical + vbDefaultButton1 + vbOKOnly, Me.Name
Resume Next
End Sub
The images do exist in the directory that are referenced in the table. Any ideas of what is missing?
Thank You
Whenever I need to do some dynamic content I always use the [section]_Format event - so if your controls are on the Detail section then:
Private Sub Detail_Format(Cancel As Integer, FormatCount As Integer)
If FormatCount = 1 then 'only need to do this once per record
UpdateImages
Endif
End Sub
I've never seen the GetControl method, and I don't have a lot of experience using the Image control, but it seems like that the Dim statement should read more like:
Dim pictureCtrl as Control
Set pictureCtrl = Me.Controls("Image" & i)
I would insert a break and verify that
strImage = RS.Fields("Image_Loc").Value & "\" & RS.Fields("Image_Name").Value
is returning values you expect. You can also shorten these to:
strImage = rs!Image_Loc & "\" & rs!Image_Name
sometimes Access doesn't like the added ".value" as this is already the default return.
Variety of ways to get a list of report names:
Query
SELECT [Name] FROM MsysObjects
WHERE ([Type] = -32764)
Or VBA
Dim rpt As AccessObject
Dim dB As Object
On Error GoTo Error_Handler
Set dB = Application.CurrentProject
For Each rpt In dB.AllReports
Debug.Print rpt.Name
Next rpt
A report can have a Description under the Properties (Right-Click on report object), but I cannot access with code.
I'd like to have a listbox display a user-friendly report name associated with the actual report name. I'm trying to avoid creating a separate table to manage this at this point.
CurrentProject is an ADO object, and I don't know how to do what you want from ADO. You can use DAO to retrieve the Description property.
? CurrentDb.Containers("Reports").Documents("rptFoo").Properties("Description")
Foo Report
Since Description is a user-defined property, it doesn't exist until you assign a value for it. Therefore the next line triggers error 3270 (Property not found) for rptLinks, since it doesn't have a Description assigned.
? CurrentDb.Containers("Reports").Documents("rptLinks").Properties("Description")
You could trap that error. Or see if you can make use of Allen Browne's HasProperty function
A totally different approach would be to create tblReports with report_name and friendly_name fields. You would have to maintain that table, but the workload should be roughly equivalent to maintaining the Description properties on the report objects. Then you could use a simple SELECT on the table as the RowSource for your list box.
Update: You could also SELECT from MSysObjects with a custom function to return the Description for each report.
Public Function ReportDescription(ByVal pName As String) As String
Dim strReturn As String
Dim strMsg As String
On Error GoTo ErrorHandler
strReturn = _
CurrentDb.Containers("Reports").Documents(pName).Properties("Description")
ExitHere:
On Error GoTo 0
ReportDescription = strReturn
Exit Function
ErrorHandler:
Select Case Err.Number
Case 3270 'Property not found.'
'strReturn = "(no Description)"'
'* no Description -> just echo report name *'
strReturn = pName
Case Else
strMsg = "Error " & Err.Number & " (" & Err.description _
& ") in procedure ReportDescription"
MsgBox strMsg
strReturn = vbNullString
End Select
GoTo ExitHere
End Function
Revise your original query to use the function.
SELECT
[Name] AS report_name,
ReportDescription([Name]) AS friendly_name
FROM MsysObjects
WHERE ([Type] = -32764);
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