Excel crashing during VBA procedures

M

Magestick

New Member
Joined
Sep 29, 2016
Messages
19
I have a module called UpdateCheck with procedures which check another document to see if the version number has changed. If it has, it asks the user if they want to update the document to the new version. This is only to update the modules because the formatting of the worksheets is set in stone at this point. When the user clicks "Yes", it goes through the procedures, but Excel crashes towards the end. I'm having a hard time figuring out where it's crashing, and therefore how to fix it. Any help would be greatly appreciated. Here is the code from the UpdateCheck module.

Code: 
Option Explicit


[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hwndParent As LongPtr, ByVal hwndChildAfter As LongPtr, ByVal lpszClass As String, ByVal lpszWindow As String) As LongPtr
    Private Declare PtrSafe Function GetParent Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetDlgItem Lib "user32" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long) As LongPtr ' nIDDlgItem = int?
    Private Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal Msg As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare PtrSafe Function SetFocusAPI Lib "user32" Alias "SetFocus" (ByVal hWnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function LockWindowUpdate Lib "user32" (ByVal hWndLock As LongPtr) As Long
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal uIDEvent As LongPtr) As Long
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hwndParent As Long, ByVal hwndChildAfter As Long, ByVal lpszClass As String, ByVal lpszWindow As String) As Long
    Private Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare Function GetDlgItem Lib "user32" (ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long ' nIDDlgItem = int?
    Private Declare Function GetDesktopWindow Lib "user32" () As Long
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Function SetFocusAPI Lib "user32" Alias "SetFocus" (ByVal hWnd As Long) As Long
    Private Declare Function LockWindowUpdate Lib "user32" (ByVal hWndLock As Long) As Long
    Private Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal uIDEvent As Long) As Long
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If


Private Const WM_CLOSE As Long = &H10
Private Const WM_GETTEXT As Long = &HD
Private Const EM_REPLACESEL As Long = &HC2
Private Const EM_SETSEL As Long = &HB1
Private Const BM_CLICK As Long = &HF5&
Private Const TCM_SETCURFOCUS As Long = &H1330&
Private Const IDPassword As Long = &H155E&
Private Const IDOK As Long = &H1&


Private Const TimeoutSecond As Long = 2


Private g_ProjectName    As String
Private g_Password       As String
Private g_Result         As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Private g_hwndVBE        As LongPtr
    Private g_hwndPassword   As LongPtr
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Private g_hwndVBE        As Long
    Private g_hwndPassword   As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If


Public Function UnlockProject(ByVal Project As Object, ByVal Password As String) As Long


[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Dim lRet As LongPtr
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Dim lRet As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
Dim timeout As Date


    On Error GoTo ErrorHandler
    UnlockProject = 1


    ' Set global varaibles for the project name, the password and the result of the callback
    g_ProjectName = Project.Name
    g_Password = Password
    g_Result = 0


    ' Freeze windows updates so user doesn't see the magic happening :)
    ' This is dangerous if the program crashes as will 'lock' user out of Windows
    ' LockWindowUpdate GetDesktopWindow()


    ' Switch to the VBE
    ' and set the VBE window handle as a global variable
    Application.VBE.MainWindow.Visible = True
    g_hwndVBE = Application.VBE.MainWindow.hWnd


    ' Run 'UnlockTimerProc' as a callback
    lRet = SetTimer(0, 0, 100, AddressOf UnlockTimerProc)
    If lRet = 0 Then
        Debug.Print "error setting timer"
        GoTo ErrorHandler
    End If


    ' Switch to the project we want to unlock
    Set Application.VBE.ActiveVBProject = Project
    'If Not Application.VBE.ActiveVBProject Is Project Then GoTo ErrorHandler


    ' Launch the menu item Tools -> VBA Project Properties
    ' This will trigger the password dialog
    ' which will then get picked up by the callback
    Application.VBE.CommandBars.FindControl(ID:=2578).Execute


    ' Loop until callback procedure 'UnlockTimerProc' has run
    ' determine run by watching the state of the global variable 'g_result'
    ' ... or backstop of 2 seconds max
    timeout = Now() + TimeSerial(0, 0, TimeoutSecond)
    Do While g_Result = 0 And Now() < timeout
        DoEvents
    Loop
    If g_Result Then UnlockProject = 0


ErrorHandler:
    ' Switch back to the Excel application
    AppActivate Application.Caption


    ' Unfreeze window updates
    LockWindowUpdate 0


End Function


[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Private Function UnlockTimerProc(ByVal hWnd As LongPtr, ByVal uMsg As Long, ByVal idEvent As LongPtr, ByVal dwTime As Long) As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Private Function UnlockTimerProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long) As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If


[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Dim hWndPassword As LongPtr
    Dim hWndOK As LongPtr
    Dim hWndTmp As LongPtr
    Dim lRet As LongPtr
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Dim hWndPassword As Long
    Dim hWndOK As Long
    Dim hWndTmp As Long
    Dim lRet As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
Dim lRet2 As Long
Dim sCaption As String
Dim timeout As Date
Dim timeout2 As Date
Dim pwd As String


    ' Protect ourselves against failure :)
    On Error GoTo ErrorHandler


    ' Kill timer used to initiate this callback
    KillTimer 0, idEvent


    ' Determine the Title for the password dialog
    Select Case Application.LanguageSettings.LanguageID(msoLanguageIDUI)
        ' For the japanese version
        Case 1041
            sCaption = ChrW(&H30D7) & ChrW(&H30ED) & ChrW(&H30B8) & _
                        ChrW(&H30A7) & ChrW(&H30AF) & ChrW(&H30C8) & _
                        ChrW(&H20) & ChrW(&H30D7) & ChrW(&H30ED) & _
                        ChrW(&H30D1) & ChrW(&H30C6) & ChrW(&H30A3)
        Case Else
            sCaption = " Password"
    End Select
    sCaption = g_ProjectName & sCaption


    ' Set a max timeout of 2 seconds to guard against endless loop failure
    timeout = Now() + TimeSerial(0, 0, TimeoutSecond)
    Do While Now() < timeout


        hWndPassword = 0
        hWndOK = 0
        hWndTmp = 0


        ' Loop until find a window with the correct title that is a child of the
        ' VBE handle for the project to unlock we found in 'UnlockProject'
        Do
            hWndTmp = FindWindowEx(0, hWndTmp, vbNullString, sCaption)
            If hWndTmp = 0 Then Exit Do
        Loop Until GetParent(hWndTmp) = g_hwndVBE


        ' If we don't find it then could be that the calling routine hasn't yet triggered
        ' the appearance of the dialog box
        ' Skip to the end of the loop, wait 0.1 secs and try again
        If hWndTmp = 0 Then GoTo Continue


        ' Found the dialog box, make sure it has focus
        Debug.Print "found window"
        lRet2 = SendMessage(hWndTmp, TCM_SETCURFOCUS, 1, ByVal 0&)


        ' Get the handle for the password input
        hWndPassword = GetDlgItem(hWndTmp, IDPassword)
        Debug.Print "hwndpassword: " & hWndPassword


        ' Get the handle for the OK button
        hWndOK = GetDlgItem(hWndTmp, IDOK)
        Debug.Print "hwndOK: " & hWndOK


        ' If either handle is zero then we have an issue
        ' Skip to the end of the loop, wait 0.1 secs and try again
        If (hWndTmp And hWndOK) = 0 Then GoTo Continue


        ' Enter the password ionto the password box
        lRet = SetFocusAPI(hWndPassword)
        lRet2 = SendMessage(hWndPassword, EM_SETSEL, 0, ByVal -1&)
        lRet2 = SendMessage(hWndPassword, EM_REPLACESEL, 0, ByVal g_Password)


        ' As a check, get the text back out of the pasword box and verify it's the same
        pwd = String(260, Chr(0))
        lRet2 = SendMessage(hWndPassword, WM_GETTEXT, Len(pwd), ByVal pwd)
        pwd = Left(pwd, InStr(1, pwd, Chr(0), 0) - 1)
        ' If not the same then we have an issue
        ' Skip to the end of the loop, wait 0.1 secs and try again
        If pwd <> g_Password Then GoTo Continue


        ' Now we need to close the Project Properties window we opened to trigger
        ' the password input in the first place
        ' Like the current routine, do it as a callback
        lRet = SetTimer(0, 0, 100, AddressOf ClosePropertiesWindow)


        ' Click the OK button
        lRet = SetFocusAPI(hWndOK)
        lRet2 = SendMessage(hWndOK, BM_CLICK, 0, ByVal 0&)


        ' Set the gloabal variable to success to flag back up to the initiating routine
        ' that this worked
        g_Result = 1
        Exit Do


        ' If we get here then something didn't work above
        ' Wait 0.1 secs and try again
        ' Master loop is capped with a longstop of 2 secs to terminate endless loops
Continue:
        DoEvents
        Sleep 100
    Loop
    Exit Function


    ' If we get here something went wrong so close the password dialog box (if we have a handle)
    ' and unfreeze window updates (if we set that in the first place)
ErrorHandler:
    Debug.Print Err.Number
    If hWndPassword <> 0 Then SendMessage hWndPassword, WM_CLOSE, 0, ByVal 0&
    LockWindowUpdate 0


End Function


[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Function ClosePropertiesWindow(ByVal hWnd As LongPtr, ByVal uMsg As Long, ByVal idEvent As LongPtr, ByVal dwTime As Long) As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Function ClosePropertiesWindow(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long) As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If


[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Dim hWndTmp As LongPtr
    Dim hWndOK As LongPtr
    Dim lRet As LongPtr
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Dim hWndTmp As Long
    Dim hWndOK As Long
    Dim lRet As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
Dim lRet2 As Long
Dim timeout As Date
Dim sCaption As String


    ' Protect ourselves against failure :)
    On Error GoTo ErrorHandler


    ' Kill timer used to initiate this callback
    KillTimer 0, idEvent


    ' Determine the Title for the project properties dialog
    sCaption = g_ProjectName & " - Project Properties"
    Debug.Print sCaption


    ' Set a max timeout of 2 seconds to guard against endless loop failure
    timeout = Now() + TimeSerial(0, 0, TimeoutSecond)
    Do While Now() < timeout


        hWndTmp = 0


        ' Loop until find a window with the correct title that is a child of the
        ' VBE handle for the project to unlock we found in 'UnlockProject'
        Do
            hWndTmp = FindWindowEx(0, hWndTmp, vbNullString, sCaption)
            If hWndTmp = 0 Then Exit Do
        Loop Until GetParent(hWndTmp) = g_hwndVBE


        ' If we don't find it then could be that the calling routine hasn't yet triggered
        ' the appearance of the dialog box
        ' Skip to the end of the loop, wait 0.1 secs and try again
        If hWndTmp = 0 Then GoTo Continue


        ' Found the dialog box, make sure it has focus
        Debug.Print "found properties window"
        lRet2 = SendMessage(hWndTmp, TCM_SETCURFOCUS, 1, ByVal 0&)


        ' Get the handle for the OK button
        hWndOK = GetDlgItem(hWndTmp, IDOK)
        Debug.Print "hwndOK: " & hWndOK


        ' If either handle is zero then we have an issue
        ' Skip to the end of the loop, wait 0.1 secs and try again
        If (hWndTmp And hWndOK) = 0 Then GoTo Continue


        ' Click the OK button
        lRet = SetFocusAPI(hWndOK)
        lRet2 = SendMessage(hWndOK, BM_CLICK, 0, ByVal 0&)


        ' Set the gloabal variable to success to flag back up to the initiating routine
        ' that this worked
        g_Result = 1
        Exit Do


        ' If we get here then something didn't work above
        ' Wait 0.1 secs and try again
        ' Master loop is capped with a longstop of 2 secs to terminate endless loops
Continue:
        DoEvents
        Sleep 100
    Loop
    Exit Function


    ' If we get here something went wrong so unfreeze window updates (if we set that in the first place)
ErrorHandler:
    Debug.Print Err.Number
    LockWindowUpdate 0


End Function


Sub CheckForUpdate()
Dim DocVersion As String, CurrentVersion As String, ThisDoc As String, Template As String


DocVersion = ThisWorkbook.Sheets("Case Detail").Cells(33, 20).Value
ThisDoc = ThisWorkbook.Name


If Len(Dir("\\165.237.249.27\share\HE\SpliceSheets\_Master Templates")) > 0 Then
    Application.EnableEvents = False
    Workbooks.Open "\\165.237.249.27\share\HE\SpliceSheets\_Master Templates\Master Splicesheet Template.xltm"
    Application.EnableEvents = True
    Template = ActiveWorkbook.Name
    CurrentVersion = Workbooks(Template).Sheets("Case Detail").Cells(33, 20).Value
    If Workbooks(Template).Sheets("Case Detail").Cells(33, 20).Value = DocVersion Then
        Application.Run "'" & Template & "'!ConversionInProgress"
        Workbooks(Template).Close
        ElseIf MsgBox("Update Needed!" & Chr(13) & Chr(13) & "Would you like to update this file now?", vbYesNo, "Update Needed") = vbYes Then
            UpdateModules ThisDoc, Template
            Application.Run "'" & Template & "'!ConversionInProgress"
            Workbooks(Template).Close
            DoEvents
            Workbooks(ThisDoc).Sheets("Case Detail").Cells(33, 20).Value = CurrentVersion
            Else
                Application.Run "'" & Template & "'!ConversionInProgress"
                Workbooks(Template).Close
    End If
End If
End Sub


Sub UpdateModules(ThisDoc As String, Template As String)
Dim element As Object
Dim i As Integer


    UnlockProject Workbooks(ThisDoc).VBProject, "finoptions"
    For Each element In Workbooks(ThisDoc).VBProject.vbcomponents
        If Workbooks(ThisDoc).VBProject.vbcomponents(element.Name).Type = 1 And Not element.Name = "UpdateCheck" Then
            For i = 1 To Workbooks(ThisDoc).VBProject.vbcomponents(element.Name).CodeModule.countoflines
                Workbooks(ThisDoc).VBProject.vbcomponents(element.Name).CodeModule.deletelines (1)
            Next i
            Workbooks(ThisDoc).VBProject.vbcomponents.Remove element
        End If
        DoEvents
    Next element
    
    UnlockProject Workbooks(Template).VBProject, "finoptions"
    For Each element In Workbooks(Template).VBProject.vbcomponents
        If Workbooks(Template).VBProject.vbcomponents(element.Name).Type = 1 And Not element.Name = "UpdateCheck" Then
            Workbooks(Template).VBProject.vbcomponents(element.Name).Export (element.Name)
            Workbooks(ThisDoc).VBProject.vbcomponents.Import (element.Name)
        End If
        DoEvents
    Next element
        
End Sub

Thanks in advance!
 
Last edited:

Excel Facts

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.
Sort by date Sort by votes
This reminds me of all the times when Application.Wait seems relevant. There is also some setting or reference thing that U must have in order to mess with inserting module vbcomponents stuff... do your users have the same settings... no Idea if it matters? Anyways, my guess is that something needs more time to finish what it's doing before the next thing that U have coded for can happen. To check, insert some message boxes "Hi1", "Hi2", etc. and see if and where it fails. HTH. Dave
 
Upvote 0
On second read, "This is only to update the modules because the formatting of the worksheets is set in stone at this point" … Then why not just copy the sheets to the updated wb instead of all that messing with vbcomponents (ie. the new wb has the new modules and then the old sheets are copied to the new wb). U can load a collection with sheets and then transfer the collection to a new wb fairly easily. Dave
 
Upvote 0
Very good point, Dave! Previously, it made more sense to copy the modules because the formatting of the sheets wasn't permanent. Also...I find I sometimes try to make things harder than they need to be. I've started rewriting the VBA for this, and am very pleased with the results so far.

Thanks again!
 
Upvote 0
You must log in or register to reply here.

Similar threads

Jaafar Tribak
  • Question Question
KeyPress Event for Worksheet Cells (Subclassing Without Crashing)
Replies
0
Views
165
Jaafar Tribak
Jaafar Tribak
Jaafar Tribak
  • Question Question
Capturing the Paste Event (API Hooking - Redirection)
Replies
4
Views
747
Jaafar Tribak
Jaafar Tribak
D
  • Solved
Long vs Longptr
Replies
7
Views
317
Micron
M
M
  • Question Question
Please help me to correct Excel VBA code!
Replies
1
Views
309
Minh Tuan VN
M
H
  • Solved
Catching the Mouse Click Error in Modal User Form
Replies
4
Views
745
huiettcm
H

Forum statistics

Threads
1,223,229
Messages
6,170,881
Members
452,364
Latest member
springate

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