Detecting Inactivity using VBA - excel

I am trying to write a script that will auto save and close an excel file if there is computer (not just excel) inactivity after so long. A message box warning to the user would also be a nice feature that I would like to include. I found some code that seems like it would meet my needs perfectly (http://www.vbaexpress.com/forum/showthread.php?33711-Solved-Possible-for-excel-to-detect-inactivity-at-pc), but I can't seem to get it to work right. I have put this code in a module, but it gets hung up on the very first line (Private Declare Sub GetLastInputInfo Lib "USER32" (ByRef plii As LASTINPUTINFO)) saying "Compile Error: User defined type not defined." I have enabled Microsoft ActiveX Data Objects 6.1 Library, but still get the same result. I'm fairly new to VBA so I can't read someone else's code very well so sorry in advance if I'm missing something simple.
Private Declare Sub GetLastInputInfo Lib "USER32" (ByRef plii As LASTINPUTINFO)
Function IdleTime() As Single
Dim a As LASTINPUTINFO
a.cbSize = LenB(a)
GetLastInputInfo a
IdleTime = (GetTickCount - a.dwTime) / 1000
End Function
Public Sub CloseDownFile()
On Error Resume Next
If IdleTime > 30 Then
Application.StatusBar = "Inactive File Closed: " & ThisWorkbook.Name
ThisWorkbook.Close SaveChanges:=True
Else
CloseDownTime = Now + TimeValue("00:00:30") ' change as needed
Application.OnTime CloseDownTime, "CloseDownFile"
End If
End Sub
Sub Test_MsgBoxWait()
Dim rc As Long
rc = MsgBoxWait("UserName", "Is your computer user name " & _
Environ("username") & "?" & vbLf & _
"I will wait 5 seconds for your response.", 1, 2) '4+32
Select Case rc
Case 6
MsgBox "Congratulations, you are correct."
Case 7
MsgBox "I am sorry, that is incorrect." & vbLf & _
"Your computer username is " & Environ("username") & "."
Case Else
MsgBox "The return code was: " & rc
End Select
End Sub
'Function MsgBoxWait(strTitle As String, strText As String, _
nType As Integer, nSecondsToWait As Integer)
Function MsgBoxWait(strTitle As String, strText As String, _
nType As Long, nSecondsToWait As Integer)
Dim ws As Object, rc As Long
Set ws = CreateObject("WScript.Shell")
rc = ws.Popup(strText, nSecondsToWait, strTitle, nType)
Set ws = Nothing
MsgBoxWait = rc
End Function
'Arguments
'Object
'WshShell object.
'strText
'String value containing the text you want to appear in the pop-up message box.
'nSecondsToWait
'Numeric value indicating the maximum length of time (in seconds) you want the pop-up message box displayed.
'strTitle
'String value containing the text you want to appear as the title of the pop-up message box.
'nType
'Numeric value indicating the type of buttons and icons you want in the pop-up message box. These determine how the message box is used.
'IntButton //not used but returned as result of MsgBoxWait().
'Integer value indicating the number of the button the user clicked to dismiss the message box. This is the value returned by the Popup method.
'Remarks
'The Popup method displays a message box regardless of which host executable file is running (WScript.exe or CScript.exe). If
' nSecondsToWaitis equals zero (the default), the pop-up message box remains visible until closed by the user. If
' nSecondsToWaitis is greater than zero, the pop-up message box closes after nSecondsToWait seconds. If you do not supply
' the argument strTitle, the title of the pop-up message box defaults to "Windows Script Host." The meaning of nType is the
' same as in the Microsoft Win32® application programming interface MessageBox function. The following tables show the
' values and their meanings. You can combine values in these tables.
'
'Note To display text properly in RTL languages such as Hebrew or Arabic, add hex &h00100000 (decimal 1048576) to the nType parameter.
'Button Types
'
'Value Description
'0 Show OK button.
'1 Show OK and Cancel buttons.
'2 Show Abort, Retry, and Ignore buttons.
'3 Show Yes, No, and Cancel buttons.
'4 Show Yes and No buttons.
'5 Show Retry and Cancel buttons.
'
'Icon Types
'
'Value Description
'16 Show "Stop Mark" icon.
'32 Show "Question Mark" icon.
'48 Show "Exclamation Mark" icon.
'64 Show "Information Mark" icon.
'
'The previous two tables do not cover all values for nType. For a complete list, see the Microsoft Win32 documentation.
'
'The return value intButton denotes the number of the button that the user clicked. If the user does not click a button before nSecondsToWait seconds, intButton is set to -1.
'
'Value Description
'1 OK Button
'2 Cancel Button
'3 Abort Button
'4 Retry Button
'5 Ignore Button
'6 Yes Button
'7 No Button
'
' Note: intButton is not used here. The value for intButton is returned to from the Function.

You just need to declare LASTINPUTINFO type:
Private Type LASTINPUTINFO
cbSize As Long
dwTime As Long
End Type
Private Declare Sub GetLastInputInfo Lib "user32" (ByRef plii As LASTINPUTINFO)
Private Declare Function GetTickCount Lib "kernel32" () As Long
Function IdleTime() As Single
Dim a As LASTINPUTINFO
a.cbSize = LenB(a)
GetLastInputInfo a
IdleTime = (GetTickCount - a.dwTime) / 1000
End Function

Related

Bring previous opened window (Word document) to foreground

Suppose I have two hyperlinks (on excel sheet) referring to two documents:
e.g ( A.doc and B.doc ) on my local intranet.
I will open the first document "A.doc" then I will open the second one "B.doc"
The problem:
If there is already an opened word document and then I clicked hyperlink (Word Document on my local intranet),
The later file is not opened automatically and I have to click on the flashing taskbar button to open the cited second file.
This issue occurs only with Microsoft word documents found on my local intranet.
If there is no open document and I clicked on any word hyperlink, It opens normally without any issue.
Please watch this short video to understand my problem.
I need to utilize FollowHyperlink event in excel or any other method to:
bring the previous opened window A.doc to front and then bring the second one B.doc to front.
you may find it a strange question! But I have to do it manually each time to show and bring the second one to front.
I have used this API code (in a Word document) on Normal-ThisDocument:
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
Dim LHwnd As Long
Private Sub Document_Open()
If Application.Documents.Count > 1 Then
LHwnd = FindWindow("rctrl_renwnd32", Application.ActiveWindow.Caption)
SetForegroundWindow (LHwnd)
End If
End Sub
And used that code on my excel sheet itself:
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
On Error Resume Next
Dim objWd As Object
Set objWd = GetObject(, "Word.Application")
AppActivate objWd.ActiveWindow.Caption
Set objWd = Nothing
End Sub
Finally, I found this helpful page Bring an external application window to the foreground But I could not adapted it to my need.
Please, try the next BeforeDoubleClick event. If the problem is related only to hyperlinks, it should work...
Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.column = 1 And Target.Value <> "" Then 'limit this behavior to the first column
If LCase(left(Target.Value, 5)) = "http:" Then
Cancel = True
Dim objWd As Object, d As Object, arrD: arrD = Split(Target.Value, ".")
If LCase(left(arrD(UBound(arrD)), 3)) <> "doc" Then Exit Sub
On Error Resume Next
Set objWd = GetObject(, "Word.Application") 'find the Word open session, if any
On Error GoTo 0
If objWd Is Nothing Then
Set objWd = CreateObject("Word.Application")
End If
With objWd
.Visible = True
Set d = .Documents.Open(Target.Value)
End With
'force somehow the new open document window expose its handler...
Dim i As Long
Do Until objWd.ActiveWindow.Caption = d.name Or _
objWd.ActiveWindow.Caption = left(d.name, InstRev(d.name, ".")-1) & " [Read-Only] [Compatibility Mode]"
i = i + 1: Debug.Print objWd.ActiveWindow.Caption, left(d.name, InstRev(d.name, ".")-1) & " [Read-Only] [Compatibility Mode]"
DoEvents: If i >= 10 Then Exit Do 'just in case, if something unexpected happens...
Loop
SetForegroundWindow CLngPtr(objWd.ActiveWindow.hWnd)
End If
End If
End Sub
It should work in 64 bit, but it is easy to be adapted for both cases, supposing that it works as you need.

Excel VBA Problem when adding an ImageCombo-ActiveX to a worksheet

I'm trying to add an ImageCombo-ActiveX control to an Excel worksheet by using the VBA-function .OLEObjects.Add(classtype:="MSComctlLib.ImageComboCtl.2", Top:=TopPos, Left:=LeftPos, Height:=0, Width:=0).
When doing so, the ImageCombo control is displayed on the worksheet in a preloaded state:
ImageCombo Preloaded State
When doing a check with Winspector Spy, it turned out then the ActiveX-Window is loaded as a child-window of an invisible window within Excel named as 'CtlFrameworkParking':
ActiveX control window
instead of being diplayed as an ImageCombo-control. To force this, I first have to make the worksheet window invisble and then redisplay it:
Status after Re-displaying the worksheet window
Finally, after manually scrolling down a line, the ImageCombo-control is diplayed at the desired location with the desired size.
Status after worksheet scroll
Reinspecting with Winspector Spy the ActiveX-Window now is located within the worksheet window:
final correct status
Is there any way to programatically force the ActiveX-Window to show in final state on the worksheet window, probably with some api calls?
I Solved the problem doing it the dirty way by adding the following lines:
Function ShowLanguageDropDown(TargetSheetName As String, Optional TopPos As Single = 0#, Optional LeftPos As Single = 0#, Optional SetVisible As Boolean = False) As MSComctlLib.ImageCombo
'---------------------------------------------------------------------------------------
' Procedure : ShowLanguageDropDown
' Author : Bernd Birkicht
' Date : 05.11.2022
' Purpose : inserts an image dropdown on the target sheet, requires prelodad OLE-objects on a SourceSheet
' containing the ImageDropdown and the to be associated pre-set ImageList-activeX control
'---------------------------------------------------------------------------------------
'
'........
Set TargetSheet = ActiveWorkbook.Sheets(TargetSheetName)
'........
With TargetSheet
.Visible = xlSheetHidden
.Visible = xlSheetVisible
.Activate
End With
Set TargetSheet = Nothing
CurrentScrollRow = ActiveWindow.ScrollRow
ActiveWindow.ScrollRow = 2
ActiveWindow.ScrollRow = CurrentScrollRow
End function
These commands now do programmatically what I did manually before resulting in now correctly displaying the ImageDropdown control at the desired location on the worksheet.
I would welcome a more elegant solution.
I finally decided to to drop the approach of using an ImageCombo-ActiveX control directly on an Excel worksheet due to i encounterd a big bunch of problems with the ImageCombo-control further on.
When stopping the screen update, the Drop-down arrow within the control occasionally disappears and the control repaints not always fully. I was not able to fix this.
At the end of the day, I used the ImageCombo-ActiveX control within a modeless userform which is not affected at all from application screen updating or events processed by the application while the userform is displayed.
To prevent the userform from floating on the windows screen, I now attached the userform to the Excel-application window and cropped the userform frame around the ImageCombo-control.
Please find below the code:
Private Sub UserForm_Initialize()
'---------------------------------------------------------------------------------------
' Procedure : UserForm_Initialize
' Author : Bernd Birkicht
' Date : 10.11.2022
' Purpose : fills the image-Dropdownbox valid lnaguage entries
'---------------------------------------------------------------------------------------
'
Static BasicInit As Boolean
On Error GoTo UserForm_Initialize_Error
If BasicInit Then Exit Sub 'already initialised?
....
'adapt userform window to Dropbox size
Me.Height = Me!LanguageDropBox.Height
Me.Width = Me!LanguageDropBox.Width
With Me.LanguageDropBox
Set .ImageList = Nothing 'delete image list and import again
If .ImageList Is Nothing Then Set .ImageList = Me.LanguageSmallIconImageList
mlngptrCtlHwnd = .hwnd
.Locked = True
End With
PopulateComboItems Translate:=bTranslate
UserForm_Initialize_Exit:
Crop_UF_Frame
BasicInit = MakeChild(Me)
Exit Sub
UserForm_Initialize_Error:
Select Case Err.Number
Case Else
'MsgBox "Error " & Err.Number & " (" & Err.Description & ") in Prozedur UserForm_Initialize aus Formular LanguageDropBoxForm"
'LogError Err.Number, Err.Description, "in Prozedur UserForm_Initialize aus Formular LanguageDropBoxForm"
ErrEx.CallGlobalErrorHandler ' Call the global error handler to deal with unhandled errors
Resume UserForm_Initialize_Exit:
End Select
End Sub
Private Sub Crop_UF_Frame()
'---------------------------------------------------------------------------------------
' Procedure : Crop_UF_Frame
' Author : Nepumuk https://www.herber.de/forum/archiv/1456to1460/1459854_Userform_komplett_ohne_Rand.html
' Date : 21.11.2015
' Purpose : crop the userform frame
' geändert : 11.11.2022 Bernd Birkicht
' ergänzt: Region eingrenzen auf einzelnes Control in der Userform
'---------------------------------------------------------------------------------------
'
Dim udtRect As RECT, udtPoint As POINTAPI
Dim lngptrStyle As LongPtr, lngptrRegion As LongPtr, lngParenthWnd As LongPtr
Static BasicInit As Boolean
On Error GoTo Crop_UF_Frame_Error
mlngptrHwnd = FindWindowA(GC_CLASSNAMEMSFORM, Caption)
lngptrStyle = GetWindowLongA(mlngptrHwnd, GWL_STYLE)
Call SetWindowLongA(mlngptrHwnd, GWL_STYLE, lngptrStyle And Not WS_CAPTION)
Call DrawMenuBar(mlngptrHwnd)
Call GetWindowRect(mlngptrHwnd, udtRect)
udtPoint.x = udtRect.right
udtPoint.y = udtRect.bottom
Call ScreenToClient(mlngptrHwnd, udtPoint)
'11.11.2022 set region
If mlngptrCtlHwnd = 0 Then 'Control in Userform gewählt?
'remove userform frame
With udtRect
.bottom = udtPoint.y
.left = 4
.right = udtPoint.x
.top = 4
End With
Else
'set region to WindowRect of the selected control
Call GetWindowRect(mlngptrCtlHwnd, udtRect)
End If
lngptrRegion = CreateRectRgnIndirect(udtRect)
Call SetWindowRgn(mlngptrHwnd, lngptrRegion, 1&)
Crop_UF_Frame_Exit:
Exit Sub
Crop_UF_Frame_Error:
Select Case Err.Number
Case Else
ErrEx.CallGlobalErrorHandler ' Call the global error handler to deal with unhandled errors
Resume Crop_UF_Frame_Exit:
End Select
End Sub
Private Function MakeChild(ByVal UF As UserForm) As Boolean
Dim DeskHWnd As LongPtr
Dim WindowHWnd As LongPtr
Dim UFhWnd As LongPtr
MakeChild = False
' get the window handle of the Excel desktop
DeskHWnd = FindWindowEx(Application.hwnd, 0&, "XLDESK", vbNullString)
If DeskHWnd > 0 Then
' get the window handle of the ActiveWindow
WindowHWnd = FindWindowEx(DeskHWnd, 0&, "EXCEL7", ActiveWindow.Caption)
If WindowHWnd > 0 Then
' ok
Else
MsgBox "Unable to get the window handle of the ActiveWindow."
Exit Function
End If
Else
MsgBox "Unable to get the window handle of the Excel Desktop."
Exit Function
End If
' get the window handle of the userform
Call IUnknown_GetWindow(UF, VarPtr(UFhWnd))
mlngptrOldParenthWnd = GetParent(UFhWnd)
If mlngptrOldParenthWnd = WindowHWnd Then Exit Function 'Assignment to Excel window already done
'make the userform a child window of the MDIForm
If (UFhWnd > 0) And (WindowHWnd > 0) Then
' make the userform a child window of the ActiveWindow
If SetParent(UFhWnd, WindowHWnd) = 0 Then
''''''''''''''''''''
' an error occurred.
''''''''''''''''''''
MsgBox "The call to SetParent failed."
Exit Function
End If
End If
MakeChild = True
End Function
call:
If Wb.ActiveSheet.Name = Translate_To_OriginalText(InitSheetName) And LanguageDropBoxUForm Is Nothing Then
LanguageDropBoxForm.Hide 'Lädt das Window ohne es anzuzeigen
If UserForms.count > 0 Then Set LanguageDropBoxUForm = UserForms(UserForms.count - 1)
LanguageDropBoxForm.Move 660#, 85#
LanguageDropBoxForm.Show vbModeless 'show Language-Select-Window modeless
endif

Excell VBA Shell command not working but it does work from the windows command window

The code below Works with Excel 2016
When the user clicks a cell in column A (after the first few header rows are checked)
The value of the contents of the cell is stored in the string variable stockcode.
The Sub Spark() is where the problem lies, in particular Call Shell(stAppName, 0)
stAppName = "C:\Autoit\Spark_test_10_Excel.a3x " & stockcode
Debug.Print stAppName
Call Shell(stAppName, 0)
The application being called displays a chart.
In the debug window you can see the call string C:\Autoit\Spark_test_10_Excel.a3x BHP
If I copy and paste that output into the windows 10 search window the string opens the app and displays a chart perfectly. I also compiled the Autoit script to an EXE That performed exactly as described above. No difference.
Also not the Notepad test commented out. That also worked perfectly.
I guess this is problem is security related. I have tried numerous workarounds none worked so far.
Any suggestions will be gratefully received
Option Explicit
Public stAppName As String
Public stockcode As String
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type MSG
hwnd As Long
Message As Long
wParam As Long
lParam As Long
time As Long
pt As POINTAPI
End Type
Private Declare Function PeekMessage Lib "user32" _
Alias "PeekMessageA" _
(ByRef lpMsg As MSG, ByVal hwnd As Long, _
ByVal wMsgFilterMin As Long, _
ByVal wMsgFilterMax As Long, _
ByVal wRemoveMsg As Long) As Long
Private Const PM_NOREMOVE = &H0
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Message As MSG
'check for left-mouse button clicks.
PeekMessage Message, 0, 0, 0, PM_NOREMOVE
If Message.Message = 512 Then
Debug.Print "You clicked cell: " & Selection.Address, Selection.Value
End If
On Error GoTo FoundAnError 'the user probably clicked somewhare not in column A in the sheet
stockcode = Selection.Value
Call Spark
FoundAnError:
MsgBox ("there was a VBA code error it should have been addressed")
End Sub
Sub Spark()
Debug.Print "Spark: " & Selection.Address, Selection.Value
If ActiveCell.Column = 1 Then
If stockcode = "Ticker Symbol" Then
Debug.Print "Ticker", stockcode
Exit Sub
End If
If Selection.Value = "" Then
Debug.Print "No stock code ", stockcode
Exit Sub
End If
Debug.Print "stock code in call ", stockcode
'Shell "Notepad", vbNormalFocus 'Yes this works as a test
'On Error GoTo 0
stAppName = "C:\Autoit\Spark_test_10_Excel.a3x " & stockcode
Debug.Print stAppName
'EDIT
'Call Shell(stAppName, 0)This does not work!
Shell "cmd.exe /C " & stAppName, vbHide 'Works
'This Works Thanks FaneDuru
End If
End Sub
This is the output from the debug window running the above code
You clicked cell: $A$7 BHP
Spark: $A$7 BHP
stock code in call BHP
C:\Autoit\Spark_test_10_Excel.a3x BHP

Excel.. Get the cell contents with a single click and call vba function Problem

I use the following code to pass a variable to an external program. The code works fine with a single click passing the found data to the immediate window See Debug.print statement. (As long as the call to sub spark is not uncommented) IE 'Call Spark
If the call is uncommented a double click is required. IE Call Spark. From a user point of view very confusing and clumsy.
I have tried not using the Sub Spark() and running the code from within the
Sub Worksheet_SelectionChange
That makes no difference I need a double click.
Excel VBA is not my strong point, It's got me beat....
All that is needed is to grab the data with a single click and move on. The external call displays a stock chart. I do not need to edit the cell.
Regards
John
Option Explicit
Public stAppName As String
Public stockcode As String
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type MSG
hwnd As Long
Message As Long
wParam As Long
lParam As Long
time As Long
pt As POINTAPI
End Type
Private Declare Function PeekMessage Lib "user32" _
Alias "PeekMessageA" _
(ByRef lpMsg As MSG, ByVal hwnd As Long, _
ByVal wMsgFilterMin As Long, _
ByVal wMsgFilterMax As Long, _
ByVal wRemoveMsg As Long) As Long
Private Const PM_NOREMOVE = &H0
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Message As MSG
'check for left-mouse button clicks.
PeekMessage Message, 0, 0, 0, PM_NOREMOVE
If Message.Message = 512 Then
Debug.Print "You clicked cell: " & Selection.Address, Selection.Value
End If
stockcode = Selection.Value
'Call Spark
End Sub
Sub Spark()
Debug.Print "Spark: " & Selection.Address, Selection.Value
stAppName = "C:\Users\JCM\Desktop\AUTOIT\Spark test 10 first working.exe " & stockcode
Call Shell(stAppName, 1)
End Sub

VBA Excel: message box and non english words [duplicate]

This question already has answers here:
How do I display a messagebox with unicode characters in VBA?
(2 answers)
Unicode string literals in VBA
(3 answers)
Closed 2 years ago.
Has anyone a workaround to show Arabic in a message box. I even changed the font to Arial (Arabic) in VBA setting and I cant write Arabic in the code but when it runs its shows garbage words in the message box.
Below is a sample code even though it's showing as CaCaCa below but in my VBA it's a proper Arabic word.
Private Sub cmdDelete_Click()
Dim iRow As Long
If Selected_List = 0 Then
Font.Name = "Arial Unicode MS"
MsgBox "ÇáÇãÇä No row is selected. ", vbOKOnly + vbInformation, "Delete"
Exit Sub
End If
An approach based on #Tarik 's link to MsgBox with Unicode characters:
VBA7 Declaration of API function MessageBoxW()
Option Explicit ' Declaration head of code module
Private Declare PtrSafe Function MessageBoxW Lib "User32" ( _
ByVal hWnd As LongPtr, _
ByVal lpText As LongPtr, _
ByVal lpCaption As LongPtr, _
ByVal uType As Long) _
As Long
Help function MsgBoxW()
'Site: https://stackoverflow.com/questions/55210315/how-do-i-display-a-messagebox-with-unicode-characters-in-vba
Function MsgBoxW( _
Prompt As String, _
Optional Buttons As VbMsgBoxStyle = vbOKOnly + vbInformation, _
Optional Title As String = " Delete") _
As VbMsgBoxResult
Title = WorksheetFunction.Unichar(&H1F4BC) & Title
MsgBoxW = MessageBoxW(Application.hWnd, StrPtr(Prompt), StrPtr(Title), Buttons)
End Function
Note that Access would need a Application.hWndAccessApp argument to get the corresponding window handle.
Example call
Sub ExampleCall()
Dim s As String
s = WorksheetFunction.Unichar(&H2776) & " " & getArabic() & vbNewLine & vbNewLine & _
WorksheetFunction.Unichar(&H2777) & " No Rows selected. "
MsgBoxW s
End Sub
Hardcoding test function getArabic()
As I don't know the Arabic language, the following function only tries to simulate a correct phrase I got via a translation site by joining single unicode values of a hardcoded array to a string like e.g. ; so I beg your pardon for any mistranslation :-)
There are numerous sites where you can get the hexadecimal or decimal code values immediately.
It would be possible as well to insert your original string into an Excel sheet cell and analyze the corresponding character values one by one (e.g. via formula =UNICODE(MID($A2,1,1)) etc.)
Function getArabic()
'Note: uses decimal values here (e.g. decimal 1604 equals hexadecimal &H644)
Dim arr: arr = Array(1604, 1605, 32, 1610, 1578, 1605, 32, 1578, 1581, 1583, 1610, 1583, 32, 1589, 1601, 46)
Dim a, s As String
For Each a In arr
s = s & WorksheetFunction.Unichar(a)
Next a
getArabic = s
End Function
The computer you are using should have the default code page to Windows 1256. That way, it interprets any extended ASCII character (above 127) as Arabic. The alternative (preferred option) is to ensure you use UTF-8.
See How do I display a messagebox with unicode characters in VBA?

Resources