VBA editor events - ms-access

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

Related

How to connect to OPEN workbook in another instance of Excel SAP Issue

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

How to make the process run while the button is pressed?

I use:
  - Win 7x64;
  - Access - 2016;
I try to solve my problem with the following code.
Form1
Option Compare Database
Option Explicit
Public statusBool As Boolean
Public numProc As Integer
' `Button pressed`.
Private Sub btnStart_Click()
numProc = 0
statusBool = True
Call Process(statusBool, numProc)
End Sub
' Process
Public Sub Process(statusBool As Boolean, numProc As Integer)
If statusBool = True Then
Me.txtProcessFrm = "ProcessNum - " & numProc + 1
Call SleepFor(1000) '1 seconds delay
Call Process(statusBool, numProc)
End If
End Sub
'
Private Sub btnStart_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
statusBool = False
numProc = 0
Call Process(statusBool, numProc)
End Sub
Public Sub SleepFor(ByVal MilliSeconds As Long)
Sleep MilliSeconds
End Sub
Module1
Option Compare Database
Option Explicit
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Question
Will my solution be correct for this task or are there simpler ways to solve this problem?
Update_1
The code does not start.
I get an error Sub or Function not defined.
Update_2
Module Module1.
Replaced Private to Public.
It was
 Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
It became
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Problem.
When I click the button btnStart_Click the file hangs
Update_3
Modified Process (statusBool As Boolean, numProc As Integer)
It became.
' Process
Public Sub Process(statusBool As Boolean, numProc As Integer)
If statusBool = True Then
Do
Sleep 1000
DoEvents
Loop Until Me.txtProcessFrm = "ProcessNum - " & numProc + 1
Call Process(statusBool, numProc)
End If
End Sub
Problem.
It seems the pause works, but the logic itself does not work.
In other words, the text field is not filled with text.
If you release the button, the cycle continues to work.
The chain of event for clicking a button follows as this.
MouseDown → MouseUp → Click → DblClick → Click
In your code, the loop will never stop because your statusBool will always be true causing infinite loop and that's probably why it's hanging even if you release the mosue.
you can however try this mouse down => mouse up:
Private Sub btnStart_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
statusBool = True
Call Process(0)
End Sub
Private Sub btnStart_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
statusBool = False
End Sub
Public Sub Process(numProc As Integer)
If statusBool Then
numProc = numProc + 1
Me.txtProcessFrm = "ProcessNum - " & numProc
Sleep 1000
DoEvents
Call Process(numProc)
End If
End Sub
more here:
https://learn.microsoft.com/en-us/office/vba/api/access.commandbutton.click

UrlDownloadToFile in Access 2010 - Sub or Function not Defined

I am trying to use the function URLDownloadToFile in Access 2010 VBA code. When i run the code it tells me that URLDownloadToFile is not defined.
I have read that this function is in the urlmon.dll which i DO have on my computer. I tried to click the references button in the code editor and load it but it would not let me do so.
How can I fix this so I can use the function? Or is there another function that will allow me to download a url to to a file?
You'll need to declare this WinAPI function in order to call it from procedures in your code.
From HERE
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Public Function DownloadFile(URL As String, LocalFilename As String) As Boolean
Dim lngRetVal As Long
lngRetVal = URLDownloadToFile(0, URL, LocalFilename, 0, 0)
If lngRetVal = 0 Then
If Dir(LocalFileName) <> vbNullString Then
DownloadFile = True
End If
End If
End Function
Private Sub Form_Load()
If Not DownloadFile("http://www.ex-designz.net", "c:\\photogallery.asp") Then
MsgBox "Unable to download the file, or the source URL doesn't exist."
End If
End Sub

VBA running out of memory

I have an access database with about 5000 records and each has a bmp stored in the database as an OLE. I am using Lebans OLEtoDisk, http://www.lebans.com/oletodisk.htm, to replace the objects with a file path, however, the code can only get through about 150 records and then I get an error "out of memory." I cannot figure out what is clogging up the memory. The OLEtoDisk functions use the clipboard, but I clear it after every record. Anyone have any ideas, or maybe just a way to clear all memory?
Here is the code I am using. First is the command button click event:
Option Compare Database
Option Explicit
Private Declare Function apiDeleteObject Lib "gdi32" Alias "DeleteObject" (ByVal hObject As Long) As Long
Private Declare Function apiOpenClipboard Lib "user32" Alias "OpenClipboard" (ByVal hwnd As Long) As Long
Private Declare Function apiEmptyClipboard Lib "user32" Alias "EmptyClipboard" () As Long
Private Declare Function apiCloseClipboard Lib "user32" Alias "CloseClipboard" () As Long
Private Declare Function CountClipboardFormats Lib "user32" () As Long
Sub EmptyClipboard()
Call apiOpenClipboard(0&)
Call apiEmptyClipboard
Call apiCloseClipboard
End Sub
Private Sub cmdCreateIPicture_Click()
DoCmd.SetWarnings False
' *********************
' You must set a Reference to: "OLE Automation" for this function to work. Goto the Menu and select Tools->References
' Scroll down to: Ole Automation and click in the check box to select this reference.
Dim lngRet, lngBytes, hBitmap As Long
Dim hpix As IPicture
Dim intRecordCount As Integer
intRecordCount = 0
Me.RecordsetClone.MoveFirst
Do While Not Me.RecordsetClone.EOF
If intRecordCount Mod 25 = 0 Then
EmptyClipboard
DoEvents
Excel.Application.CutCopyMode = False
Debug.Print "cleared"
End If
Me.Bookmark = Me.RecordsetClone.Bookmark
Me.OLEBound19.SetFocus
DoCmd.RunCommand acCmdCopy
hBitmap = GetClipBoard
Set hpix = BitmapToPicture(hBitmap)
SavePicture hpix, "C:\Users\PHammett\Images\" & intRecordCount & ".bmp"
DoCmd.RunSQL "INSERT INTO tblImageSave2 (newPath,oldPath) VALUES (""C:\Users\PHammett\Images\" & intRecordCount & """,""" & Me.RecordsetClone!Path & """);"
apiDeleteObject (hBitmap)
Set hpix = Nothing
EmptyClipboard
Me.RecordsetClone.MoveNext
intRecordCount = intRecordCount + 1
Loop
DoCmd.SetWarnings True
End Sub
Here is the code that resides in a module
Option Compare Database
Option Explicit
Private Const vbPicTypeBitmap = 1
Private Type IID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Type PictDesc
Size As Long
Type As Long
hBmp As Long
hPal As Long
Reserved As Long
End Type
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PictDesc, RefIID As IID, ByVal fPictureOwnsHandle As Long, Ipic As IPicture) As Long
'windows API function declarations
'does the clipboard contain a bitmap/metafile?
Private Declare Function IsClipboardFormatVailable Lib "user32" (ByVal wFormat As Integer) As Long
'open the clipbarod to read
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
'get a pointer to the bitmap/metafile
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
'empty the keyboard
Private Declare Function EmptyClipboard Lib "user32" () As Long
'close the clipobard
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function CopyEnhMetaFila Lib "gdi32" Alias "CopyEnhMetaFilaA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
'The API format types
Const CF_BITMAP = 2
Const CF_PALETTE = 9
Const IMAGE_BITMAP = 0
Const LR_COPYRETURNORG = &H4
Const xlPicture = CF_BITMAP
Const xlBitmap = CF_BITMAP
Public Function BitmapToPicture(ByVal hBmp As Long, Optional ByVal hPal As Long = 0&) As IPictureDisp
'Copyr ight: Lebans Holdings 1999 Ltd.
' May not be resold in whole or part. Please feel
' free to use any/all of this code within your
' own application without cost or obligation.
' Please include the one line Copyright notice
' if you use this function in your own code.
'
'Name: BitmapToPicture &
' GetClipBoard
'
'Purpose: Provides a method to save the contents of a
' Bound or Unbound OLE Control to a Disk file.
' This version only handles BITMAP files.
' '
'Author: Stephen Lebans
'Email: Stephen#lebans.com
'Web Site: www.lebans.com
'Date: Apr 10, 2000, 05:31:18 AM
'
'Called by: Any
'
'Inputs: Needs a Handle to a Bitmap.
' This must be a 24 bit bitmap for this release.
Dim lngRet As Long
Dim Ipic As IPicture, picdes As PictDesc, iidIPicture As IID
picdes.Size = Len(picdes)
picdes.Type = vbPicTypeBitmap
picdes.hBmp = hBmp
picdes.hPal = hPal
iidIPicture.Data1 = &H7BF80980
iidIPicture.Data2 = &HBF32
iidIPicture.Data3 = &H101A
iidIPicture.Data4(0) = &H8B
iidIPicture.Data4(1) = &HBB
iidIPicture.Data4(2) = &H0
iidIPicture.Data4(3) = &HAA
iidIPicture.Data4(4) = &H0
iidIPicture.Data4(5) = &H30
iidIPicture.Data4(6) = &HC
iidIPicture.Data4(7) = &HAB
'create the picture from the bitmap handle
lngRet = OleCreatePictureIndirect(picdes, iidIPicture, True, Ipic)
Set BitmapToPicture = Ipic
End Function
Public Function GetClipBoard() As Long
' Adapted from original Source Code by:
'* MODULE NAME: Paste Picture
'* AUTHOR & DATE: STEPHEN BULLEN, Business Modelling Solutions Ltd.
'* 15 November 1998
'*
'* CONTACT: Stephen#BMSLtd.co.uk
'* WEB SITE: http://www.BMSLtd.co.uk
Dim hClipBoard As Long
Dim hBitmap As Long
Dim hBitmap2 As Long
hClipBoard = OpenClipboard(0&)
If hClipBoard <> 0 Then
hBitmap = GetClipboardData(CF_BITMAP)
If hBitmap = 0 Then GoTo exit_error
hBitmap2 = CopyImage(hBitmap, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
hClipBoard = EmptyClipboard
hClipBoard = CloseClipboard
GetClipBoard = hBitmap2
End If
Exit Function
exit_error:
GetClipBoard = -1
End Function
Public Function ClearClipboard()
EmptyClipboard
CloseClipboard
End Function
...but I clear it after every record
Try DoEvents after this code.

Forms GotFocus event does not seem to fire

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.