VBA to pop up a box and run the code accordingly

[Balajibenz]

Hi,

Can someone help me with the below requirement.

I have a code that is running fine but I want to place a message box in between to give a break to the code to do some manual updates.

I am looking for code that pops up with a message asking to do manual updates in workbook and with option button as "Done" or "yes" and if it is clicked then it should continue running the code.

 

[Sahak]

Hi,

From where is running your code, from UserForm?
I have a code that is running fine

 

[bebo021999]

1st part code
.....
DoEvents
.....
2nd part code

 

[Sahak]

Where is stored your macro?

• Sheet module
• Workbook module
• Code module
• Userforms module

 

[Jaafar Tribak]

I would show a modeless userform for this and start a loop (with DoEvents) in its activate event. This will allow you to interact with the workbook as well as with the buttons on the userform... The loop will end when clicking the Done or Yes userform buttons.

If the Click button is pressed, close the userform and resume your code. If the Done button is pressed, close the userform and exit the code.

 

[audeser]

Use this code (paste in normal module). It's a replacement to Application.MsgBox as shown on TestMsgBox procedure, but can be stopped if called like this and you press the CANCEL button:

Call fMsgBox("Just a test", vbOKOnly + vbInformation)

Codemodule:

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function SetDlgItemText Lib "user32" Alias "SetDlgItemTextA" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long, ByVal lpString As String) 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 hhk As LongPtr) As Long
    Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
#Else
    ' Set Hook
    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
    
    ' Delete Hook
    Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
    
    ' Change button text on Msgbox
    Private Declare Function SetDlgItemText Lib "user32" Alias "SetDlgItemTextA" (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal lpString As String) As Long
    
    Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
#End If
 
Private Const WH_CBT = 5
Private Const HCBT_ACTIVATE = 5

Public Enum eButton
    [Ok] = 1
    [Cancel] = 2
    [abort] = 3
    [RETRY] = 4
    [Ignore] = 5
    [Yes] = 6
    [No] = 7
End Enum

' Variables that takes function función MsgBoxCustom inside HOOK
Private m_Button1 As Long ' Button1 to modify
Private m_Button2 As Long ' Button2 to modify
Private m_Button3 As Long ' Button2 to modify
Private m_Text_Button1 As String ' Button1 text
Private m_Text_Button2 As String ' Button2 text
Private m_Text_Button3 As String ' Button3 text

#If VBA7 Then
    Private Id_Hook As LongPtr  ' Keeps value to end Hook
#Else
 Private Id_Hook As Long        ' Keeps value to end Hook
#End If

Private Sub TestMsgBox()
    Call fMsgBox("Just a test", vbOKOnly + vbInformation , , , , "Opt1", "Opt2", "Opt3")
End Sub

Public Function fMsgBox(ByVal prompt As String, _
                        Optional ByVal Buttons As VbMsgBoxStyle = vbYesNo, _
                        Optional ByVal Title As String = "W A R N I N G", _
                        Optional ByVal HelpFile As Variant, _
                        Optional ByVal Context As Variant, _
                             Optional ByVal TextButton1 As String = vbNullString, _
                             Optional ByVal TextButton2 As String = vbNullString, _
                             Optional ByVal TextButton3 As String = vbNullString) As VbMsgBoxResult
    Dim retValue As VbMsgBoxResult
    Dim lgCustom As Long
    Dim lgIcon As Long
    Dim bInformation As Boolean, bExclamation As Boolean, bCritical As Boolean
    
    If TextButton1 & TextButton2 & TextButton3 = vbNullString Then
        If Buttons >= vbCritical Then
            If Buttons >= vbCritical And Buttons < 2 * vbCritical Then
                Buttons = Buttons - vbCritical
                bCritical = True
                If Title = vbNullString Then Title = "W A R N I N G"
            End If
            If Buttons >= vbExclamation And Buttons < (vbCritical + vbExclamation) Then
                Buttons = Buttons - vbExclamation
                bExclamation = True
                If Title = vbNullString Then Title = "W A R N I N G"
            End If
            If Buttons >= vbInformation And Buttons < (vbCritical + vbInformation) Then
                Buttons = Buttons - vbInformation
                bInformation = True
                If Title = vbNullString Then Title = "I N F O"
            End If
        End If
    
        If Buttons = vbOKOnly Then
            Buttons = vbOKCancel: lgCustom = -1
        ElseIf Buttons = vbYesNo Then
            Buttons = vbOKCancel: lgCustom = 5
        End If
    
        If bCritical Then Buttons = Buttons + vbCritical
        If bExclamation Then Buttons = Buttons + vbExclamation
        If bInformation Then Buttons = Buttons + vbInformation
        
        If bCritical And Buttons = vbCritical Then Buttons = Buttons + vbOKCancel
    
        retValue = VBA.MsgBox(prompt, Buttons, Title, HelpFile, Context)
        If retValue = vbCancel Then
            Stop
        ElseIf retValue = vbAbort Then
            Stop
        End If
    
        fMsgBox = VBA.IIf(retValue + lgCustom < 1, 1, retValue + lgCustom)
    Else
        fMsgBox = MsgBoxCustom(prompt, Buttons, Title, _
                               TextButton1, TextButton2, TextButton3)
    End If
End Function

Public Function MsgBoxCustom(ByVal prompt As String, _
                             ByVal lgMsgBoxIconStyle As VbMsgBoxStyle, _
                             ByVal Title As String, _
                             ByVal TextButton1 As String, _
                             Optional ByVal TextButton2 As String = vbNullString, _
                             Optional ByVal TextButton3 As String = vbNullString) As VbMsgBoxResult
' lgMsgBoxIconStyle should only contain icon styles (value > 7)
    
    Dim retValue As VbMsgBoxResult
    Dim lgMsgBoxStyle As VbMsgBoxStyle

    m_Text_Button1 = TextButton1
    m_Text_Button2 = TextButton2
    m_Text_Button3 = TextButton3
    sHook
    
    If VBA.Trim$(TextButton3) = vbNullString Then
        If VBA.Trim$(TextButton2) = vbNullString Then
            lgMsgBoxStyle = lgMsgBoxIconStyle + vbOKOnly
            m_Button1 = 1
        Else
            lgMsgBoxStyle = lgMsgBoxIconStyle + vbYesNo
            m_Button1 = 6
            m_Button2 = 7
        End If
    Else
        lgMsgBoxStyle = lgMsgBoxIconStyle + vbYesNoCancel
        m_Button1 = 6
        m_Button2 = 7
        m_Button3 = 2
    End If
    
    retValue = VBA.MsgBox(prompt, lgMsgBoxStyle, Title)
    
    If retValue = vbOK Then
        MsgBoxCustom = 1
    ElseIf retValue = vbYes Then
        MsgBoxCustom = 1
    ElseIf retValue = vbNo Then
        MsgBoxCustom = 2
    ElseIf retValue = vbCancel Then
        MsgBoxCustom = 3
    End If

    ' Deletes hook!. If not, Excel will crash...
    retValue = UnhookWindowsHookEx(Id_Hook)
    m_Text_Button1 = vbNullString
    m_Text_Button2 = vbNullString
    m_Text_Button3 = vbNullString
End Function

Private Sub sHook()
' Initialize Hook
    Id_Hook = SetWindowsHookEx(WH_CBT, AddressOf winProc, 0, GetCurrentThreadId) 'App.ThreadID)
End Sub

Public Function winProc(ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
' intercept messages
       
    Dim retValue As VbMsgBoxResult
  
    'On Error Resume Next
    If uMsg = HCBT_ACTIVATE Then
        'Set text on Button 1
        retValue = SetDlgItemText(wParam, m_Button1, m_Text_Button1)
        
        If m_Button2 > 0 Then
            'Set text on Button 2
            retValue = SetDlgItemText(wParam, m_Button2, m_Text_Button2)
        End If
    
        If m_Button3 > 0 Then
            'Set text on Button 3
            retValue = SetDlgItemText(wParam, m_Button3, m_Text_Button3)
        End If
    End If
    On Error GoTo 0
  
    winProc = 0
End Function