Class Terminate problem

[Ron S]

Good morning to all,

The following code will write "Debug,Print" to the "Code" and
"Immediate" windows by means of a shortcut menu item on each
respective toolbar and the procedures and class work great, except for
the proceedure "Write_Debug_Print_To_Code_Win_1". When I execute this
macro, via the shortcut menu that the class creates, the
line"cm.ReplaceLine m, strString & strApp" will cause the
"Class_Terminate" proceedure to fire which removes the shortcut menu
items.

Can someone please explain why this happens and how to fix it??

Thanks,
Ron Seaman

I am using Win XP with Office Pro 2000.
'**********************************
'*** Insert following into a module
'**********************************
Option Explicit
Public Const gs_MACRO_WRT_DBG_PRNT_CODE_WIN_1 As String =
"Write_Debug_Print_To_Code_Win_1"
Public Const gs_MACRO_WRT_DBG_PRNT_IM_WIN_2 As String =
"Write_Debug_Print_To_IM_Win_2"
Public gb_FromVBE As Boolean
Public gcls_MenuHandler As C_MenuHandler
Sub Auto_Open()
'*** Create the VBE menu item class
Set gcls_MenuHandler = New C_MenuHandler
End Sub
Sub Auto_Close()
'*** Terminate The VBE menu item class
Set gcls_MenuHandler = Nothing
End Sub
Sub Write_Debug_Print_To_Code_Win_1()

Dim cp As CodePane
Dim cm As CodeModule
Dim strString As String
Dim strApp As String
Dim m As Long
Dim n As Long
Dim x As Long
Dim y As Long
'Test HereDebug.Print
strApp = "Debug.Print "
Set cp = Application.VBE.ActiveCodePane

cp.GetSelection m, n, x, y
Set cm = Application.VBE.CodePanes(1).CodeModule
strString = cm.Lines(m, 1)

cm.ReplaceLine m, strString & strApp 'Causes class to
terminate
cp.SetSelection m, n + Len(strString & " " & strApp), x, _
y + Len(strString & " " & strApp)
End Sub
Sub Write_Debug_Print_To_IM_Win_2()
Debug.Print "Debug.Print "
End Sub
'************************************************************
'*** Insert following into class module named "C_MenuHandler"
'************************************************************
'
'*** This class from:
''' VBA Code Cleaner 4.4 © 1996-2002 by Rob Bovey,
''' all rights reserved. May be redistributed for free but
''' may not be sold without the author's explicit permission.
'*** Thanks Rob
'*** Modified by Ron Seaman
Option Explicit

''' **********************************************************
''' Class Variable Declarations Follow
''' **********************************************************
Private WithEvents CustomMenu1 As VBIDE.CommandBarEvents
Private WithEvents CustomMenu2 As VBIDE.CommandBarEvents
Private mtb_CodeWindow_1 As CommandBar
Private ms_OnAction1 As String
Private mtb_IM_Win_2 As CommandBar
Private ms_OnAction2 As String


''' *************************************************************************
''' Class Event Procedures Follow
''' *************************************************************************
Private Sub Class_Initialize()

Set mtb_CodeWindow_1 = Application.VBE.CommandBars("Code Window")
ms_OnAction1 = ThisWorkbook.Name & "!" &
gs_MACRO_WRT_DBG_PRNT_CODE_WIN_1

Set mtb_IM_Win_2 = Application.VBE.CommandBars("Immediate Window")
ms_OnAction2 = ThisWorkbook.Name & "!" &
gs_MACRO_WRT_DBG_PRNT_IM_WIN_2

Call AddMenuItem
End Sub
Private Sub Class_Terminate()

On Error Resume Next
Set CustomMenu1 = Nothing
mtb_CodeWindow_1.Controls("Write ""Debug.Print """).Delete
Set mtb_CodeWindow_1 = Nothing

Set CustomMenu2 = Nothing
mtb_IM_Win_2.Controls("Write ""Debug.Print """).Delete
Set mtb_IM_Win_2 = Nothing

Debug.Print "Class_Terminated"
Debug.Print "Err # " & Err.Number & " Description " &
Err.Description

End Sub
Private Sub CustomMenu1_Click(ByVal cmdBar As Object, handled As
Boolean, Cancel As Boolean)
gb_FromVBE = True
Application.OnTime Now(), ms_OnAction1
handled = True
End Sub
Private Sub CustomMenu2_Click(ByVal cmdBar As Object, handled As
Boolean, Cancel As Boolean)
gb_FromVBE = True
Application.OnTime Now(), ms_OnAction2
handled = True
End Sub
''' *************************************************************************
''' Class Private Procedures Follows
''' *************************************************************************
Private Sub AddMenuItem()
Dim ctlCustom1 As CommandBarButton
Dim ctlCustom2 As CommandBarButton
''' Always try to delete any old menus left around by a crash.
On Error Resume Next
mtb_CodeWindow_1.Controls("Write ""Debug.Print """).Delete
mtb_IM_Win_2.Controls("Write ""Debug.Print """).Delete
On Error GoTo 0
''' Add the new menu item # 1 "Debug.Print in Code Window
Set ctlCustom1 = mtb_CodeWindow_1.Controls.Add(msoControlButton, ,
, _
Application.VBE.CommandBars("Code Window") _
.Controls("List Properties/Met&hods"). _
Index, True) 'Add(msoControlButton)
With ctlCustom1
.Caption = "Write ""Debug.Print """
.BeginGroup = True
End With
''' Add the new menu item # 2 "Debug.Print in Immediate Window
Set ctlCustom2 = mtb_IM_Win_2.Controls.Add(msoControlButton, , , _
Application.VBE.CommandBars("Immediate Window") _
.Controls("&Object Browser"). _
Index, True) 'Add(msoControlButton)
With ctlCustom2
.Caption = "Write ""Debug.Print """
.BeginGroup = True
End With
''' Set a reference to the Event object for the custom menu items
Set CustomMenu1 =
Application.VBE.Events.CommandBarEvents(ctlCustom1)
Set CustomMenu2 =
Application.VBE.Events.CommandBarEvents(ctlCustom2)
End Sub

 

[Rob Bovey]

Hi Ron,

Temporarily change your Write_Debug_Print_To_Code_Win_1 as shown below
so you can see exactly which code window it's going to modify. If the code
window name printed in the immediate window is the name of your class module
then the commented code would destroy your class by attempting to modify it.

Sub Write_Debug_Print_To_Code_Win_1()

Dim cp As CodePane
Dim cm As CodeModule
Dim strString As String
Dim strApp As String
Dim m As Long
Dim n As Long
Dim x As Long
Dim y As Long
'Test HereDebug.Print
strApp = "Debug.Print "
Set cp = Application.VBE.ActiveCodePane

''' What CodePane are we going to modify?
Debug.Print Application.VBE.CodePanes(1).Window.Caption

' cp.GetSelection m, n, x, y
' Set cm = Application.VBE.CodePanes(1).CodeModule
' strString = cm.Lines(m, 1)
'
' cm.ReplaceLine m, strString & strApp 'Causes class to Terminate
' cp.SetSelection m, n + Len(strString & " " & strApp), x, _
' y + Len(strString & " " & strApp)

End Sub


--
Rob Bovey, MCSE, MCSD, Excel MVP
Application Professionals
http://www.appspro.com/

* Please post all replies to this newsgroup *
* I delete all unsolicited e-mail responses *

 

[Ron S]

Thanks Rob.

I have changed "CodePanes(1)" to "ActiveCodePane" and the Class Crash
happens every time no matter where I use it in the project. However,
when I use it in another project, it works OK.

Thanks for the tip,
Ron Seaman