Stop VBA to block Excel sheet when executing a function - excel

I’ve got following Excel scenario:
A1 has the value of "A", B2 = "B", C3 = "C"
but they are interchangeable.
Within the workbook path there are two subfolders containing wav files named A.wav, B.wav and C.wav
The code at the bottom allows me to playback the wav files with a button click firing the macro PlayIt().
My Problem is, while the function is executing I’m unable to edit cells in Excel which I really need to! It kinda looks like this
https://gifyu.com/images/GIF8d5e1.gif
Thank you for any help!
Code for Audioplayback:
Option Explicit
#If VBA7 Then
Public Declare PtrSafe Function PlaySound Lib "winmm.dll" _
Alias "sndPlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long
#Else
Public Declare Function PlaySound Lib "winmm.dll" _
Alias "sndPlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long
#End If
Const SND_SYNC = &H0
Const SND_ASYNC = &H1
Const SND_FILENAME = &H20000
Sub PlayTheSound(ByVal WhatSound As String)
If Dir(WhatSound, vbNormal) = "" Then
' WhatSound is not a file. Get the file named by
' WhatSound from the Windows\Media directory.
WhatSound = ThisWorkbook.Path & "\stimuli\" & "\1second\" & WhatSound
If InStr(1, WhatSound, ".") = 0 Then
' if WhatSound does not have a .wav extension,
' add one.
WhatSound = WhatSound & ".wav"
End If
If Dir(WhatSound, vbNormal) = vbNullString Then
Beep ' Can't find the file. Do a simple Beep.
MsgBox "Could not find the file in the Path: " & WhatSound
Exit Sub
End If
Else
' WhatSound is a file. Use it.
End If
PlaySound WhatSound, 0&, SND_ASYNC Or SND_FILENAME ' Finally, play the sound.
End Sub
Sub PlayIt()
PlayTheSound (Range("A1").Value)
PlayTheSound (Range("B1").Value)
PlayTheSound (Range("C1").Value & "e")
End Sub

You have your declaration wrong in two ways: hModule should be LongPtr, and you are using parameters from PlaySound while actually calling sndPlaySound.
Fix your declaration:
#If VBA7 Then
Public Declare PtrSafe Function PlaySound Lib "winmm.dll" _
Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As LongPtr, ByVal dwFlags As Long) As Long
#Else
Public Declare Function PlaySound Lib "winmm.dll" _
Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long
#End If

Related

How to detect mouse release for a shape, not a button in Excel

I want to make a button that plays a sound, but stops playing when I release the click. I tried using command buttons, but it stops the whole program, until the sound ends. So, I used a normal rectangle instead. There is MouseUp event for the command buttons, but I need something for shapes.
I have this code:
#If VBA7 Then
Public Declare PtrSafe Function WINMM Lib "winmm.dll" _
Alias "PlaySoundA" (ByVal lpszName As String, _
ByVal hModule As Long, ByVal dwFlags As Long) As Long
#Else
Public Declare Function WINMM Lib "winmm.dll" _
Alias "PlaySoundA" (ByVal lpszName As String, _
ByVal hModule As Long, ByVal dwFlags As Long) As Long
#End If
Const SND_SYNC = &H0
Const SND_ASYNC = &H1
Const SND_FILENAME = &H20000
Private Sub Obdélník1_Click()
Path = ThisWorkbook.Path & "\Sound1.wav"
Call WINMM(Path, 0&, SND_ASYNC Or SND_FILENAME)
End Sub
Private Sub Obdélník1_Release()
Path = ThisWorkbook.Path & "\Sound2.wav" 'Sound2 is just a short silent sound, that replaces the Sound1
Call WINMM(Path, 0&, SND_ASYNC Or SND_FILENAME)
End Sub
How to activate the last macro on the click release?

How can I read a timer value on a network connection window?

I have a process that requires an active VPN connection, but the connection is automatically cut every 8 hours. I need to be able to control that the connection is active and the time left up to the 8 hour limit.
In the properties of the windows connections the time appears (attached capture with the data that I need), but I need to know how to read this data.
Try the next approach, please:
Edited, because of the last request:
Please add two new declarations
Copy the next API functions on top of a standard module:
Option Explicit
Private Declare PtrSafe Function FindWindow Lib "User32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function FindWindowEx Lib "User32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, _
ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
Private Declare PtrSafe Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal hwnd As LongPtr, _
ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As Long
Private Declare PtrSafe Function GetWindowTextLength Lib "User32" Alias "GetWindowTextLengthA" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function GetWindowText Lib "User32" Alias "GetWindowTextA" (ByVal hwnd As LongPtr, _
ByVal lpString As String, ByVal cch As Long) As Long
Private Declare PtrSafe Function GetWindow Lib "User32" (ByVal hwnd As LongPtr, ByVal wCmd As Long) As Long
And the next Constant:
Private Const GW_HWNDNEXT = 2
'Added after editing:__________________
Private Const WM_LBUTTON_DOWN = &H201
Private Const BM_CLICK = &HF5
'______________________________________
In the same standard module, copy the next Sub. Please, take care to change Duration: from the code, with the Spanish correct variant ('Duración' [with the necessary accent]):
Sub DurationAPI()
Dim hwndEth As LongPtr, hwndGen As LongPtr, hwndDurlbl As LongPtr, hwndDur As LongPtr
Dim sStr As String, strWindowTitle As String, durationLbl As String, durT As Date, limitD As Date
'added after editing:_____________________________
OpenWiFiConnectionWindow 'open connection window
AppActivate Application.ActiveWindow.Caption
'_________________________________________________
limitD = CDate("08:00:00")
strWindowTitle = "Estado de Wi-Fi"
durationLbl = "Duration:" 'Please change here with your exact label title (in Spanish...)
'I cannot write duracion: with the necessary accent...
hwndEth = FindWindow(vbNullString, strWindowTitle): Debug.Print Hex(hwndEth)
hwndGen = FindWindowEx(hwndEth, 0&, vbNullString, "General"): Debug.Print Hex(hwndGen)
hwndDurlbl = FindWindowEx(hwndGen, 0&, vbNullString, durationLbl): Debug.Print Hex(hwndDurlbl)
hwndDur = GetWindow(hwndDurlbl, GW_HWNDNEXT): Debug.Print Hex(hwndDur)
sStr = String(GetWindowTextLength(hwndDur) + 1, Chr$(0))
GetWindowText hwndDur, sStr, Len(sStr)
durT = CDate(sStr)
MsgBox Format(limitD - durT, "hh:mm:ss") & " left until connection will be interrupted!", _
vbInformation, "Time to connection interruption"
'Added after editing: ____________________________________________________
Dim hwndClose As LongPtr
'closing the connection window:
hwndClose = FindWindowEx(hwndEth, 0&, vbNullString, "&Close"): Debug.Print Hex(hwndClose)
SendMessage hwndClose, WM_LBUTTON_DOWN, 0&, 0&
SendMessage hwndClose, BM_CLICK, 0, ByVal 0&
'_________________________________________________________________________
End Sub
bis Copy the Sub able to show the necessary connection window:
Private Sub OpenWiFiConnectionWindow()
Dim objApp As Object: Set objApp = CreateObject("Shell.Application")
Dim objFolder As Object: Set objFolder = objApp.Namespace(&H31&).self.GetFolder
Dim interface As Variant, interfaceTarget As Object, InterfaceName As String
InterfaceName = "Wi-Fi" 'Please, check here what is show your "Network Connections" folder. It maybe can be slightly different...
'I tested the code on my Ethernet connection, which not was simple "Ethernet". It was "Ethernet 2"...
For Each interface In objFolder.Items
If LCase(interface.Name) = LCase(InterfaceName) Then
Set interfaceTarget = interface: Exit For
End If
Next
Dim Verb As Variant
For Each Verb In interfaceTarget.Verbs
If Verb.Name = "Stat&us" Then
Verb.DoIt
Application.Wait Now + TimeValue("0:00:01")
Exit For
End If
Next
End Sub
Please, try this Sub first, in order to be sure that it shows the necessary connection window. If it doesn't, please look in the "Network Connections" folder and change InterfaceName with an appropriate one.
Run the above DurationAPI() Sub.
All the necessary windows handlers are returned in Immediate window. If one of them is 0 (zero), there must be checked to understand what is happening... I used Spy++ to find the windows titles/classes...
For a window with English titles, it returns correctly and almost instant the necessary connection duration time.

minimize window driver selenium excel vba

I have searched a lot for a way to minimize the window of the driver in selenium for excel vba. I have found ways for Java and python and tried to adopt them but all my tries failed
I just found a way to maximize the window using
bot.Window.Maximize
But when trying to use Minimize I got an error
Again I am searching for excel vba as for selenium ...
Thanks advanced for help
AFAIK there is no method for this in VBA implementation (there is in Python for example). There are a number of ways to manipulate size and position e.g.
bot.Window.SetSize 0, 0
Or you can run headless
bot.AddArgument "--headless"
You might also try to:
1) Emulate Windows Key + Down
2) Write a javscript function that performs window.minimize() and async execute off the parent window
3) Capture your target co-ordinates by generating a GetWindowPlacement call along with implementing your own WINDOWPLACEMENT struct. Looks like gets ugly fast.
See also:
Getting the size of a minimized window
Driver.Window.SetSize 0, 0
just made the window smaller, without minimizing the browser to the taskbar.
How to use GetWindowPlacement in selenium vba?
'for vb6
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type WINDOWPLACEMENT
Length As Long
flags As Long
showCmd As Long
ptMinPosition As POINTAPI
ptMaxPosition As POINTAPI
rcNormalPosition As RECT
End Type
Private Declare Function GetWindowPlacement Lib "user32" (ByVal hwnd As Long, lpwndpl As WINDOWPLACEMENT) As Long
Private Sub Command1_Click()
Dim wp As WINDOWPLACEMENT
wp.Length = Len(wp)
GetWindowPlacement targetHandle, wp
End Sub
Minimize window by windows API
This is a workaround for Selenium VBA not having a working minimize window option.
''compiler constants
#If VBA7 Then
Public Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Boolean
Public Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal cch As Long) As Long
Public Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
#Else
Public Declare Function ShowWindow Lib "USER32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Boolean
Public Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Public 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
#End If
Dim hwnd As Long
Dim Botwindowtitle As String
bot.Start
Botwindowtitle = bot.Window.Title
hwnd = GetAllWindowHandles(Botwindowtitle)
Call ShowWindow(hwnd, 7) 'Show the window minimized (SW_SHOWMINNOACTIVE = 7) http://www.jasinskionline.com/windowsapi/ref/s/showwindow.html
bot.Get "https://www.google.com/"
Private Function GetAllWindowHandles(partialName As String) As Long
Dim hwnd As Long, lngRet As Long
Dim strText As String
Dim hWndTemp As Long
hwnd = FindWindowEx(0&, 0&, vbNullString, vbNullString)
Do While hwnd <> 0
strText = String$(100, Chr$(0))
lngRet = GetWindowText(hwnd, strText, 100)
If InStr(1, strText, partialName, vbTextCompare) > 0 Then
Debug.Print "Window Handle:" & hwnd & vbNewLine & _
"Window title:" & Left$(strText, lngRet) & vbNewLine & _
"----------------------"
hWndTemp = hwnd
GetAllWindowHandles = hWndTemp
End If
'~~> Find next window
hwnd = FindWindowEx(0&, hwnd, vbNullString, vbNullString)
Loop
End Function

Focus to MgsBox when Excel is not active

I have checked related questions such as this or this one but the solutions there do not seem to solve my problem.
I am running a VBA script on my computer. The script takes a few minutes to execute and while waiting I am checking other things in my computer. To get my attention once the script has finished running, I have included a MsgBox at the end of my script. However, because Excel is not active/selected when the script finishes, I cannot see it - only when I reactivate/select Excel.
How can I bring into focus the MsgBox when Excel is not active? I have already tried the following tweaks but they do not work:
ThisWorkbook.Activate:
...
ThisWorkbook.Activate
MsgBox "..."
...
AppActivate() (this command threw an error):
...
AppActivate("Microsoft excel")
MsgBox "..."
...
How about playing a sound when the program finishes?
Place this declaration at the top of a standard code module, above any procedures existing there.
Public Declare Function Beep Lib "kernel32" _
(ByVal dwFreq As Long, _
ByVal dwDuration As Long) As Long
If you place this procedure in the same module you may not need it to be public. Adjust pitch and duration to your preference.
Sub EndSound()
Beep 500, 1000
End Sub
Then place the procedure call at the end of your program.
Call EndSound
I suppose you might use a more elaborate sound - may I suggest a couple of bars from Beethoven's 5th? Modify the EndSound procedure. Chip Pearson has more on this idea.
Try:
Application.WindowState = xlMaximized
Disclaimer: This is not my code and I do not know who the author is. I had this code in my database.
Put your code in Sub Sample(). I have shown where you can insert your code. Once the code is run, Excel will flash 5 times. you can change this number by changing Private Const NumberOfFlashes = 5
Paste this in a Module.
Option Explicit
Private Type FLASHWINFO
cbSize As Long
Hwnd As Long
dwFlags As Long
uCount As Long
dwTimeout As Long
End Type
Private Const FLASHW_STOP As Long = 0
Private Const FLASHW_CAPTION As Long = &H1
Private Const FLASHW_TRAY As Long = &H2
Private Const FLASHW_ALL As Long = (FLASHW_CAPTION Or FLASHW_TRAY)
Private Const FLASHW_TIMER As Long = &H4
Private Const FLASHW_TIMERNOFG As Long = &HC
Private FLASHW_FLAGS As Long
Private Declare Function LoadLibrary Lib "kernel32" _
Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" _
(ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32" _
(ByVal hLibModule As Long) As Long
Private Declare Function FlashWindowEx Lib "user32" _
(FWInfo As FLASHWINFO) As Boolean
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Const NumberOfFlashes = 5
Private Function APIFunctionPresent(ByVal FunctionName _
As String, ByVal DllName As String) As Boolean
Dim lHandle As Long
Dim lAddr As Long
lHandle = LoadLibrary(DllName)
If lHandle <> 0 Then
lAddr = GetProcAddress(lHandle, FunctionName)
FreeLibrary lHandle
End If
APIFunctionPresent = (lAddr <> 0)
End Function
Sub Sample()
'
' Put your code here. Once that code finishes, Excel will FLASH
'
Dim udtFWInfo As FLASHWINFO
If Not APIFunctionPresent("FlashWindowEx", "user32") Then Exit Sub
With udtFWInfo
.cbSize = Len(udtFWInfo)
.Hwnd = Application.Hwnd
.dwFlags = FLASHW_FLAGS Or FLASHW_TRAY
.uCount = NumberOfFlashes
.dwTimeout = 0
End With
Call FlashWindowEx(udtFWInfo)
MsgBox "Done"
End Sub
The easiest way is to probably to create a userform instead then set the focus to this when it initialises.
Code in the userform to show as modal:
Private Declare Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName _
As String, ByVal lpWindowName As String) As Long
Private Declare Function SetWindowPos Lib "User32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, _
ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2
Private Const FLAGS As Long = SWP_NOMOVE Or SWP_NOSIZE
Private Const HWND_TOPMOST = -1
Private Sub UserForm_Initialize()
Dim hwnd As Long: hwnd = FindWindow(vbNullString, Me.Caption)
If hwnd > 0 Then SetWindowPos hwnd, HWND_TOPMOST, 0, 0, 0, 0, FLAGS ' Set Modal
End Sub

VBA Macro to copy different cell values in a Notepad

I want to copy the different cells data into a notepad. How do i do that.
Example : values from row3 column B(B3), then from row3 column E(E3).
Thanks in advance.
Using a helper module you could:
Dim cell As Range
Dim concat As String
For Each cell In Range("$B$3,$E$3")
concat = concat & vbCrLf & cell.Value
Next
' Debug.Print concat
Text2Clipboard concat
If instead of Range("$B$3,$E$3") you said Selection you'd end up with all the cells currently selected.
Hint: You can select inidivual cells using Ctrl+LeftMouseButton
You need the following helper definitions somewhere in your VBA project (I suggest a module named like 'Clipboard'):
Declare Function abOpenClipboard Lib "User32" Alias "OpenClipboard" (ByVal Hwnd As Long) As Long
Declare Function abCloseClipboard Lib "User32" Alias "CloseClipboard" () As Long
Declare Function abEmptyClipboard Lib "User32" Alias "EmptyClipboard" () As Long
Declare Function abIsClipboardFormatAvailable Lib "User32" Alias "IsClipboardFormatAvailable" (ByVal wFormat As Long) As Long
Declare Function abSetClipboardData Lib "User32" Alias "SetClipboardData" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Declare Function abGetClipboardData Lib "User32" Alias "GetClipboardData" (ByVal wFormat As Long) As Long
Declare Function abGlobalAlloc Lib "Kernel32" Alias "GlobalAlloc" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Declare Function abGlobalLock Lib "Kernel32" Alias "GlobalLock" (ByVal hMem As Long) As Long
Declare Function abGlobalUnlock Lib "Kernel32" Alias "GlobalUnlock" (ByVal hMem As Long) As Boolean
Declare Function abLstrcpy Lib "Kernel32" Alias "lstrcpyA" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Declare Function abGlobalFree Lib "Kernel32" Alias "GlobalFree" (ByVal hMem As Long) As Long
Declare Function abGlobalSize Lib "Kernel32" Alias "GlobalSize" (ByVal hMem As Long) As Long
Const GHND = &H42
Const CF_TEXT = 1
Const APINULL = 0
Function Text2Clipboard(szText As String)
Dim wLen As Integer
Dim hMemory As Long
Dim lpMemory As Long
Dim retval As Variant
Dim wFreeMemory As Boolean
' Get the length, including one extra for a CHR$(0) at the end.
wLen = Len(szText) + 1
szText = szText & Chr$(0)
hMemory = abGlobalAlloc(GHND, wLen + 1)
If hMemory = APINULL Then
MsgBox "Unable to allocate memory."
Exit Function
End If
wFreeMemory = True
lpMemory = abGlobalLock(hMemory)
If lpMemory = APINULL Then
MsgBox "Unable to lock memory."
GoTo T2CB_Free
End If
' Copy our string into the locked memory.
retval = abLstrcpy(lpMemory, szText)
' Don't send clipboard locked memory.
retval = abGlobalUnlock(hMemory)
If abOpenClipboard(0&) = APINULL Then
MsgBox "Unable to open Clipboard. Perhaps some other application is using it."
GoTo T2CB_Free
End If
If abEmptyClipboard() = APINULL Then
MsgBox "Unable to empty the clipboard."
GoTo T2CB_Close
End If
If abSetClipboardData(CF_TEXT, hMemory) = APINULL Then
MsgBox "Unable to set the clipboard data."
GoTo T2CB_Close
End If
wFreeMemory = False
T2CB_Close:
If abCloseClipboard() = APINULL Then
MsgBox "Unable to close the Clipboard."
End If
If wFreeMemory Then GoTo T2CB_Free
Exit Function
T2CB_Free:
If abGlobalFree(hMemory) <> APINULL Then
MsgBox "Unable to free global memory."
End If
End Function
Notes
code 'borrowed' from http://www.everythingaccess.com/tutorials.asp?ID=Copying-data-to-and-from-the-Clipboard-(Acc-95%2B)
tested in Excel 2003 on Windows XP SP3
Write your cell values to a text file, then open it in Notepad or your favourite text editor.
' Write to file.
Open "C:\temp.txt" For Output As #1
Print #1, Range("B3").Value, Range("C4").Value
Print #1, Range("Q981").Value, "hello world!" ' or whatever else
Close #1
' Now open it in notepad.
Shell ("notepad ""C:\temp.txt""")

Resources