How to Solve Undesirable Alt key Behavior?

G

glasstronomic

New Member
Joined
Apr 29, 2009
Messages
10
Office Version
  1. 365
Hi friends,

I'm a long time lurker and first time poster who needs help.

I have a complex project that works great, except for one issue that has me at wit's end.

It has many necessary loops with disciplined use of DoEvents and assuring no concurrent loops. It is intended for blind users who must operate it in conjunction with screen reader apps, so it depends heavily on accelerator keys and is mindful of focus conditions.

The problem is when the main UserForm named ControlPanel has focus, Alt+ accelerator keys work fine. But tapping or holding and releasing Alt without an accelerator key pauses execution and makes ControlPanel unresponsive until Alt is tapped again. This is especially problematic for blind users who don't get immediate feedback that this has occurred. As far as they can tell, the thing just stopped working. The fix of tapping again is in the readme, but y'all know about users and readme's.

I have beat my head against the wall all weekend while struggling with this. Even ChatGPT gave up and admitted it can't fix it after days of different attempts including Windows API calls, disabling Excel's default Alt key handling, modal and modeless form displays (the form must remain modeless for reader compatibility reasons), and many others. So many Debug.Print and so many failures.

Can you help? Code for ControlPanel...

VBA Code: 
Option Explicit

#If VBA7 Then
    ' Sleep function for VBA7 (Excel 2010 and later)
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
    ' Sleep function for older VBA versions (Excel 2007 and earlier)
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

Private Sub UserForm_Initialize()
  
    ' some stuff I have to hide for privacy, sorry, should not affect keyups or keydowns

End Sub

Private Sub UserForm_Activate()

    cntrlPnl = True
    isPausedBkwd = True
    isPausedFwd = True
    stopPlayback = False
    zmLp = False
  
    currentRow = 1
    previousRow = 2
    ProgressBar.Enabled = True
    ProgressBar.Refresh
    ProgressBar.Min = 1
    ProgressBar.Max = lastRow
    ProgressBar.Value = currentRow
  
    If firstImport <> False Then stereoWide = True
  
    If stereoWide = False Then
        StereoWidth.Caption = "Stereo is narrow" & vbCrLf & "Key Alt+w"
        StereoWidth.ControlTipText = "Stereo is narrow"
    Else
        StereoWidth.Caption = "Stereo is wide" & vbCrLf & "Key Alt+w"
        StereoWidth.ControlTipText = "Stereo is wide"
    End If
  
    ImportedFileName.Caption = fileName
    ImportedFileName.ControlTipText = fileName
    DataPoints.Caption = lastRow & " data points"
    DataPoints.ControlTipText = lastRow & " data points"
    AmplitudeRange.Caption = Application.WorksheetFunction.Min(ws.Range("B1:B" & lastRow)) & " to " & Application.WorksheetFunction.Max(ws.Range("B1:B" & lastRow)) & " dBm"
    AmplitudeRange.ControlTipText = Application.WorksheetFunction.Min(ws.Range("B1:B" & lastRow)) & " to " & Application.WorksheetFunction.Max(ws.Range("B1:B" & lastRow)) & " dBm"
    FrequencySpan.Caption = Application.WorksheetFunction.Min(ws.Range("A1:A" & lastRow)) & " to " & Application.WorksheetFunction.Max(ws.Range("A1:A" & lastRow)) & " megahertz"
    FrequencySpan.ControlTipText = Application.WorksheetFunction.Min(ws.Range("A1:A" & lastRow)) & " to " & Application.WorksheetFunction.Max(ws.Range("A1:A" & lastRow)) & " megahertz"
    Speed.Caption = playSpeed & " milliseconds per point speed"
    Speed.ControlTipText = playSpeed & " milliseconds per point speed"
  
    UpdateReadouts
  
    HalfSpeed.Caption = "Half Speed" & vbCrLf & vbCrLf & "Key Alt+7"
    SlowDown1ms.Caption = "Go Slower by" & vbCrLf & "0.5 millisecond" & vbCrLf & "per point" & vbCrLf & vbCrLf & "Key Alt+8"
    SpeedUp1ms.Caption = "Go Faster by" & vbCrLf & "0.5 millisecond" & vbCrLf & "per point" & vbCrLf & vbCrLf & "Key Alt+9"
    DoubleSpeed.Caption = "Double Speed" & vbCrLf & vbCrLf & "Key Alt+0"
    PlayBackward.Caption = "Play Backward" & vbCrLf & vbCrLf & "Key Alt+b"
    Pause.Caption = "Pause" & vbCrLf & vbCrLf & "Key Alt+p"
    PlayForward.Caption = "Play Forward" & vbCrLf & vbCrLf & "Key Alt+f"
    ZoomLoop.Caption = "Zoom Loop is Off" & vbCrLf & vbCrLf & "Key Alt+z"
    ZoomLoop.ControlTipText = "Zoom Loop is Off"
  
    SkipBackward500Points.Caption = "Skip Backward" & vbCrLf & "500 points" & vbCrLf & vbCrLf & "Key Alt+h"
    SkipBackward1Point.Caption = "Skip Backward" & vbCrLf & "1 point" & vbCrLf & vbCrLf & "Key Alt+j"
    SkipForward1Point.Caption = "Skip Forward" & vbCrLf & "1 point" & vbCrLf & vbCrLf & "Key Alt+k"
    SkipForward500Points.Caption = "Skip Forward" & vbCrLf & "500 points" & vbCrLf & vbCrLf & "Key Alt+l"
    SkipToFirstPoint.Caption = "Skip to" & vbCrLf & "first point" & vbCrLf & vbCrLf & "Key Alt+1"
    SkipToMidPoint.Caption = "Skip to" & vbCrLf & "middle point" & vbCrLf & vbCrLf & "Key Alt+2"
    SkipToEndPoint.Caption = "Skip to" & vbCrLf & "last point" & vbCrLf & vbCrLf & "Key Alt+3"
    StopClearAndImportNew.Caption = "Stop and" & vbCrLf & "clear data to" & vbCrLf & "import a new file" & vbCrLf & vbCrLf & "Key Alt+s"
  
    Sleep 300
  
    AllSoundsOff

    SendMIDIControlChange 91, 10
    SendMIDIControlChange 93, 0
    SetPitchBendSensitivity 1, 48, 0
  
    If stereoWide = True Then
        StereoPanWide
    Else
        StereoPanNarrow
    End If
  
    ScrubPadsEnable

    If lastRow <= 32767 Then
        ScrubPad1.Max = lastRow
        ScrubPad1.Value = Int(ControlPanel.ScrubPad1.Max / 2)
        ScrubPadsUpdate
    Else
        ScrubPad1.Max = 32767
        ScrubPad1.Value = Int(ControlPanel.ScrubPad1.Max / 2)
        ScrubPadsUpdate
    End If
  
    If scrbPdMPos = False Then
        quitPdMPos = True
        MouseLock.Caption = "ScrubPad MouseLock is Off" & vbCrLf & "Key Alt+m"
        MouseLock.ControlTipText = "ScrubPad MouseLock is Off"
    Else
        quitPdMPos = False
        MouseLock.Caption = "ScrubPad MouseLock is On" & vbCrLf & "Key Alt+m"
        MouseLock.ControlTipText = "ScrubPad MouseLock is On"
        MonoAscending
        If scrbPdMPos = True And msTmrRunning = False Then ScrbMouseTimer
    End If
  
End Sub

Private Sub StereoWidth_Click()

        If stereoWide = True Then
            StereoWidth.Caption = "Stereo is narrow" & vbCrLf & "Key Alt+w"
            StereoWidth.ControlTipText = "Stereo is narrow"
            stereoWide = False
            If isPausedBkwd = True And isPausedFwd = True Then StereoPanNarrow
        Else
            StereoWidth.Caption = "Stereo is wide" & vbCrLf & "Key Alt+w"
            StereoWidth.ControlTipText = "Stereo is wide"
            stereoWide = True
            If isPausedBkwd = True And isPausedFwd = True Then StereoPanWide
        End If
  
End Sub

Private Sub MouseLock_Click()

    If scrbPdMPos = False Then
        isPausedBkwd = True
        isPausedFwd = True
        scrbPdMPos = True
        quitPdMPos = False
        MouseLock.Caption = "ScrubPad MouseLock is On" & vbCrLf & "Key Alt+m"
        MouseLock.ControlTipText = "ScrubPad MouseLock is On"
        MonoAscending
        ScrubPadsEnable
        If scrbPdMPos = True And msTmrRunning = False Then ScrbMouseTimer
    Else
        isPausedBkwd = True
        isPausedFwd = True
        scrbPdMPos = False
        quitPdMPos = True
        MouseLock.Caption = "ScrubPad MouseLock is Off" & vbCrLf & "Key Alt+m"
        MouseLock.ControlTipText = "ScrubPad MouseLock is Off"
        MonoDescending
    End If

End Sub

Private Sub HelpReadMe_Click()

    isPausedBkwd = True
    isPausedFwd = True
    scrbPdMPos = False
    quitPdMPos = True
    MouseLock.Caption = "ScrubPad MouseLock is Off" & vbCrLf & "Key Alt+m"
    MouseLock.ControlTipText = "ScrubPad MouseLock is Off"
    MonoDescending
  
    Sleep 200

    HelpFileNotepad
    Beeper

End Sub

Private Sub ProgressBar_Change()

    If zmLp = True Then
        If isPausedBkwd = True And isPausedFwd = True Then
          
            currentRow = ProgressBar.Value
          
            If zoomPreviousRow < currentRow And currentRow = zoomLastRow Then
                ProgressBar.Value = zoomFirstRow
                currentRow = zoomFirstRow
            Else
                If zoomPreviousRow > currentRow And currentRow = zoomFirstRow Then
                    ProgressBar.Value = zoomLastRow
                    currentRow = zoomLastRow
                End If
            End If
          
            zoomPreviousRow = currentRow
          
            CalcMIDIPan
            SendMIDIControlChange 10, panMSB ' CC10 (MSB)
            SendMIDIControlChange 42, panLSB ' CC42 (LSB)
            SendMIDIPitchBend 1, pitchBendValue ' Channel 1
            UpdateReadouts
        End If
    Else
        If isPausedBkwd = True And isPausedFwd = True Then
      
            currentRow = ProgressBar.Value
          
            If previousRow < currentRow And currentRow = lastRow Then
                ProgressBar.Value = 1
                currentRow = 1
            Else
                If previousRow > currentRow And currentRow = 1 Then
                    ProgressBar.Value = lastRow
                    currentRow = lastRow
                End If
            End If
          
            previousRow = currentRow
          
            CalcMIDIPan
            SendMIDIControlChange 10, panMSB ' CC10 (MSB)
            SendMIDIControlChange 42, panLSB ' CC42 (LSB)
            SendMIDIPitchBend 1, pitchBendValue ' Channel 1
            UpdateReadouts
        End If
    End If
  
End Sub
Private Sub ProgressBar_Scroll()

    If zmLp = True Then
        If isPausedBkwd = True And isPausedFwd = True Then
          
            currentRow = ProgressBar.Value
          
            If zoomPreviousRow < currentRow And currentRow = zoomLastRow Then
                ProgressBar.Value = zoomFirstRow
                currentRow = zoomFirstRow
            Else
                If zoomPreviousRow > currentRow And currentRow = zoomFirstRow Then
                    ProgressBar.Value = zoomLastRow
                    currentRow = zoomLastRow
                End If
            End If
          
            zoomPreviousRow = currentRow
          
            CalcMIDIPan
            SendMIDIControlChange 10, panMSB ' CC10 (MSB)
            SendMIDIControlChange 42, panLSB ' CC42 (LSB)
            SendMIDIPitchBend 1, pitchBendValue ' Channel 1
            UpdateReadouts
        End If
    Else
        If isPausedBkwd = True And isPausedFwd = True Then
      
            currentRow = ProgressBar.Value
          
            If previousRow < currentRow And currentRow = lastRow Then
                ProgressBar.Value = 1
                currentRow = 1
            Else
                If previousRow > currentRow And currentRow = 1 Then
                    ProgressBar.Value = lastRow
                    currentRow = lastRow
                End If
            End If
          
            previousRow = currentRow
          
            CalcMIDIPan
            SendMIDIControlChange 10, panMSB ' CC10 (MSB)
            SendMIDIControlChange 42, panLSB ' CC42 (LSB)
            SendMIDIPitchBend 1, pitchBendValue ' Channel 1
            UpdateReadouts
        End If
    End If
  
End Sub

Private Sub ScrubPad1_Scroll()

    If isPausedBkwd = True And isPausedFwd = True Then
        TimerReset
        Timer2sec
      
        If noteIsOn = False Then
            SendMIDINoteOn 60
        End If
      
        ProgressBar.Value = ProgressBar.Value + ScrubPad1.Value - Int(ScrubPad1.Max / 2)
        UpdateReadouts
        ScrubPadsEnable
        ScrubPad1.Value = Int(ScrubPad1.Max / 2)
    End If
  
End Sub

Private Sub SlowDown1ms_Click()

    If playSpeed + 0.5 <= 500 Then
        playSpeed = playSpeed + 0.5
    Else
        playSpeed = 500
    End If
  
    Speed.Caption = playSpeed & " milliseconds per point speed"
    Speed.ControlTipText = playSpeed & " milliseconds per point speed"
    If isPausedBkwd = True And isPausedFwd = True Then PlayCurrent
  
End Sub

Private Sub HalfSpeed_Click()

    If Int((playSpeed * 2) * 2 + 0.5) / 2 <= 500 Then
        playSpeed = Int((playSpeed * 2) * 2 + 0.5) / 2
    Else
        playSpeed = 500
    End If
  
    Speed.Caption = playSpeed & " milliseconds per point speed"
    Speed.ControlTipText = playSpeed & " milliseconds per point speed"
    If isPausedBkwd = True And isPausedFwd = True Then PlayCurrent
  
End Sub

Private Sub DoubleSpeed_Click()

    If Int(playSpeed + 0.5) / 2 >= 1 Then
        playSpeed = Int(playSpeed + 0.5) / 2
    Else
        playSpeed = 0.5
    End If
  
    Speed.Caption = playSpeed & " milliseconds per point speed"
    Speed.ControlTipText = playSpeed & " milliseconds per point speed"
    If isPausedBkwd = True And isPausedFwd = True Then PlayCurrent
      
End Sub

Private Sub SpeedUp1ms_Click()

    If playSpeed >= 1 Then
        playSpeed = playSpeed - 0.5
    Else
        playSpeed = 0.5
    End If
  
    Speed.Caption = playSpeed & " milliseconds per point speed"
    Speed.ControlTipText = playSpeed & " milliseconds per point speed"
    If isPausedBkwd = True And isPausedFwd = True Then PlayCurrent
      
End Sub

Private Sub SkipBackward500Points_Click()

    If zmLp = False Then
        If currentRow > 501 Then
            previousRow = 0
            currentRow = currentRow - 500
            ProgressBar.Value = currentRow
            UpdateReadouts
            previousRow = currentRow + 1
        Else
            previousRow = 0
            currentRow = 1
            ProgressBar.Value = currentRow
            UpdateReadouts
            previousRow = 2
        End If
    End If
  

    If zmLp = True Then
        If currentRow > zoomFirstRow + 500 Then
            zoomPreviousRow = zoomFirstRow - 1
            currentRow = currentRow - 500
            ProgressBar.Value = currentRow
            UpdateReadouts
            zoomPreviousRow = currentRow + 1
        Else
            zoomPreviousRow = zoomFirstRow - 1
            currentRow = zoomFirstRow
            ProgressBar.Value = currentRow
            UpdateReadouts
            zoomPreviousRow = currentRow + 1
        End If
    End If

    If isPausedBkwd = True And isPausedFwd = True Then PlayDing

End Sub

Private Sub SkipBackward1Point_Click()
      
    If zmLp = False Then
        If currentRow > 1 Then
            previousRow = 0
            currentRow = currentRow - 1
            ProgressBar.Value = currentRow
            UpdateReadouts
            previousRow = currentRow + 1
        End If
    End If
  
      
    If zmLp = True Then
        If currentRow > zoomFirstRow Then
            zoomPreviousRow = zoomFirstRow - 1
            currentRow = currentRow - 1
            ProgressBar.Value = currentRow
            UpdateReadouts
            zoomPreviousRow = currentRow + 1
        End If
    End If

    If isPausedBkwd = True And isPausedFwd = True Then PlayDing
  
End Sub

Private Sub SkipForward1Point_Click()
  
    If zmLp = False Then
        If currentRow < lastRow Then
            previousRow = lastRow + 1
            currentRow = currentRow + 1
            ProgressBar.Value = currentRow
            UpdateReadouts
            previousRow = currentRow - 1
        End If
    End If
  
    If zmLp = True Then
        If currentRow < zoomLastRow Then
            zoomPreviousRow = zoomLastRow + 1
            currentRow = currentRow + 1
            ProgressBar.Value = currentRow
            UpdateReadouts
            zoomPreviousRow = currentRow - 1
        End If
    End If

    If isPausedBkwd = True And isPausedFwd = True Then PlayDing
  
End Sub

Private Sub SkipForward500Points_Click()

    If zmLp = False Then
        If currentRow <= lastRow - 500 Then
            previousRow = lastRow + 1
            currentRow = currentRow + 500
            ProgressBar.Value = currentRow
            UpdateReadouts
            previousRow = currentRow - 1
        Else
            previousRow = lastRow + 1
            currentRow = lastRow
            ProgressBar.Value = currentRow
            UpdateReadouts
            previousRow = currentRow - 1
        End If
    End If
  
    If zmLp = True Then
        If currentRow <= zoomLastRow - 500 Then
            zoomPreviousRow = zoomLastRow + 1
            currentRow = currentRow + 500
            ProgressBar.Value = currentRow
            UpdateReadouts
            zoomPreviousRow = currentRow - 1
        Else
            zoomPreviousRow = zoomLastRow + 1
            currentRow = zoomLastRow
            ProgressBar.Value = currentRow
            UpdateReadouts
            zoomPreviousRow = currentRow - 1
        End If
    End If

    If isPausedBkwd = True And isPausedFwd = True Then PlayDing
  
End Sub

Private Sub PlayBackward_Click()

    AllNotesOff
    stopPlayback = False
  
    If isPausedBkwd = False Then
        isPausedBkwd = True
            quitPdMPos = False
        ProgressBar.Value = currentRow
        UpdateReadouts
        ScrubPadsEnable
        If scrbPdMPos = True And msTmrRunning = False Then ScrbMouseTimer
    Else
        isPausedFwd = True
        isPausedBkwd = False
        quitPdMPos = True
        ScrubPadsDisable
        BackwardPlay
        ProgressBar.Value = currentRow
        UpdateReadouts
    End If
  
End Sub

Private Sub Pause_Click()

    AllNotesOff
    quitPdMPos = False
    If isPausedBkwd = True And isPausedFwd = True Then PlayDing
    isPausedBkwd = True
    isPausedFwd = True
    ProgressBar.Value = currentRow
    UpdateReadouts
    ScrubPadsEnable
    If scrbPdMPos = True And msTmrRunning = False Then ScrbMouseTimer
  
End Sub

Private Sub PlayForward_Click()

    AllNotesOff
    stopPlayback = False
  
    If isPausedFwd = False Then
        isPausedFwd = True
        quitPdMPos = False
        ProgressBar.Value = currentRow
        UpdateReadouts
        ScrubPadsEnable
        If scrbPdMPos = True And msTmrRunning = False Then ScrbMouseTimer
    Else
        isPausedBkwd = True
        isPausedFwd = False
        quitPdMPos = True
        ScrubPadsDisable
        ForwardPlay
        ProgressBar.Value = currentRow
        UpdateReadouts
    End If
  
End Sub

Private Sub ZoomLoop_Click()

    If zmLp = True Then
        isPausedBkwd = True
        isPausedFwd = True
        zmLp = False
      
        currentRow = previousRow
        lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
      
        ProgressBar.Min = 1
        ProgressBar.Max = lastRow
      
        If stereoWide = True Then
            StereoPanWide
        Else
            StereoPanNarrow
        End If
      
        playSpeed = previousSpeed
      
        Speed.Caption = playSpeed & " milliseconds per point speed"
        Speed.ControlTipText = playSpeed & " milliseconds per point speed"
        UpdateReadouts
      
        ZoomLoop.Caption = "Zoom Loop is Off" & vbCrLf & vbCrLf & "Key Alt+z"
        ZoomLoop.ControlTipText = "Zoom Loop is Off"
    Else
        isPausedBkwd = True
        isPausedFwd = True
        quitPdMPos = True
      
        previousRow = currentRow
        previousSpeed = playSpeed
      
        SetZoomStart
      
        If StrPtr(zoomLowInput) = 0 Then
            GoTo QuitZmLp
        ElseIf zoomLowInput = vbNullString Then
            GoTo QuitZmLp
        End If
          
        SetZoomEnd
      
        If StrPtr(zoomHighInput) = 0 Then
            GoTo QuitZmLp
        ElseIf zoomHighInput = vbNullString Then
            GoTo QuitZmLp
        End If
      
        zmLp = True
      
        currentRow = zoomFirstRow
        lastRow = zoomLastRow
        UpdateReadouts
          
        ProgressBar.Min = zoomFirstRow
        ProgressBar.Max = zoomLastRow
      
        ZoomLoop.Caption = "Zoom Loop is On" & vbCrLf & vbCrLf & Format(ws.Cells(currentRow, "A").Value, "#000.0000") & vbCrLf & " to " & vbCrLf & Format(ws.Cells(zoomLastRow, "A").Value, "#000.0000") & vbCrLf & vbCrLf & "Key Alt+z"
        ZoomLoop.ControlTipText = "Zoom Loop is On " & Format(ws.Cells(currentRow, "A").Value, "#000.0000") & " to " & Format(ws.Cells(zoomLastRow, 1).Value, "#000.0000")
      
      
        If stereoWide = True Then
            StereoPanWide
        Else
            StereoPanNarrow
        End If
      
        zoomPreviousRow = zoomFirstRow + 1
      
        If playSpeed * (zoomLastRow - zoomFirstRow) < 2500 Then playSpeed = Int(2500 / (zoomLastRow - zoomFirstRow))
      
        Speed.Caption = playSpeed & " milliseconds per point speed"
        Speed.ControlTipText = playSpeed & " milliseconds per point speed"
      
    End If

QuitZmLp:
      
    ScrubPadsEnable
      
    quitPdMPos = False
      
    If scrbPdMPos = True And msTmrRunning = False Then ScrbMouseTimer

End Sub

Private Sub SkipToFirstPoint_Click()
  
    If zmLp = False Then
        previousRow = 0
        currentRow = 1
        ProgressBar.Value = 1
        previousRow = currentRow + 1
        UpdateReadouts
    Else
        zoomPreviousRow = zoomFirstRow - 1
        currentRow = zoomFirstRow
        ProgressBar.Value = zoomFirstRow
        zoomPreviousRow = currentRow + 1
        UpdateReadouts
    End If

    If isPausedBkwd = True And isPausedFwd = True Then PlayDing
  
End Sub

Private Sub SkipToMidPoint_Click()
  
    If zmLp = False Then
        currentRow = Int(lastRow / 2)
        ProgressBar.Value = Int(lastRow / 2)
        UpdateReadouts
    Else
        currentRow = zoomFirstRow + Int((zoomLastRow - zoomFirstRow) / 2)
        ProgressBar.Value = zoomFirstRow + Int((zoomLastRow - zoomFirstRow) / 2)
        UpdateReadouts
    End If

    If isPausedBkwd = True And isPausedFwd = True Then PlayDing
      
End Sub

Private Sub SkipToEndPoint_Click()

    If zmLp = False Then
        previousRow = lastRow + 1
        currentRow = lastRow
        ProgressBar.Value = lastRow
        previousRow = lastRow - 1
        UpdateReadouts
    Else
        zoomPreviousRow = zoomLastRow + 1
        currentRow = zoomLastRow
        ProgressBar.Value = zoomLastRow
        zoomPreviousRow = zoomLastRow - 1
        UpdateReadouts
    End If
  
    If isPausedBkwd = True And isPausedFwd = True Then PlayDing
  
End Sub

Private Sub StopClearAndImportNew_Click()

    ScrubPadsDisable
    ProgressBar.Enabled = False

    AllSoundsOff
  
    cntrlPnl = False
    quitPdMPos = True
    isPausedBkwd = True
    isPausedFwd = True
    stopPlayback = True
    firstImport = False
    zmLp = False
  
    'TimerReset
  
    ' Clean up and unload
    Call StrikeIconTskbar(Me)
    CleanupMIDI
    Application.DisplayAlerts = False
    On Error Resume Next
    Unload Me
    Start_Over
  
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)

    ScrubPadsDisable
    ProgressBar.Enabled = False
    AllSoundsOff
    cntrlPnl = False
    quitPdMPos = True
    isPausedBkwd = True
    isPausedFwd = True
    stopPlayback = True
    firstImport = False
    zmLp = False
    previousSpeed = playSpeed
    CleanupMIDI
    Unload Me
      
    If CloseMode = vbFormControlMenu Then
        Call StrikeIconTskbar(Me)
        Application.Visible = True
        ThisWorkbook.Saved = True
        Unload Me
        Beeper
        CleanupMIDI
        Application.Quit
    End If
      
End Sub

FYI, the stuff I hid for privacy should not at all affect key commands. And the MouseLock calls do not involve any clicks, but rather only hover its pointer over a necessary area.
 
Last edited by a moderator:
Sort by date Sort by votes

Excel Facts

Convert text numbers to real numbers
Select a column containing text numbers. Press Alt+D E F to quickly convert text to numbers. Faster than "Convert to Number"
Hi, sorry for the late response.

The reason the loop(s) stop running when holding the Alt key down is because pressing the Alt key evokes the form window context- system menu.

To verify this, try holding the Alt key down (without simultaniously pressing a control accelerator key) and then hit the Down Arrow navigation key on your keyboard, you will see that the userform context menu is activated ... Unfortunately, active menu(s) put the code in a halting state (cancel mode) and that's why your code stops. Pessing the Alt key again dismisses the context menu and the code resumes ... So this is all expected behaviour of windows.

To tackle this problem, either we could disable the Alt key or temporarly remove the form context menu (system menu).

Disabling the Alt key would be much easier than removing the context menu as we could simply use the RegisterHotKey api function. However, this would also disable any controls acceleration keys which you happen to be using. So, we will dismiss this workaround as it is not an option in our situation.

As for temporarly removing the system menu, it is a bit more involved. The main reason is because this would also unconveniently remove the form X close button which we cannot afford. In order to work around this close button issue, I have added api code to dynamically know the X close button location and place its memory image over it so that even if the X close button is disabled, it will look enabled and will respond to user clicks.... Also, ALT+ F4 is working as normal for closing the form.

Here is a simplified workbook example for testing:
AltKeyTrouble.xlsm
(The workbook example shows a userform with a label displaying the current time via a Do Loop. Holding down the Alt key doesn't stop the time updating every second)


1- api Code in a Standard Module:
VBA Code: 
Option Explicit

#If Win64 Then
    Private Const NULL_PTR = 0^
#Else
    Private Const NULL_PTR = 0&
#End If

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

#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (destination As Any, source As Any, ByVal length As LongPtr)
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
        Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, ByVal arg2 As LongPtr) As Long
    #Else
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
        Private Declare PtrSafe Function GetWindowLong Lib "USER32.DLL" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
        Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, ByVal arg1 As Long, ByVal arg2 As Long) As Long
    #End If
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByRef hwnd As LongPtr) As Long
    Private Declare PtrSafe Function GetWindowRect Lib "USER32.DLL" (ByVal hwnd As LongPtr, ByRef lpRect As RECT) As Long
    Private Declare PtrSafe Function GetClientRect Lib "USER32.DLL" (ByVal hwnd As LongPtr, ByRef lpRect As RECT) As Long
    Private Declare PtrSafe Function GetSystemMetrics Lib "USER32.DLL" (ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function ClientToScreen Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetDC Lib "USER32.DLL" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hDC As LongPtr) As LongPtr
    Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hDC As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    Private Declare PtrSafe Function BitBlt Lib "gdi32.dll" (ByVal hdcDest As LongPtr, ByVal xDest As Long, ByVal yDest As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hdcSrc As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
    Private Declare PtrSafe Function DeleteDC Lib "gdi32.dll" (ByVal hDC As LongPtr) As Long
    Private Declare PtrSafe Function DeleteObject Lib "gdi32.dll" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function ReleaseDC Lib "USER32.DLL" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetSystemMenu Lib "user32" (ByVal hwnd As LongPtr, ByVal bRevert As Long) As LongPtr
    Private Declare PtrSafe Function RemoveMenu Lib "user32" (ByVal hMenu As LongPtr, ByVal nPosition As Long, ByVal wFlags As Long) As Long
#Else
    Private Enum LongPtr
        [_]
    End Enum
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Private Declare Function GetWindowLong Lib "USER32.DLL" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal arg1 As Long, ByVal arg2 As Long) As Long
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByRef hwnd As LongPtr) As Long
    Private Declare Function GetWindowRect Lib "USER32.DLL" (ByVal hwnd As LongPtr, ByRef lpRect As RECT) As Long
    Private Declare Function GetClientRect Lib "USER32.DLL" (ByVal hwnd As LongPtr, ByRef lpRect As RECT) As Long
    Private Declare Function GetSystemMetrics Lib "USER32.DLL" (ByVal nIndex As Long) As Long
    Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function GetDC Lib "USER32.DLL" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hDC As LongPtr) As LongPtr
    Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hDC As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    Private Declare Function BitBlt Lib "gdi32.dll" (ByVal hdcDest As LongPtr, ByVal xDest As Long, ByVal yDest As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hdcSrc As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
    Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hDC As LongPtr) As Long
    Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As LongPtr) As Long
    Private Declare Function ReleaseDC Lib "USER32.DLL" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As LongPtr, ByVal bRevert As Long) As LongPtr
    Private Declare Function RemoveMenu Lib "user32" (ByVal hMenu As LongPtr, ByVal nPosition As Long, ByVal wFlags As Long) As Long
#End If

Private hMemDC As LongPtr

' ____________________________________ PUBLIC ROUTINES ______________________________
    
Public Sub RunLoopTest(ByVal Form As UserForm)
    Const SRCCOPY = &HCC0020
    Dim uRect As RECT, uCurPos As POINTAPI
    Dim hwnd As LongPtr, hDC As LongPtr
    Dim lRet As Long
    Call IUnknown_GetWindow(Form, hwnd)
    uRect = GetCloseButtonRect(hwnd)
    Call GetCursorPos(uCurPos)
    #If Win64 Then
        Dim lPtr As LongLong
        Call CopyMemory(lPtr, uCurPos, LenB(uCurPos))
        lRet = PtInRect(uRect, lPtr)
    #Else
        lRet = PtInRect(uRect, uCurPos.X, uCurPos.Y)
    #End If
    If lRet Then
        RemoveSysMenu(Form) = False
    Else
        RemoveSysMenu(Form) = True
        hDC = GetDC(NULL_PTR)
        With uRect
            Call BitBlt(hDC, .Left, .Top, .Right, .Bottom, hMemDC, 0&, 0&, SRCCOPY)
        End With
        Call ReleaseDC(NULL_PTR, hDC)
    End If
    'Debug.Print Now
    Form.Label2 = Format(Now, "Long Time")
End Sub

Public Sub GetScreenShot(ByVal Form As UserForm)
    Dim uRect As RECT
    Dim hwnd As LongPtr
    Call IUnknown_GetWindow(Form, hwnd)
    uRect = GetCloseButtonRect(hwnd)
    Call CleanupGdiObjects
    With uRect
        Call CaptureScreenArea(.Left, .Top, .Right - .Left, .Bottom - .Top)
    End With
End Sub

Public Property Let RemoveSysMenu(ByVal Form As UserForm, ByVal vNewValue As Boolean)
    Const GWL_STYLE = -16&, WS_SYSMENU = &H80000
    Dim hwnd As LongPtr, hMenu As LongPtr
    Call IUnknown_GetWindow(Form, hwnd)
    hMenu = GetSystemMenu(hwnd, 0&)
    If vNewValue Then
        Call RemoveMenu(hMenu, 0&, &H400)
        Call SetWindowLong(hwnd, GWL_STYLE, (GetWindowLong(hwnd, GWL_STYLE) And Not WS_SYSMENU))
    Else
        Call SetWindowLong(hwnd, GWL_STYLE, (GetWindowLong(hwnd, GWL_STYLE) Or WS_SYSMENU))
        Call GetSystemMenu(hwnd, 1&)
    End If
End Property

Public Sub CleanupGdiObjects()
    Call DeleteDC(hMemDC)
End Sub


' ____________________________________ PRIVATE ROUTINES ______________________________

Private Sub CaptureScreenArea(ByVal X As Long, ByVal Y As Long, ByVal width As Long, ByVal height As Long)
    Const SRCCOPY = &HCC0020
    Dim hDC As LongPtr, hBitmap As LongPtr, hPrevBmp As LongPtr
    hDC = GetDC(NULL_PTR)
    hMemDC = CreateCompatibleDC(hDC)
    hBitmap = CreateCompatibleBitmap(hDC, width, height)
    hPrevBmp = SelectObject(hMemDC, hBitmap)
    Call BitBlt(hMemDC, 0&, 0&, width, height, hDC, X, Y, SRCCOPY)
    Call DeleteObject(hBitmap)
    Call SelectObject(hDC, hPrevBmp)
    Call ReleaseDC(NULL_PTR, hDC)
End Sub

Private Function GetCloseButtonRect(ByVal hwnd As LongPtr) As RECT
    Const SM_CXSIZE = 30&, SM_CXFIXEDFRAME = 7&
    Dim uWinRect As RECT, tClientRect As RECT, uPnt As POINTAPI
    Dim lLeft As Long, lTop As Long
    Call GetWindowRect(hwnd, uWinRect)
    Call GetClientRect(hwnd, tClientRect)
    uPnt.Y = tClientRect.Top
    Call ClientToScreen(hwnd, uPnt)
    lLeft = uWinRect.Right - (GetSystemMetrics(SM_CXFIXEDFRAME) * 2.5 + GetSystemMetrics(SM_CXSIZE))
    lTop = uWinRect.Top
    With GetCloseButtonRect
        .Left = lLeft
        .Top = lTop
        .Right = lLeft + GetSystemMetrics(SM_CXSIZE)
        .Bottom = uPnt.Y
    End With
End Function


2- Code in the UserForm Module:
VBA Code: 
Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
#Else
    Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
#End If

Private bCancel As Boolean

Private Sub UserForm_Activate()
    'api calls to make sure that holding down the Alt key doesn't stop the subsequent loop.
    Call GetScreenShot(Me)
    RemoveSysMenu(Me) = True
    'run the continious loop
    Do While bCancel = False
        DoEvents
        Call RunLoopTest(Me)
    Loop
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CloseMode = vbFormControlMenu Then
        bCancel = True 'exit the above loop.
        Call CleanupGdiObjects
    End If
End Sub

Private Sub CommandButton1_Click()
    MsgBox "Hi from CommandButton1"
End Sub

Private Sub TextBox1_Enter()
    If GetAsyncKeyState(VBA.vbKeyA) Then
        MsgBox "TextBox1 was activated by Pressing (Alt + A)"
    End If
End Sub

See if you can adapt this to your project. If any problems, just ask.
 
Last edited:
Upvote 0
A couple of small code adjustements that should be applied in the above api code:

1- In the CaptureScreenArea routine:
Changed from :
hBitmap = CreateCompatibleBitmap(hDC, width , height)
To:
hBitmap = CreateCompatibleBitmap(hDC, width -10&, height)

2- In the GetCloseButtonRect routine:
Changed from :
lLeft = uWinRect.Right - (GetSystemMetrics(SM_CXFIXEDFRAME) * 2.5 + GetSystemMetrics(SM_CXSIZE))
To:
lLeft = uWinRect.Right - (GetSystemMetrics(SM_CXFIXEDFRAME) + GetSystemMetrics(SM_CXSIZE))

From:
.Right = lLeft + GetSystemMetrics(SM_CXSIZE)
To:
.Right = uWinRect.Right - 1&

Workbook Example has been updated with these changes.
 
Upvote 0
You must log in or register to reply here.

Forum statistics

Threads
1,226,017
Messages
6,188,439
Members
453,474
Latest member
th9r

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top