This question already has answers here:
There is no Wait Method associated with Application in VisualBasic Word
(4 answers)
Closed 3 years ago.
I would like to have a break where it randomly waits between 5-10 minutes before going to the next i.
Unfortunately the function Application.Wait does not work in Word.
Do you have another solution for me?
I don't know much about macros.
-
The Error is: Error during compilation:
Constants, character strings of fixed length, user-defined data fields and Declare statements are not permitted as public elements of object modules.
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
Sub Test_DE()
If MsgBox("Wirklich senden?", vbYesNo, "Senden") <> vbYes Then Exit Sub
Application.ScreenUpdating = False
Dim i As Long
With ActiveDocument
For i = 1 To .MailMerge.DataSource.RecordCount
With .MailMerge
.Destination = wdSendToEmail
.MailSubject = "xxxx"
.MailFormat = wdMailFormatHTML
.MailAddressFieldName = "EMAIL"
.SuppressBlankLines = True
With .DataSource
.FirstRecord = i
.LastRecord = i
.ActiveRecord = i
End With
.Execute Pause:=False
End With
Delay = Int((600000 - 300000 + 1) * Rnd + 300)
Sleep (Delay)
'CreateObject("Excel.Application").Wait (Now + TimeValue("00:00:Delay"))
'Dim PauseDelay As Long
'PauseDelay = Int((600 - 300 + 1) * Rnd + 300) ' Stores the random interval between 300-480
'Call Pause(PauseDelay) ' Calls Pause with the random interval
Next i
End With
Application.ScreenUpdating = True
End Sub
If you work on Windows...
Open a normal module (in VBE press Alt+I, M) then place the code below at the beginning.
#If VBA7 And Win64 Then
' For 64bit version of Excel
Public Declare PtrSafe Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As LongPtr)
#Else
' For 32bit version of Excel
Public Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
#End If
Then you could use sleep 1000 to wait for one second.
Related
I have a large amount of data to scroll through every day and an autoscroll macro that pauses when a key is pressed (and resumes with a button push) would be a big help.
So far, I've tried:
Sub Autoscroll()
Dim RowCount As Integer
Dim i As Integer
RowCount = Range("Table").Rows.Count
For i = RowCount + 1 To 2 Step -1
Range("A" & i).Select
Application.Wait (Now + TimeValue("0:00:01"))
Next i
End Sub
But this doesn't achieve what I want for a few reasons:
It doesn't pause when I press a key
It can't go faster than 1 second. (I could use the Sleep function to make the scroll move faster)
Looking for some recommendations about the best way to do this.
Thank you
If you insist on using a macro try this, it should do the trick (if you are using Windows!).
You have to press the return key to interrupt. If you'd prefer a different key let me know.
Option Explicit
#If VBA7 Then
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
#Else
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
#End If
'Sub pausing code execution without freezing the app or causing high CPU usage
'Author: Guido Witt-Dörring, https://stackoverflow.com/a/74387976/12287457
Public Sub WaitSeconds(ByVal seconds As Single)
Const VK_RETURN = &HD
Dim currTime As Single, endTime As Single, cacheTime As Single
currTime = Timer(): endTime = currTime + seconds: cacheTime = currTime
Do While currTime < endTime
If GetAsyncKeyState(VK_RETURN) Then
Sleep 200
Do Until GetAsyncKeyState(VK_RETURN)
DoEvents: Sleep 15
Loop
Sleep 200
End If
DoEvents: Sleep 15: currTime = Timer()
'The following is necessary because the Timer() function resets at 00:00
If currTime < cacheTime Then endTime = endTime - 86400! 'seconds per day
cacheTime = currTime
Loop
End Sub
Sub Autoscroll()
Dim RowCount As Long
Dim i As Long
RowCount = Range("Table").Rows.Count
For i = RowCount + 1 To 2 Step -1
WaitSeconds 0.5 '<-- this is how long it waits at every row,
Range("A" & i).Select 'set it to your desired value
Next i
End Sub
I have a working VBA macro which enters SAP, starts a transaction and then extracts the data in spreadsheet.
But sometimes the calculation runs too long, or I just would like to stop it to intervene. There is a functionality on the toolbar at the top left corner, where the user can "stop transaction" manually.
Is there any SAP script code for the "stop transaction" button, so I can avoid the manual step?
SAP toolbar:
It is assumed that the VBA macro is running in the first session. If a second session is opened before starting the macro, it can be used to close the first session.
for example:
Set SapGuiAuto = GetObject("SAPGUI")
Set SAPapp = SapGuiAuto.GetScriptingEngine
Set SAPconnection = SAPapp.Children(0)
Set session = SAPconnection.Children(1)
session.findById("wnd[0]/tbar[0]/okcd").text = "/i1"
session.findById("wnd[0]").sendVKey 0
session.createSession
Application.Wait (Now + TimeValue("0:00:05"))
session.findById("wnd[0]/tbar[0]/okcd").text = "/i3"
session.findById("wnd[0]").sendVKey 0
session.createSession
Application.Wait (Now + TimeValue("0:00:05"))
Whether a "rollback" is carried out or not, would be to test.
Regards,
ScriptMan
I guess you better record a script with this scenario, then you can re-use it any time.
Otherwise, I am at the very moment struggling with the same case, but with the run time counter part to leave the tcode if running too long.
It is a hart nut to crack too, but a different topic.
Update: realizing that there is no way to get the 'Stop Transaction' step recorded, I applied the above method - thank you Script Man, it was not the first time you saved the day.
For anyone reading this thread - may be useful to know how to split the SAP runtime from VBA script runtime.
I introduced an object that is the 'Execute' command itself. This way, SAP takes the command and starts execution, while the macro will step over as it is not an actual command but applying a new object only. This trick can help users to write a time counter and drop the session if running too long.
For reference, see my code here - I quoted the part of my code that contains the relevant method.
'check whether you already have an extra session open to close the long running session
'open one if needed
On Error Resume Next
Set session1 = Connection.Children(1)
If Err.Number <> 0 Then
session.CreateSession
Application.Wait (Now + TimeValue("0:00:05"))
're-set the sessions, ensuring you use the first session for actual work and keep session1 in background
Set session = Connection.Children(0)
Set session1 = Connection.Children(1)
SesCount = Connection.Sessions.Count()
Err.Clear
On Error GoTo 0
End If
'get the ID of first session, so you can enter the correct terminating transaction code when needed
sessionID = Mid(session.ID, (InStrRev(session.ID, "[") + 1), 1)
Terminator = "/i" & sessionID + 1
session.FindById("wnd[0]").Maximize
'some code comes here
'here I use an object to apply the execute button - this way parallel with the SAP runtime, the VBA script can proceed.
perec = session.FindById("wnd[0]/tbar[1]/btn[8]").press
'here we set a loop to check whether system is busy over a certain time then we may interrupt:
Do
Application.Wait (Now + TimeValue("0:00:05"))
SecondsElapsed = SecondsElapsed + 5
fityirc = session.Busy()
if fityirc = False then
exit Do
end if
Loop Until SecondsElapsed >= 100
If fityirc = True Then
session1.FindById("wnd[0]/tbar[0]/okcd").Text = Terminator
session1.FindById("wnd[0]").sendVKey 0
End If
'...and so on. This solution is applied in a loop to extract datasets massively without human interaction.
Or, have a look at code I've just written and tested to use the Windows API to run the Stop Transaction menu item. I raised a question about it on the SAP forum, but figured it out myself in the meantime (SAP Forum)
Private Declare PtrSafe Function FindWindowA Lib "user32.dll" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function GetSystemMenu Lib "user32" (ByVal hWnd As LongPtr, ByVal bRevert As Long) As LongPtr
Private Declare PtrSafe Function GetMenuItemCount Lib "user32" (ByVal hMenu As LongPtr) As Long
Private Declare PtrSafe Function GetMenuItemInfoA Lib "user32" (ByVal hMenu As LongPtr, ByVal un As Long, ByVal b As Long, lpMenuItemInfo As MENUITEMINFO) As Long
Private Declare PtrSafe Function SendMessageA Lib "user32" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Public Const MIIM_STRING As Integer = &H40
Public Const MIIM_ID = &H2
Public Const WM_COMMAND = &H111
Public Const WM_SYSCOMMAND = &H112
Public Type MENUITEMINFO
cbSize As Long
fMask As Long
fType As Long
fState As Long
wID As LongPtr
hSubMenu As Long
hbmpChecked As Long
hbmpUnchecked As Long
dwItemData As Long
dwTypeData As String
cch As Long
End Type
Public Function RunMenuItemByString(ByVal sMenuItem As String, _
ByVal sWindowClass As String, _
ByVal sWindowText As String, _
ByVal iCommandType As Integer) As Boolean
Dim hWnd As LongPtr, hMenu As LongPtr, lpMenuItemID As LongPtr
Dim lngMenuItemCount As Long, lngMenuItem As Long, lngResultMenuItemInfo As Long
Dim typMI As MENUITEMINFO
Dim s As String
Dim blnRet As Boolean
hWnd = FindWindowA(sWindowClass, sWindowText)
hMenu = GetSystemMenu(hWnd, 0&)
lngMenuItemCount = GetMenuItemCount(hMenu)
For lngMenuItem = 0 To lngMenuItemCount - 1
typMI.cbSize = Len(typMI)
typMI.dwTypeData = String$(255, " ")
typMI.cch = Len(typMI.dwTypeData)
typMI.fMask = MIIM_STRING Or MIIM_ID
lngResultMenuItemInfo = GetMenuItemInfoA(hMenu, lngMenuItem, 1, typMI)
s = Trim$(typMI.dwTypeData)
lpMenuItemID = typMI.wID
If InStr(1, s, sMenuItem, vbTextCompare) > 0 Then
blnRet = SendMessageA(hWnd, iCommandType, lpMenuItemID, 0&) = 0
Exit For
End If
Next lngMenuItem
RunMenuItemByString = blnRet
End Function
Public Function TestRunMenuItemByString()
lpHwndSAPSession = oSAPSession.FindById("wnd[0]").Handle
sWindowText = GetWindowText(lpHwndSAPSession)
TestRunMenuItemByString = RunMenuItemByString("Stop Transaction", "SAP_FRONTEND_SESSION", sWindowText, WM_SYSCOMMAND)
End Function
The TestRunMenuItemByString function can be used only after a session is started, and will only work if there is actually a transaction executing. You will need to figure out how to reference your sap session object (oSAPSession) in order to use the Handle value from it.
The declarations should work in both 32 bit and 64 bit versions of VBA and the LongPtr has been used for the handle (h) and pointer (lp) variables to reflect this.
This was tested in Microsoft Access, but I see no reason why it shouldn't work in VBA in other Office applications. I can't vouch for it being adaptable for VBScript.
I am using Excel VBA to copy text selection from an Access file (I'd prefer not to get into details as to why). I have it in a Do While loop that SHOULD press the tab key (works), then copies the data (fails), puts it into the clipboard (works), and sets the clipboard information to a variable (works), which then, for debugging purposes, does a debug.print of the variable (works). This is to cycle through a form to get to a "base point" where I can 100% use tabs and such to navigate to other parts of the form. See code please:
AppActivate ("Microsoft Access - Filename that is constant")
X = 0
Do While X < 14
Application.SendKeys "{TAB}", True
Application.SendKeys "^C", True
Sleep (500)
mydata.GetFromClipboard
cb = mydata.GetText
Debug.Print (cb)
If Len(cb) = 5 Then
X = 14
End If
X = X + 1
Loop
Set mydata = Nothing
I've tried getting this to work, but to no avail. What am I doing wrong or perhaps what would be a better solution?
Though I hate Sendkeys and was wondering whether I should ask you about it but since you said not to ask why, I will keep my trap shut. :P
Try this small fix... If this works then that means, you need to give it some time before issuing the next sendkeys command.
Sub Sample()
'
'~~> Rest of your code
'
Application.SendKeys "{TAB}", True
Wait 2
Application.SendKeys "^{C}", True
'
'~~> Rest of your code
'
End Sub
Private Sub Wait(ByVal nSec As Long)
nSec = nSec + Timer
While nSec > Timer
DoEvents
Wend
End Sub
what would be a better solution?
Use APIs as shown Here. This doesn't directly answer your question but it explains how the concept works.
So applying that would be something like this
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Dim Ret As Long
Sub Sample()
Ret = FindWindow(vbNullString, "Microsoft Access - Filename that is constant")
If Ret <> 0 Then
MsgBox "Window Found"
Else
MsgBox "Window Not Found"
End If
End Sub
If you wish to become good at API’s like FindWindow, FindWindowEx and SendMessage then get a tool that gives you a graphical view of the system’s processes, threads, windows, and window messages. For Ex: uuSpy or Spy++. Another example which demonstrates how this API is used.
I figured it out. I copied the code from here: http://www.vbaexpress.com/forum/showthread.php?38826-SendInput()-in-Excel-64Bit
I changed VkkeyMenu to VbKeyControl and the "f" key to "C". I know it could be simplified to take up less lines, but I'd rather not mess with it if it works like the saying "If it ain't broke, don't fix it." Code:
Private Declare PtrSafe Function SendInput Lib "user32" (ByVal nInputs As LongPtr, pInputs As Any, ByVal cbSize As LongPtr) As LongPtr
Private Declare PtrSafe Function VkKeyScan Lib "user32" Alias "VkKeyScanA" (ByVal cChar As Byte) As Integer
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Type KeyboardInput ' creating variable type
dwType As Long ' input type (keyboard or mouse)
wVk As Integer ' the key to press/release as ASCSI scan code
wScan As Integer ' not required
dwFlags As Long ' specify if key is pressed or released
dwTime As Long ' not required
dwExtraInfo As Long ' not required
dwPadding As Currency ' only required for mouse inputs
End Type
' SendInput constants
Private Const INPUT_KEYBOARD As Long = 1
Private Const KEYEVENTF_EXTENDEDKEY As Long = 1
Private Const KEYEVENTF_KEYUP As Long = 2
' Member variables
Private TheKeys() As KeyboardInput
Private NEvents As Long
Sub testage()
ReDim TheKeys(0 To 3)
With TheKeys(0)
.dwType = INPUT_KEYBOARD 'operation type
.wVk = vbKeyControl 'press CTRL key
End With
With TheKeys(1)
.dwType = INPUT_KEYBOARD ' operation
.wVk = VkKeyScan(Asc("C")) 'press chr key
End With
With TheKeys(2)
.dwType = INPUT_KEYBOARD 'operation type
.wVk = VkKeyScan(Asc("C"))
.dwFlags = KEYEVENTF_KEYUP 'release chr key
End With
With TheKeys(3)
.dwType = INPUT_KEYBOARD ' operation type
.wVk = vbKeyControl
.dwFlags = KEYEVENTF_KEYUP 'release CTRL Key
End With
Call SendInput(4, TheKeys(0), Len(TheKeys(0)))
Erase TheKeys
End Sub
I have run the following program on vba excel 2010 32 bit computer :
Declare Sub sleep Lib "kernel32" (ByVal dwmilliseconds As Long)
Sub game()
i = 0
Do
i = i + 1
Cells(i, 1).Interior.Color = RGB(100, 0, 0)
sleep 500
Loop Until i > 10
End Sub
But, after running, it shows me the following error :
"Can't find dll entry point sleep in kernel32"
Can somebody please tell me what I should do next to remove the error?
Thanks for the effort.
Instead of sleep 500 you might want to use:
Application.Wait (Now + TimeValue("0:00:05"))
#Transistor is correct. You have to use capital "S". All API declarations are case sensitive.
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
An alternative to Sleep is to use the function Wait which I created few years ago and I still use it.
Sub Sample()
i = 0
Do
i = i + 1
Cells(i, 1).Interior.Color = RGB(100, 0, 0)
Wait 1
Loop Until i > 10
End Sub
Private Sub Wait(ByVal nSec As Long)
nSec = nSec + Timer
While nSec > Timer
DoEvents
Wend
End Sub
I'm going nuts here...
How do you find the "hwnd" value of a CommandButton, in an Excel 2007 Form ?
I've Googled, I've tried all kinds of suggestions (most of which suggest that a command button has a .hwnd member property - but it doesn't) and haven't found an answer.
I can get the Form's hwnd value, and (in theory) should be able to use a EnumChildWindows to find sub-windows, including my button, but this also doesn't work.
Has anyone managed to do this ?
I'm afraid you can't, MS Forms controls like CommandButtons are not windows at all, they are "Windowless controls" i.e they are drawn by the MS Forms Runtime onto the userform surface as purely graphical abstractions, so no HWND.
' this may format
' in a worksheet have driver buttons for
Option Explicit: Option Compare Text
Private Sub ControlsDet_Click()
LookFrames
End Sub
Private Sub PaintValid_Click()
PaintAll
End Sub
Private Sub ShowForm_Click()
UFS.Show False
End Sub
Private Sub TextON_Click()
DoTextOn
End Sub
' then have a form UFS and put in some controls from the tool box
'put in frames and listboxes and whatever
.
.have a code module as
Option Explicit: Option Compare Text
'
'http://www.tek-tips.com/viewthread.cfm?qid=1394490
'
' to look at the useage of CtrlName.[_GethWnd] function
' VB has a function for hWnd but VBA hides its brother as [_GetwHnd]
' in VBA there are haves and have_nots
' better than finding each control's position in pixels and then using
'Private Declare Function WindowFromPoint& Lib "user32" (ByVal xPoint&, ByVal yPoint&)
'
'
Type RECT ' any type with 4 long int will do
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'
Type RECTxy
X1 As Long
Y1 As Long
X2 As Long
Y2 As Long
End Type
'
' OK as Private here or public elsewhere
'
Declare Function GetClientRect& Lib "User32.dll" (ByVal hwnd&, ByRef lpRECT As RECTxy)
Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Declare Function DeleteObject& Lib "gdi32" (ByVal hndobj&)
Declare Function FillRectXY& Lib "User32.dll" Alias "FillRect" (ByVal Hdc&, lpRECT As RECTxy, ByVal hBrush&)
Declare Function GetDC& Lib "user32" (ByVal hwnd&)
Declare Function DeleteDC& Lib "gdi32" (ByVal hwnd&)
Declare Function TextOut& Lib "GDI32.dll" Alias "TextOutA" (ByVal Hdc&, ByVal x&, ByVal y&, _
ByVal lpString$, ByVal nCount&)
Function RndPale&(Optional R% = 150, Optional G% = 170, Optional B% = 140)
RndPale = RGB(R + Rnd() * (250 - R), G + Rnd() * (255 - G), B + Rnd() * (250 - G))
End Function
Sub PaintAll()
Dim Wc As Control
For Each Wc In UFS.Controls
Showrec Wc
Next Wc
End Sub
Sub Showrec(WCtrl As Control)
Dim hBrush&, Outwr As RECTxy, WCtrlhWnd&, WCtrlHDC&
WCtrlhWnd = WCtrl.[_GethWnd]
If WCtrlhWnd <> 0 Then ' has handle
WCtrlHDC = GetDC(WCtrlhWnd)
GetClientRect WCtrlhWnd, Outwr
hBrush = CreateSolidBrush(RndPale)
FillRectXY WCtrlHDC, Outwr, hBrush
DeleteObject hBrush
DeleteDC WCtrlHDC
DeleteObject WCtrlhWnd
End If
End Sub
Sub LookFrames()
Dim WCtrl As Control, rI%, Ra As Range
Dim Outwr As RECTxy, WCtrlhWnd&
Set Ra = ActiveSheet.Range("e4:r30")
Ra.NumberFormat = "0.0"
Ra.ClearContents
UFS.Show False
rI = 4
For Each WCtrl In UFS.Controls
WCtrlhWnd = WCtrl.[_GethWnd]
rI = rI + 1
Cells(rI, 5) = WCtrl.Name
Cells(rI, 6) = TypeName(WCtrl)
Cells(rI, 7) = WCtrlhWnd
Cells(rI, 8) = WCtrl.Left
Cells(rI, 9) = WCtrl.Top
Cells(rI, 10) = WCtrl.Width
Cells(rI, 11) = WCtrl.Height
If WCtrlhWnd <> 0 Then
GetClientRect WCtrlhWnd, Outwr
Cells(rI, 12) = Outwr.X1
Cells(rI, 13) = Outwr.Y1
Cells(rI, 14) = Outwr.X2
Cells(rI, 15) = Outwr.Y2
DeleteObject WCtrlhWnd
End If
Next WCtrl
Ra.Columns.AutoFit
End Sub
Sub DoTextOn()
UFS.Show False
Dim WHnd&, FHdc&, Tout$, Wc As Control
For Each Wc In UFS.Controls
WHnd = Wc.[_GethWnd]
If WHnd <> 0 Then
FHdc = GetDC(WHnd)
Tout = Wc.Name & " as " & WHnd
TextOut FHdc, 10, 20, Tout, Len(Tout)
DeleteDC FHdc
DeleteObject WHnd
End If
Next Wc
End Sub