I'm trying to call an event when the user returns focus to the Access application when a specific form is open. The following event doesn't seem to fire up at all.
Private Sub Form_GotFocus()
Call crtListDirectory
End Sub
Does any body have any ideas as to how I could trigger this event to happen, and when/how does the Form_GotFocus event actually get triggered.
thanks in advance for any help
Noel
Access help:
A form can get the focus only if all
visible controls on a form are
disabled, or there are no controls on
the form.
You might like to try Activate.
EDIT re Comments
The only way I can see of doing what you seem to want is with APIs, which is somewhat messy. To demonstrate this you will need a form with two controls Text0 and Text2 (these are the default names). Set the Timer Interval to something suitable, say 2000, and the Timer Event to:
Private Sub Form_Timer()
Dim lngWin As Long
Dim s As String
'This is just a counter to show that the code is running
Me.Text2 = Nz(Me.Text2, 0) + 1
'API
lngWin = GetActiveWindow()
s = GetWinName(lngWin)
If s = "Microsoft Access" Then
If Me.Text0 = "Lost Focus" Then
Me.Text0 = "Focus returned"
End If
Else
Me.Text0 = "Lost Focus"
End If
End Sub
You will now need a module for:
Option Compare Database
Declare Function GetActiveWindow Lib "user32" () As Integer
Declare Function GetWindowText Lib "user32.dll" Alias _
"GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As _
String, ByVal cch As Long) As Long
Declare Function GetWindowTextLength Lib "user32" Alias _
"GetWindowTextLengthA" (ByVal hwnd As Long) As Long
Function GetWinName(hw As Long)
Dim lngText As Long ' receives length of text of title bar
Dim strWinName As String ' receives the text of the title bar
Dim lngWinText As Long ' receives the length of the returned string
lngText = GetWindowTextLength(hw)
strWinName = Space(lngText + 1)
lngWinText = GetWindowText(hw, strWinName, lngText + 1)
strWinName = Left(strWinName, lngWinText)
GetWinName = strWinName
End Function
This is all very, very rough, but it gives you something to mess about with.
Related
I tried to follow up with the topic here:
How to connect to OPEN workbook in another instance of Excel
But I ran into a problem,
I am not able grab the new instance name or path.
However I know I have open Excel window in another instance (opened from a SAP system) and when I open VBA editor in that SAP generated Excel file and I type: ? Thisworkbook.Path in immediate window I get nothing, no path is given and thus this solutions does not get the instance path.
What can I do to make it work ?
My issue is that this: Set xlApp = GetObject("C:\Tmp\TestData2.xlsx") is not grabbing the workbook name (including This.workbook.name or activeworkbook.name)
Any idea how else I can make VBA code in instance 1 work with workbook in instance 2?
I only want to save it nothing more, I'm using Saveas option, or at least I try.
Have anyone had a similar issue?
Working with the Excel files downloaded from SAP is always problematic.
You can use the module below and add before the xls.Close SaveChanges:=False this line xls.SaveAs Filename:='Any name that you want after that just place a call in your code after downloading the Excel File with
Call Close_SAP_Excel("TestData2.xlsx")
And it should work fine.
Module:
#If VBA7 Then
Private Declare PtrSafe Function AccessibleObjectFromWindow Lib "oleacc" ( _
ByVal hwnd As LongPtr, ByVal dwId As Long, riid As Any, ppvObject As Object) As Long
Private Declare PtrSafe Function FindWindowExA Lib "user32" ( _
ByVal hwndParent As LongPtr, ByVal hwndChildAfter As LongPtr, _
ByVal lpszClass As String, ByVal lpszWindow As String) As LongPtr
#Else
Private Declare Function AccessibleObjectFromWindow Lib "oleacc" ( _
ByVal hwnd As Long, ByVal dwId As Long, riid As Any, ppvObject As Object) As Long
Private Declare Function FindWindowExA Lib "user32" ( _
ByVal hwndParent As Long, ByVal hwndChildAfter As Long, _
ByVal lpszClass As String, ByVal lpszWindow As String) As Long
#End If
Sub Close_SAP_Excel(ParamArray FileNames())
'Procedure to close files downloaded from SAP and at the same time close the Excel application instance that will be open with them.
Dim ExcelAppSAP As Variant
Dim ExcelFile As Variant
Dim FinishedLoop As Boolean, TimeoutReached As Boolean, FileClosed As Boolean
Dim ReTry As Long
Dim i As Long, x As Long
Set ExcelAppSAP = Nothing
ReTry = 100000 'Used as Timeout 100000 = ~10 seconds
i = 1
'The following loop is executed until excel file is closed.
'Inside of this, there is a For Loop for each Excel Instance and inside of that is another loop
'for each excel inside the instance. If name matches, it is closed.
Do While Not FinishedLoop
If i > ReTry Then
TimeoutReached = True
Exit Do
End If
For Each ExcelFile In GetExcelInstances() 'Function to Get Excel Open Instances
For Each xls In ExcelFile.Workbooks
For x = LBound(FileNames()) To UBound(FileNames())
If xls.Name = FileNames(x) Then
Set ExcelAppSAP = ExcelFile 'Set Instance opened by SAP to variable
'Here add actions if needed. Reference to workbook as xls e.g.: xls.Sheets(1).Range("A1").Copy
xls.Close SaveChanges:=False
FileClosed = True
End If
Next x
Next
Next
If FileClosed Then
FinishedLoop = True
End If
i = i + 1
Loop
ThisWorkbook.Activate
If Not TimeoutReached Then
If FileClosed Then
On Error Resume Next
If ExcelAppSAP.Workbooks.Count = 0 Then
ExcelAppSAP.Quit
End If
Else
MsgBox "Excel application instance from SAP was not closed correctly. Please close it manually or try again.", , "Error"
End If
Else
MsgBox "Max timeout reached", , "Error"
End If
End Sub
Public Function GetExcelInstances() As Collection
Dim guid&(0 To 3), acc As Object, hwnd, hwnd2, hwnd3
guid(0) = &H20400
guid(1) = &H0
guid(2) = &HC0
guid(3) = &H46000000
Set GetExcelInstances = New Collection
Do
hwnd = FindWindowExA(0, hwnd, "XLMAIN", vbNullString)
If hwnd = 0 Then Exit Do
hwnd2 = FindWindowExA(hwnd, 0, "XLDESK", vbNullString)
hwnd3 = FindWindowExA(hwnd2, 0, "EXCEL7", vbNullString)
If AccessibleObjectFromWindow(hwnd3, &HFFFFFFF0, guid(0), acc) = 0 Then
GetExcelInstances.Add acc.Application
End If
Loop
End Function
I have some controls in MS Access form that change the system language to Turkish, Arabic and English and I want to change the system language to English when I go to VBA to write some code.
I have a code that change system language and want to know
How to run this code automatically when I activate VBA editor?
If you put the following code on start of your application, it would run automatically Test2, whenever you press Alt+F11.
Private Sub Workbook_Open()
Application.OnKey "%{F11}", "Test2"
End Sub
Public Sub Test2()
Debug.Print "tested"
End Sub
I am not sure whether this is exactly what you want, but it is a work around to achieve it.
Edit:
Actually, here you may find plenty of useful stuff:
http://www.mrexcel.com/forum/excel-questions/468063-determine-language-user.html
E.g. With the Sub ShowLanguages you may built a function telling you which language are you using and if it is not English, you may switch to it, the way you do it in your answer. I would probably built something similar later.
Private Const LOCALE_ILANGUAGE As Long = &H1
Private Const LOCALE_SCOUNTRY As Long = &H6
Private Declare Function GetKeyboardLayout Lib "user32" _
(ByVal dwLayout As Long) As Long
Private Declare Function GetLocaleInfo Lib "kernel32" _
Alias "GetLocaleInfoA" _
(ByVal Locale As Long, _
ByVal LCType As Long, _
ByVal lpLCData As String, _
ByVal cchData As Long) As Long
Public Sub ShowLangauges()
Dim hKeyboardID As Long
Dim LCID As Long
hKeyboardID = GetKeyboardLayout(0&)
If hKeyboardID > 0 Then
LCID = LoWord(hKeyboardID)
Debug.Print GetUserLocaleInfo(LCID, LOCALE_ILANGUAGE)
Debug.Print GetUserLocaleInfo(LCID, LOCALE_SCOUNTRY)
End If
End Sub
Private Function LoWord(wParam As Long) As Integer
If wParam And &H8000& Then
LoWord = &H8000& Or (wParam And &H7FFF&)
Else
LoWord = wParam And &HFFFF&
End If
End Function
Public Function GetUserLocaleInfo(ByVal dwLocaleID As Long, _
ByVal dwLCType As Long) As String
Dim sReturn As String
Dim nSize As Long
nSize = GetLocaleInfo(dwLocaleID, dwLCType, sReturn, Len(sReturn))
If nSize > 0 Then
sReturn = Space$(nSize)
nSize = GetLocaleInfo(dwLocaleID, dwLCType, sReturn, Len(sReturn))
If nSize > 0 Then
GetUserLocaleInfo = Left$(sReturn, nSize - 1)
End If
End If
End Function
I use Timer to check if VBA editor window is the active window every 0.5 Sec and if true I run my function that change the language to English and stop Timer:
Private Sub Form_Timer()
Dim st As String
On Error Resume Next
st = VBE.ActiveWindow.Caption
If Err = 0 Then
ChLng 1033
Me.TimerInterval = 0
End If
On Error GoTo 0
End Sub
And I run Timer again when any control on my form change the language to non English language:
Private Sub cmbAR_GotFocus()
ChLng 1025
Me.TimerInterval = 500
End Sub
Private Sub cmbTR_GotFocus()
ChLng 1055
Me.TimerInterval = 500
End Sub
In Form design I manually add all needed events including Form Load event that run the Timer:
Private Sub Form_Load()
Me.TimerInterval = 500
End Sub
NOTE: ChLng xxxx is the function that change the language:
(Find your desired language at BCP 47 Code)
Private Declare Function ActivateKeyboardLayout Lib _
"user32.dll" (ByVal myLanguage As Long, Flag As Boolean) As Long
'define your desired keyboardlanguage
Sub ChLng(lng As Long)
ActivateKeyboardLayout lng, 0
End Sub
I have some code that I want to fire when the user physically prints the report. Not when Print Previewing, etc, but only when sending to the printer. The user needs to be able to pull up the report and view it, then if they decide to print, the vba code will take over and write some info to a different table than is being used to generate the report. I was hoping not to have to place a Print button on the actual report (even though I know I can hide it for the print), so I was wondering if I could somehow trap the Print dialog instead.
Has anyone ever had any luck doing so?
After much consideration, I think the best way to accomplish this is by identifying the Active Window text during the report Page event. During a print preview, this text will be the name of the database itself, something like "Microsoft Access - DatabaseName : Database (Access 2003). During a real printing operation, the active window will be "Printing"
I credit most of the code as coming from this source.
Declare Function GetActiveWindow Lib "user32" () As Long
Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" _
(ByVal Hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Sub Report_Page()
On Error GoTo PrintError
Dim strCaption As String
Dim lngLen As Long
' Create string filled with null characters.
strCaption = String$(255, vbNullChar)
' Return length of string.
lngLen = Len(strCaption)
' Call GetActiveWindow to return handle to active window,
' and pass handle to GetWindowText, along with string and its length.
If (GetWindowText(GetActiveWindow, strCaption, lngLen) > 0) Then
' Return value that Windows has written to string.
ActiveWindowCaption = strCaption
End If
If ActiveWindowCaption = "Printing" Then
'
' Special activity goes here.
'
End If
Exit Sub
PrintError:
' Just in case
End Sub
I got this code for measuring the time of a query in Access database. Every time I try to run it, I get syntax error and MyTest() line is highlighted.
Option Compare Database
Option Explicit
Private Declare Function timeGetTime _
Lib "winmm.dll" () As Long
Private mlngStartTime As Long
Private Function ElapsedTime() As Long
ElapsedTime = timeGetTime() - mlngStartTime
End Function
Private Sub StartTime()
mlngStartTime = timeGetTime()
End Sub
Public Function MyTest()
Call StartTime
DoCmd.OpenQuery "Query1"
DoCmd.GoToRecord acDataQuery, "Query1", acLast
Debug.Print ElapsedTime() & _
Call StartTime
DoCmd.OpenQuery "Query2"
DoCmd.GoToRecord acDataQuery, "Query2", acLast
Debug.Print ElapsedTime() & _
End Function
Here's another alternative (old VB6/VBA - not VB.Net syntax).
KEY SUGGESTION: the "_" characters are "continuation lines". I honestly don't think you want them in most of the places you're using them.
IMHO...
Option Explicit
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Private startTime, endTime As Long
Private Function elapsedTime(t1, t2 As Long) As Long
elapsedTime = t2 - t1
End Function
Public Function MyTest()
startTime = Now
' << do stuff >>
endTime = Now
MsgBox "Elapsed time=" & elapsedTime(startTime, endTime)
End Function
Private Sub Command1_Click()
Call MyTest
End Sub
edited.
In the two lines
Debug.Print ElapsedTime() & _
you are using the string concatenation character & and the line continuation character _ at the end of the line, even though the statement does not continue on the next line. So, either
continue the statement on the next line, e.g.
Debug.Print ElapsedTime() & _
" milliseconds" ' or whatever unit is returned by your ElapsedTime call
or
Remove the unneeded code:
Debug.Print ElapsedTime()
PS: Welcome to StackOverflow. Please get a good book on VBA development and read it. It's ok to ask basic questions here, but "please fix this code I found, because I don't know the basics of the language and don't have the time to learn it" type of questions are frowned upon and likely to be closed.
I'd like to use a .png as a custom icon in the Access 2007 ribbon.
Here's what I've tried so far:
I am able to load .bmp's and .jpg's as custom images without any problem. I can load .gif's, but it doesn't seem to preserve the transparency. I can't load .png's at all. I'd really like to use .png's to take advantage of the alpha-blending that is not available in the other formats.
I found a similar question on SO, but that just deals with loading custom icons of any kind. I am specifically interested in .png's. There is an answer from Albert Kallal to that question that links to a class module he had written that appears to do exactly what I want:
meRib("Button1").Picture = "HappyFace.png"
Unfortunately, the link in that answer is dead.
I also found this site which offers a download of a 460 line module full of dozens of API calls to get support for transparent icons. Before I go that route I wanted to ask the experts here if they know of a better way.
I know .png is pretty new-fangled and all, but I'm hoping the Office development folks slipped in some native support for the format.
Here is what I am currently using. Albert Kallal has a more full-fledged solution for Access 2007 ribbon programming that does a lot more than just load .png's. I am not using it yet, but it's worth checking out.
For those who are interested, here is the code that I am using. I believe this is pretty close to the minimum required for .png support. If there's anything extraneous here, let me know and I'll update my answer.
Add the following to a standard code module:
Option Compare Database
Option Explicit
'================================================================================
' Declarations required to load .png's in Ribbon
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type PICTDESC
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Private Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, _
inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Function GdipCreateBitmapFromFile Lib "GDIPlus" (ByVal filename As Long, bitmap As Long) As Long
Private Declare Function GdipCreateHBITMAPFromBitmap Lib "GDIPlus" (ByVal bitmap As Long, _
hbmReturn As Long, ByVal background As Long) As Long
Private Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal image As Long) As Long
Private Declare Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PICTDESC, _
RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
'================================================================================
Public Sub GetRibbonImage(ctl As IRibbonControl, ByRef image)
Dim Path As String
Path = Application.CurrentProject.Path & "\Icons\" & ctl.Tag
Set image = LoadImage(Path)
End Sub
Private Function LoadImage(ByVal strFName As String) As IPicture
Dim uGdiInput As GdiplusStartupInput
Dim hGdiPlus As Long
Dim hGdiImage As Long
Dim hBitmap As Long
uGdiInput.GdiplusVersion = 1
If GdiplusStartup(hGdiPlus, uGdiInput) = 0 Then
If GdipCreateBitmapFromFile(StrPtr(strFName), hGdiImage) = 0 Then
GdipCreateHBITMAPFromBitmap hGdiImage, hBitmap, 0
Set LoadImage = ConvertToIPicture(hBitmap)
GdipDisposeImage hGdiImage
End If
GdiplusShutdown hGdiPlus
End If
End Function
Private Function ConvertToIPicture(ByVal hPic As Long) As IPicture
Dim uPicInfo As PICTDESC
Dim IID_IDispatch As GUID
Dim IPic As IPicture
Const PICTYPE_BITMAP = 1
With IID_IDispatch
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
With uPicInfo
.Size = Len(uPicInfo)
.Type = PICTYPE_BITMAP
.hPic = hPic
.hPal = 0
End With
OleCreatePictureIndirect uPicInfo, IID_IDispatch, True, IPic
Set ConvertToIPicture = IPic
End Function
Then, if you don't already have one, add a table named USysRibbons. (NOTE: Access treats this table as a system table, so you'll have to show those in your nav pane by going to Access Options --> Current Database --> Navigation Options and make sure 'Show System Objects' is checked.) Then add these attributes to your control tag:
getImage="GetRibbonImage" tag="Acq.png"
For example:
<button id="MyButtonID" label="Do Something" enabled="true" size="large"
getImage="GetRibbonImage" tag="MyIcon.png" onAction="MyPublicSub"/>