SheetBeforeRightClick Event procedure stops firing after my macro repopulates
a spread sheet. Any thoughts?

Hi MAB,

Try posting the code for the repopulation macro.

In the absence of the code, I can only surmise that the macro is turning off
events and, perhaps, unintentionally, failing to restore them.


---
Regards,
Norman



"MAB" wrote in message
...
SheetBeforeRightClick Event procedure stops firing after my macro
repopulates
a spread sheet. Any thoughts?

Hi MAB,

I see that Jim Thomlinson responded in very similar fashion to youe earlier
thread which related to the identical problem.

Jim's reply was posted over 4 hours ago, but appears to have elicted no
response from you.

Rather, therefore, than opening a new thread, check for responses to your
original question.


---
Regards,
Norman



"Norman Jones" wrote in message
...
Hi MAB,

Try posting the code for the repopulation macro.

In the absence of the code, I can only surmise that the macro is turning
off events and, perhaps, unintentionally, failing to restore them.


---
Regards,
Norman



"MAB" wrote in message
...
SheetBeforeRightClick Event procedure stops firing after my macro
repopulates
a spread sheet. Any thoughts?

'Class module ---------------------------------------------------------

Private WithEvents xlApp As Excel.Application

Private Sub Class_Initialize()
Set xlApp = Excel.Application
End Sub

'Doesn't seem to auto-execute
'Private Sub xlApp_WorkbookOpen(ByVal Wb As Workbook)
' MsgBox "xlApp_WorkbookOpen"
'End Sub

Private Sub xlApp_SheetBeforeRightClick(ByVal Sh As Object, _
ByVal Target As Range, Cancel As Boolean)

MsgBox "xlApp_SheetBeforeRightClick " & Target.Address & " " &
Target.Hyperlinks.Count
'Add or remove Hyperlink menu items based on whether or not Hyperlink(s)
are selected

Dim oCtrl As CommandBarControl
Dim oBtn As CommandBarControl
Dim bMenusExist As Boolean
Dim bHyperlinksExist As Boolean

For Each oCtrl In Application.CommandBars("Cell").Controls
If oCtrl.Caption = "Copy Hyperlinked Docs To..." Then
bMenusExist = True
Exit For
End If
Next

bHyperlinksExist = Target.Hyperlinks.Count 0

If bHyperlinksExist And Not bMenusExist Then
Set oCtrl =
Application.CommandBars("Cell").Controls.Add(Type: =msoControlButton, _
Temporary:=True)
oCtrl.Caption = "Copy Hyperlinked Docs To..."
oCtrl.OnAction = "CopyHyperlinkedDocsTo"

Set oCtrl =
Application.CommandBars("Cell").Controls.Add(Type: =msoControlButton, _
Temporary:=True)
oCtrl.Caption = "Zip && Email Hyperlinked Docs..."
oCtrl.OnAction = "ZipAndEmailHyperlinkedDocs"

' Set oCtrl =
Application.CommandBars("Cell").Controls.Add(Type: =msoControlButton, _
' Temporary:=True)
' oCtrl.Caption = "Print Hyperlinked Docs..."
' oCtrl.OnAction = "PrintHyperlinkedDocs"
ElseIf Not bHyperlinksExist Then
For Each oCtrl In Application.CommandBars("Cell").Controls
If oCtrl.Caption = "Copy Hyperlinked Docs To..." Then
oCtrl.Delete
ElseIf oCtrl.Caption = "Zip && Email Hyperlinked Docs..." Then
oCtrl.Delete
ElseIf oCtrl.Caption = "Print Hyperlinked Docs..." Then
oCtrl.Delete
End If
Next
End If
End Sub

'Regular module --------------------------------------------------------------

Public moXLEvents As clsXLEvents



'ThisWorkbook -----------------------------------------------------------

Private Sub Workbook_Open()
Dim oWorksheet As Worksheet

Set moXLEvents = New clsXLEvents
Set oWorksheet = ThisWorkbook.ActiveSheet
If oWorksheet.Range("a2").Value = "" Then
ListNewerFiles.Show vbModal
End If
End Sub

"Norman Jones" wrote:

Hi MAB,

Try posting the code for the repopulation macro.

In the absence of the code, I can only surmise that the macro is turning off
events and, perhaps, unintentionally, failing to restore them.


---
Regards,
Norman



"MAB" wrote in message
...
SheetBeforeRightClick Event procedure stops firing after my macro
repopulates
a spread sheet. Any thoughts?

Does your object get destroyed at any point? Do you have an End anywhere in
your code? End destroys objects...
--
HTH...

Jim Thomlinson


"MAB" wrote:

'Class module ---------------------------------------------------------

Private WithEvents xlApp As Excel.Application

Private Sub Class_Initialize()
Set xlApp = Excel.Application
End Sub

'Doesn't seem to auto-execute
'Private Sub xlApp_WorkbookOpen(ByVal Wb As Workbook)
' MsgBox "xlApp_WorkbookOpen"
'End Sub

Private Sub xlApp_SheetBeforeRightClick(ByVal Sh As Object, _
ByVal Target As Range, Cancel As Boolean)

MsgBox "xlApp_SheetBeforeRightClick " & Target.Address & " " &
Target.Hyperlinks.Count
'Add or remove Hyperlink menu items based on whether or not Hyperlink(s)
are selected

Dim oCtrl As CommandBarControl
Dim oBtn As CommandBarControl
Dim bMenusExist As Boolean
Dim bHyperlinksExist As Boolean

For Each oCtrl In Application.CommandBars("Cell").Controls
If oCtrl.Caption = "Copy Hyperlinked Docs To..." Then
bMenusExist = True
Exit For
End If
Next

bHyperlinksExist = Target.Hyperlinks.Count 0

If bHyperlinksExist And Not bMenusExist Then
Set oCtrl =
Application.CommandBars("Cell").Controls.Add(Type: =msoControlButton, _
Temporary:=True)
oCtrl.Caption = "Copy Hyperlinked Docs To..."
oCtrl.OnAction = "CopyHyperlinkedDocsTo"

Set oCtrl =
Application.CommandBars("Cell").Controls.Add(Type: =msoControlButton, _
Temporary:=True)
oCtrl.Caption = "Zip && Email Hyperlinked Docs..."
oCtrl.OnAction = "ZipAndEmailHyperlinkedDocs"

' Set oCtrl =
Application.CommandBars("Cell").Controls.Add(Type: =msoControlButton, _
' Temporary:=True)
' oCtrl.Caption = "Print Hyperlinked Docs..."
' oCtrl.OnAction = "PrintHyperlinkedDocs"
ElseIf Not bHyperlinksExist Then
For Each oCtrl In Application.CommandBars("Cell").Controls
If oCtrl.Caption = "Copy Hyperlinked Docs To..." Then
oCtrl.Delete
ElseIf oCtrl.Caption = "Zip && Email Hyperlinked Docs..." Then
oCtrl.Delete
ElseIf oCtrl.Caption = "Print Hyperlinked Docs..." Then
oCtrl.Delete
End If
Next
End If
End Sub

'Regular module --------------------------------------------------------------

Public moXLEvents As clsXLEvents



'ThisWorkbook -----------------------------------------------------------

Private Sub Workbook_Open()
Dim oWorksheet As Worksheet

Set moXLEvents = New clsXLEvents
Set oWorksheet = ThisWorkbook.ActiveSheet
If oWorksheet.Range("a2").Value = "" Then
ListNewerFiles.Show vbModal
End If
End Sub

"Norman Jones" wrote:

Hi MAB,

Try posting the code for the repopulation macro.

In the absence of the code, I can only surmise that the macro is turning off
events and, perhaps, unintentionally, failing to restore them.


---
Regards,
Norman



"MAB" wrote in message
...
SheetBeforeRightClick Event procedure stops firing after my macro
repopulates
a spread sheet. Any thoughts?

I never destroy the object. When the SheetBeforeRightClick event stops
working is when I repopulate the spread sheet with data. Here's the majority
of the rest of the code (if you want the template containg all code, I can
email it to you.):

'UserForm -----------------------------------------

Option Explicit

Dim mbStop As Boolean
Dim msSpin As String

Private Sub UserForm_Initialize()
Dim sWhereToLook As String
Dim sMaster_FileSpecs As String
Dim sRoots As String
Dim sFromRoot_FileSpecs As String
Dim vList As Variant
Dim vItem As Variant

MonthView1.MaxDate = Fix(Now) + 1
MonthView1.Value = (Now - 7)
EnabledStartQ

sMaster_FileSpecs = GetSetting(gsAppName, gsSection, gsWhereToLook,
"optMaster")
If sMaster_FileSpecs = "optMaster" Then
optMaster.Value = True
Else
optFromRoot.Value = True
End If

sMaster_FileSpecs = GetSetting(gsAppName, gsSection, gsMaster_FileSpecs,
"*")
vList = Split(sMaster_FileSpecs, "|")
For Each vItem In vList
cboMasterFileSpec.AddItem vItem
Next
cboMasterFileSpec.Text = cboMasterFileSpec.List(0)

sRoots = GetSetting(gsAppName, gsSection, gsRoots)
If sRoots < "" Then
vList = Split(sRoots, "|")
For Each vItem In vList
cboRootFolder.AddItem vItem
Next
cboRootFolder.Text = cboRootFolder.List(0)
End If

sFromRoot_FileSpecs = GetSetting(gsAppName, gsSection,
gsFromRoot_FileSpecs)
If sFromRoot_FileSpecs < "" Then
vList = Split(sFromRoot_FileSpecs, "|")
For Each vItem In vList
cboFromRootFileSpec.AddItem vItem
Next
cboFromRootFileSpec.Text = cboFromRootFileSpec.List(0)
End If
End Sub

Private Sub cmdRemoveListItems_Click()
RemoveListItems.Show vbModal
End Sub

Private Sub cboFromRootFileSpec_Change()
EnabledStartQ
End Sub

Private Sub cboRootFolder_Change()
EnabledStartQ
End Sub

Private Sub optMaster_Click()
EnabledStartQ
End Sub

Private Sub optFromRoot_Click()
EnabledStartQ
End Sub

Sub EnabledStartQ()
Dim sMaster_FileSpec As String
Dim sFromRoot_FileSpec As String
Dim sRoot As String

If optMaster.Value = True Then
lblMasterFileSpec.Enabled = True
cboMasterFileSpec.Enabled = True
sMaster_FileSpec = cboMasterFileSpec.Text
cmdStart.Enabled = True
If sMaster_FileSpec < "" And Not sMaster_FileSpec Like "* *" And _
Not sMaster_FileSpec Like "*.*" Then

'Repair if necessary
If sMaster_FileSpec Like ";*" Then
cboMasterFileSpec.Text = Mid(sMaster_FileSpec, 2)
sMaster_FileSpec = cboMasterFileSpec.Text
End If
If sMaster_FileSpec Like "*;" Then
cboMasterFileSpec.Text = Mid(sMaster_FileSpec, 1,
Len(sMaster_FileSpec) - 1)
End If

cmdStart.Enabled = True
Else
cmdStart.Enabled = False
End If
cmdBrowse.Enabled = False
lblRootFolder.Enabled = False
cboRootFolder.Enabled = False
lblFromRootFileSpec.Enabled = False
cboFromRootFileSpec.Enabled = False
Else
cmdBrowse.Enabled = True
lblRootFolder.Enabled = True
cboRootFolder.Enabled = True
lblFromRootFileSpec.Enabled = True
cboFromRootFileSpec.Enabled = True
sRoot = cboRootFolder.Text
sFromRoot_FileSpec = cboFromRootFileSpec.Text
If sRoot < "" And Dir(sRoot, vbDirectory) < "" And _
sFromRoot_FileSpec < "" And Not sFromRoot_FileSpec Like "* *"
Then

'Repair if necessary
If sFromRoot_FileSpec Like ";*" Then
cboFromRootFileSpec.Text = Mid(sFromRoot_FileSpec, 2)
sFromRoot_FileSpec = cboFromRootFileSpec.Text
End If
If sFromRoot_FileSpec Like "*;" Then
cboFromRootFileSpec.Text = Mid(sFromRoot_FileSpec, 1,
Len(sFromRoot_FileSpec) - 1)
End If

cmdStart.Enabled = True
Else
cmdStart.Enabled = False
End If
lblMasterFileSpec.Enabled = False
cboMasterFileSpec.Enabled = False
End If
End Sub

Private Sub cmdBrowse_Click()
Dim sRootFolder As String

sRootFolder = ReturnFolder("Select root folder to search")
If sRootFolder < "" Then cboRootFolder.Text = sRootFolder
End Sub

Private Sub cmdExit_Click()
If cmdExit.Caption = "Exit" Or cmdExit.Caption = "Done" Then
End
Else 'Stop or Wait
Able True
EnabledStartQ
cmdExit.Caption = "Exit"
mbStop = True
End If
End Sub

Private Sub cmdStart_Click()
On Error GoTo ErrHandler

Dim sFolder As String
Dim vFolder As Variant
Dim sFile As String
Dim vFile As Variant
Dim oFolders As New Collection
Dim oAllFiles As New Collection
Dim oMatchingFiles As New Collection
Dim specs() As String
Dim sFromRoot_FileSpec As String
Dim vFromRootFileSpec As Variant
Dim sRoot As String
Dim iFolders As Integer
Dim lAllFiles As Long
Dim lFiles As Long
Dim lRow As Long
Dim lNewerThanCutoff As Long
Dim oWorksheet As Worksheet
Dim dCutoffDate As Date
Dim oRange As Range
Dim oFso As New Scripting.FileSystemObject
Dim oFile As Scripting.file
Dim sPathAndFile As String
Dim sFileName As String
Dim dFileDate As Date
Dim oHyperlink As Hyperlink
Dim sValue As String
Dim sErrMsg As String
Dim oRecurseFiles As New Collection
Dim lListPosition As Long
Dim sRootFolders As String
Dim sFromRoot_FileSpecs As String
Dim sMaster_FileSpecs As String
Dim x As Long

If optMaster.Value Then
SaveSetting gsAppName, gsSection, gsWhereToLook, "optMaster"
Else
SaveSetting gsAppName, gsSection, gsWhereToLook, "optFromRoot"
End If

ProgressBar1.Value = 0
lblNewerThanCutoff.Caption = 0
lblFile.Caption = ""
lblAllFiles.Caption = ""
mbStop = False

Able False

dCutoffDate = MonthView1.Value
msSpin = "\"
Set oWorksheet = ThisWorkbook.ActiveSheet

'Clear all rows in case data already exists from a previous query
(populate spread sheet)
lRow = 2
Do
sValue = CStr(oWorksheet.Cells(lRow, 1).Value)
oWorksheet.Range("a" & lRow).EntireRow.Clear
lRow = lRow + 1
Loop While sValue < ""

'Query (populate spread sheet)
------------------------------------------------------
If optMaster.Value = True Then
Dim vExt As Variant
Dim vSpec As Variant
Dim sCombined As String


sFromRoot_FileSpec = cboMasterFileSpec.Text
For Each vExt In Split(".dwg;.prt;.pdf;.tif;.doc", ";")
For Each vSpec In Split(sFromRoot_FileSpec, ";")
sCombined = sCombined & ";" & vSpec & vExt
Next
Next
If Left(sCombined, 1) = ";" Then sCombined = Mid(sCombined, 2)

specs = Split(sCombined, ";")

'Collect top level folders
sRoot = "J:\Master\"
sFolder = Dir(sRoot, vbDirectory) ' "." if
Do While sFolder < ""
SpinAndDoEvents
If mbStop Then Exit Sub
If sFolder Like "##" Or sFolder Like "[5-9]##" Or sFolder Like
"MERLIN" Then
oFolders.Add sRoot & sFolder & "\"
End If
sFolder = Dir
Loop
sRoot = "J:\!Sorting\CM_MASTER\"
sFolder = Dir(sRoot, vbDirectory) ' "." if
Do While sFolder < ""
SpinAndDoEvents
If mbStop Then Exit Sub
If sFolder Like "###" Then
oFolders.Add sRoot & sFolder & "\"
End If
sFolder = Dir
Loop
iFolders = oFolders.Count

'Collect list of all files matching the spec in the top level
folders (should be fairly quick).
On Error Resume Next 'Needed because oFolders could have some
files if files in the root folder have no file extension.
For Each vFolder In oFolders
'Debug.Print vFolder
For Each vFromRootFileSpec In specs
sFile = Dir(vFolder & vFromRootFileSpec, vbNormal)
'Debug.Print " " & sFile
If sFile < "" Then
Do
SpinAndDoEvents
If mbStop Then Exit Sub
If sFile < "." And sFile < ".." Then 'Not sure if
this is needed.
'Debug.Print " " & sFile
oAllFiles.Add vFolder & sFile
End If
sFile = Dir
Loop While sFile < ""
End If
Next
Next
'Debug.Print oFolders.Count
lAllFiles = oAllFiles.Count
lblAllFiles.Caption = lAllFiles
ProgressBar1.Max = lAllFiles
cmdExit.Caption = "Stop"

'Reorder list (if necessary) and save root folders list
lListPosition = lPositionIn_oList(cboMasterFileSpec,
cboMasterFileSpec.Text)
If lListPosition 0 Or lListPosition = -1 Then
If lListPosition 0 Then cboMasterFileSpec.RemoveItem
lListPosition
cboMasterFileSpec.AddItem cboMasterFileSpec.Text, 0
For x = 0 To cboMasterFileSpec.ListCount - 1
sMaster_FileSpecs = sMaster_FileSpecs & "|" &
cboMasterFileSpec.List(x)
Next x
sMaster_FileSpecs = Mid(sMaster_FileSpecs, 2)
SaveSetting gsAppName, gsSection, gsMaster_FileSpecs,
sMaster_FileSpecs
End If

'Test modified dates against cutoff date.
lRow = 2
For Each vFile In oAllFiles
lFiles = lFiles + 1
ProgressBar1.Value = lFiles
DoEvents
If mbStop Then Exit Sub
lblFile.Caption = lFiles
Set oFile = oFso.GetFile(vFile)
dFileDate = oFile.DateLastModified
' 'dFileDate = CDate(Format(oFile.DateLastModified, "m/d/yy,
h:mm:ss AMPM")) '6/24/2006 3:43:00 PM
' dFileDate = CDate(Format(oFile.DateLastModified, "General
Date")) '6/24/2006 3:43:00 PM
If dFileDate dCutoffDate Then
sFileName = oFile.Name
sPathAndFile = oFile.path
Set oRange = oWorksheet.Range("a" & lRow)
oRange.Value = sFileName
Set oHyperlink = oWorksheet.Hyperlinks.Add(oRange, "file://"
& sPathAndFile)
oWorksheet.Range("b" & lRow).Value = dFileDate
oWorksheet.Range("c" & lRow).Value = sPathAndFile
lNewerThanCutoff = lNewerThanCutoff + 1
lblNewerThanCutoff.Caption = lNewerThanCutoff
lRow = lRow + 1
End If
Next

If lNewerThanCutoff = 0 Then
sErrMsg = "No files found under path """ & sRoot & """ matching
the " & _
" file spec """ & sFromRoot_FileSpec & """ newer then the
specified cutoff " & _
"date """ & CStr(dCutoffDate) & """."
MsgBox sErrMsg, vbCritical, "User Error"
End If
Else 'From selected root folder.
cmdExit.Caption = "Please Wait": Me.Repaint 'SpinAndDoEvents
doesn't work (?)
sRoot = cboRootFolder.Text
sFromRoot_FileSpec = cboFromRootFileSpec.Text
Set oAllFiles = oGetSubFiles3(sRoot, sFromRoot_FileSpec,
oRecurseFiles)
If oAllFiles.Count 0 Then
lAllFiles = oAllFiles.Count
lblAllFiles.Caption = lAllFiles
ProgressBar1.Max = lAllFiles
cmdExit.Caption = "Stop"

'Reorder list (if necessary) and save root folders list
lListPosition = lPositionIn_oList(cboRootFolder,
cboRootFolder.Text)
If lListPosition 0 Or lListPosition = -1 Then
If lListPosition 0 Then cboRootFolder.RemoveItem
lListPosition
cboRootFolder.AddItem cboRootFolder.Text, 0
For x = 0 To cboRootFolder.ListCount - 1
sRootFolders = sRootFolders & "|" & cboRootFolder.List(x)
Next x
sRootFolders = Mid(sRootFolders, 2)
SaveSetting gsAppName, gsSection, gsRoots, sRootFolders
End If

'Reorder list (if necessary) and save root folders list
lListPosition = lPositionIn_oList(cboFromRootFileSpec,
cboFromRootFileSpec.Text)
If lListPosition 0 Or lListPosition = -1 Then
If lListPosition 0 Then cboFromRootFileSpec.RemoveItem
lListPosition
cboFromRootFileSpec.AddItem cboFromRootFileSpec.Text, 0
For x = 0 To cboFromRootFileSpec.ListCount - 1
sFromRoot_FileSpecs = sFromRoot_FileSpecs & "|" &
cboFromRootFileSpec.List(x)
Next x
sFromRoot_FileSpecs = Mid(sFromRoot_FileSpecs, 2)
SaveSetting gsAppName, gsSection, gsFromRoot_FileSpecs,
sFromRoot_FileSpecs
End If

'Test modified dates against cutoff date.
lRow = 2
For Each vFile In oAllFiles
'Debug.Print vFile
lFiles = lFiles + 1
ProgressBar1.Value = lFiles
DoEvents
If mbStop Then Exit Sub
lblFile.Caption = lFiles
Set oFile = oFso.GetFile(vFile)
dFileDate = oFile.DateLastModified
' 'dFileDate = CDate(Format(oFile.DateLastModified, "m/d/yy,
h:mm:ss AMPM")) '6/24/2006 3:43:00 PM
' dFileDate = CDate(Format(oFile.DateLastModified, "General
Date")) '6/24/2006 3:43:00 PM
If dFileDate dCutoffDate Then
sFileName = oFile.Name
sPathAndFile = oFile.path
Set oRange = oWorksheet.Range("a" & lRow)
oRange.Value = sFileName
Set oHyperlink = oWorksheet.Hyperlinks.Add(oRange,
"file://" & sPathAndFile)
oWorksheet.Range("b" & lRow).Value = dFileDate
oWorksheet.Range("c" & lRow).Value = sPathAndFile
lNewerThanCutoff = lNewerThanCutoff + 1
lblNewerThanCutoff.Caption = lNewerThanCutoff
lRow = lRow + 1
End If
Next
End If

If lNewerThanCutoff = 0 Then
sErrMsg = "No files found under path """ & sRoot & """ matching
the " & _
" file spec """ & sFromRoot_FileSpec & """ newer then the
specified cutoff " & _
"date """ & CStr(dCutoffDate) & """."
MsgBox sErrMsg, vbCritical, "User Error"
End If
End If
'------------------------------------------------------------------------------

SortBy "b", xlDescending, "a"
cmdExit.Caption = "Done"

'EnabledStartQ (after these statements) will override some of these
Able True
EnabledStartQ
Exit Sub

ErrHandler:
MsgBox Err.Description, vbCritical, "Error"
Able True
EnabledStartQ
End Sub


Sub Able(bEnable As Boolean)
cmdStart.Enabled = bEnable
cmdRemoveListItems.Enabled = bEnable
fraWhereToLook.Enabled = bEnable
optMaster.Enabled = bEnable
lblMasterFileSpec.Enabled = bEnable
cboMasterFileSpec.Enabled = bEnable
optFromRoot.Enabled = bEnable
lblRootFolder.Enabled = bEnable
cboRootFolder.Enabled = bEnable
cmdBrowse.Enabled = bEnable
MonthView1.Enabled = bEnable
End Sub


'SpinAndDoEventsner added to toolbox routines (start)
-------------------------------------------------------------

Private Function oGetSubFiles3(ByVal sPath As String, ByVal SpecString As
String, _
subFiles As Collection) As Collection

Dim vFile As Variant
Dim oTemp As New Collection
Dim oTemp2 As New Collection
Dim vFolder As Variant

If Right(sPath, 1) < "\" Then sPath = sPath & "\"

'On Error Resume Next
Set oTemp = oGetFiles3(sPath, SpecString)
For Each vFile In oTemp
'Debug.Print file
subFiles.Add vFile, vFile
Next

On Error Resume Next
Set oTemp2 = oGetFolders2(sPath)
For Each vFolder In oTemp2
If vFolder < "" Then
Set oTemp = oGetSubFiles3(sPath & vFolder, SpecString, subFiles)
'Debug.Print oTemp.Count
End If
Next

Set oGetSubFiles3 = subFiles
End Function

Private Function oGetFiles3(ByVal folder As String, ByVal SpecString As
String) As Collection

Dim vSpecs() As String
Dim vItem As Variant
Dim sFileName As String
Dim oTemp As New Collection

If Right(folder, 1) < "\" Then folder = folder & "\"

On Error Resume Next
vSpecs = Split(SpecString, ";")
For Each vItem In vSpecs
sFileName = Dir(folder & vItem, vbNormal) 'Debug.Print sFileName
Do While sFileName < ""
SpinAndDoEvents
If sFileName Like "*.*" Then
oTemp.Add folder & sFileName, folder & sFileName
End If
sFileName = Dir 'What is DIR?
Loop
Next
Set oGetFiles3 = oTemp
'MsgBox SpecString & " " & GetFiles3.Count
End Function

Private Function oGetFolders2(ByVal sRoot As String) As Collection
Dim sFolder As String
Dim oCol As New Collection

If Right(sRoot, 1) < "\" Then sRoot = sRoot & "\"
sFolder = Dir(sRoot, vbDirectory)
If Not sFolder Like "*.*" Then oCol.Add sFolder
Do While sFolder < ""
If Not sFolder Like "*.*" Then oCol.Add sFolder
sFolder = Dir
Loop
Set oGetFolders2 = oCol
End Function


'SpinAndDoEventsner added to toolbox routines (end)
-------------------------------------------------------------

'
Private Sub SpinAndDoEvents()
Select Case msSpin
Case "\"
msSpin = "|"
Case "|"
msSpin = "/"
Case "/"
msSpin = "-"
Case "-"
msSpin = "\"
End Select
cmdExit.Caption = "Please Wait " & msSpin
DoEvents 'Needed to force graphic update of Exit button
End Sub

'
Private Function lPositionIn_oList(oList As Control, ByVal key As String) As
Long
Dim index As Long
Dim found As Boolean
Dim cnt As Long
Dim item As String

cnt = 0
key = UCase(key)

For index = 0 To oList.ListCount - 1
item = UCase(oList.List(index))
If item = key Then
found = True
Exit For
End If
cnt = cnt + 1
Next index


If found = True Then
lPositionIn_oList = cnt
Else
lPositionIn_oList = -1 ' not found
End If
End Function



"Jim Thomlinson" wrote:

Does your object get destroyed at any point? Do you have an End anywhere in
your code? End destroys objects...
--
HTH...

Jim Thomlinson


"MAB" wrote:

'Class module ---------------------------------------------------------

Private WithEvents xlApp As Excel.Application

Private Sub Class_Initialize()
Set xlApp = Excel.Application
End Sub

'Doesn't seem to auto-execute
'Private Sub xlApp_WorkbookOpen(ByVal Wb As Workbook)
' MsgBox "xlApp_WorkbookOpen"
'End Sub

Private Sub xlApp_SheetBeforeRightClick(ByVal Sh As Object, _
ByVal Target As Range, Cancel As Boolean)

MsgBox "xlApp_SheetBeforeRightClick " & Target.Address & " " &
Target.Hyperlinks.Count
'Add or remove Hyperlink menu items based on whether or not Hyperlink(s)
are selected

Dim oCtrl As CommandBarControl
Dim oBtn As CommandBarControl
Dim bMenusExist As Boolean
Dim bHyperlinksExist As Boolean

For Each oCtrl In Application.CommandBars("Cell").Controls
If oCtrl.Caption = "Copy Hyperlinked Docs To..." Then
bMenusExist = True
Exit For
End If
Next

bHyperlinksExist = Target.Hyperlinks.Count 0

If bHyperlinksExist And Not bMenusExist Then
Set oCtrl =
Application.CommandBars("Cell").Controls.Add(Type: =msoControlButton, _
Temporary:=True)
oCtrl.Caption = "Copy Hyperlinked Docs To..."
oCtrl.OnAction = "CopyHyperlinkedDocsTo"

Set oCtrl =
Application.CommandBars("Cell").Controls.Add(Type: =msoControlButton, _
Temporary:=True)
oCtrl.Caption = "Zip && Email Hyperlinked Docs..."
oCtrl.OnAction = "ZipAndEmailHyperlinkedDocs"

' Set oCtrl =
Application.CommandBars("Cell").Controls.Add(Type: =msoControlButton, _
' Temporary:=True)
' oCtrl.Caption = "Print Hyperlinked Docs..."
' oCtrl.OnAction = "PrintHyperlinkedDocs"
ElseIf Not bHyperlinksExist Then
For Each oCtrl In Application.CommandBars("Cell").Controls
If oCtrl.Caption = "Copy Hyperlinked Docs To..." Then
oCtrl.Delete
ElseIf oCtrl.Caption = "Zip && Email Hyperlinked Docs..." Then
oCtrl.Delete
ElseIf oCtrl.Caption = "Print Hyperlinked Docs..." Then
oCtrl.Delete
End If
Next
End If
End Sub

'Regular module --------------------------------------------------------------

Public moXLEvents As clsXLEvents



'ThisWorkbook -----------------------------------------------------------

Private Sub Workbook_Open()
Dim oWorksheet As Worksheet

Set moXLEvents = New clsXLEvents
Set oWorksheet = ThisWorkbook.ActiveSheet
If oWorksheet.Range("a2").Value = "" Then
ListNewerFiles.Show vbModal
End If
End Sub

"Norman Jones" wrote:

Hi MAB,

Try posting the code for the repopulation macro.

In the absence of the code, I can only surmise that the macro is turning off
events and, perhaps, unintentionally, failing to restore them.


---
Regards,
Norman



"MAB" wrote in message
...
SheetBeforeRightClick Event procedure stops firing after my macro
repopulates
a spread sheet. Any thoughts?

You have an End in your code. As soon as that runs all of your globally
declared objects are cleared... You need to change this code (and any other
End's in your project...)

If cmdExit.Caption = "Exit" Or cmdExit.Caption = "Done" Then
End

Just a note. End is VERY dangerous code. There are two way sto stop your
car. Press on the brake until the car gently comes to a stop or to point the
car at a brick wall and then wait for the sudden stop. Both will stop your
car, but one is a lot less painful than the other. In code, End is equivalent
to "point your car at the brick wall and then wait for the sudden stop"...
--
HTH...

Jim Thomlinson


"MAB" wrote:

I never destroy the object. When the SheetBeforeRightClick event stops
working is when I repopulate the spread sheet with data. Here's the majority
of the rest of the code (if you want the template containg all code, I can
email it to you.):

'UserForm -----------------------------------------

Option Explicit

Dim mbStop As Boolean
Dim msSpin As String

Private Sub UserForm_Initialize()
Dim sWhereToLook As String
Dim sMaster_FileSpecs As String
Dim sRoots As String
Dim sFromRoot_FileSpecs As String
Dim vList As Variant
Dim vItem As Variant

MonthView1.MaxDate = Fix(Now) + 1
MonthView1.Value = (Now - 7)
EnabledStartQ

sMaster_FileSpecs = GetSetting(gsAppName, gsSection, gsWhereToLook,
"optMaster")
If sMaster_FileSpecs = "optMaster" Then
optMaster.Value = True
Else
optFromRoot.Value = True
End If

sMaster_FileSpecs = GetSetting(gsAppName, gsSection, gsMaster_FileSpecs,
"*")
vList = Split(sMaster_FileSpecs, "|")
For Each vItem In vList
cboMasterFileSpec.AddItem vItem
Next
cboMasterFileSpec.Text = cboMasterFileSpec.List(0)

sRoots = GetSetting(gsAppName, gsSection, gsRoots)
If sRoots < "" Then
vList = Split(sRoots, "|")
For Each vItem In vList
cboRootFolder.AddItem vItem
Next
cboRootFolder.Text = cboRootFolder.List(0)
End If

sFromRoot_FileSpecs = GetSetting(gsAppName, gsSection,
gsFromRoot_FileSpecs)
If sFromRoot_FileSpecs < "" Then
vList = Split(sFromRoot_FileSpecs, "|")
For Each vItem In vList
cboFromRootFileSpec.AddItem vItem
Next
cboFromRootFileSpec.Text = cboFromRootFileSpec.List(0)
End If
End Sub

Private Sub cmdRemoveListItems_Click()
RemoveListItems.Show vbModal
End Sub

Private Sub cboFromRootFileSpec_Change()
EnabledStartQ
End Sub

Private Sub cboRootFolder_Change()
EnabledStartQ
End Sub

Private Sub optMaster_Click()
EnabledStartQ
End Sub

Private Sub optFromRoot_Click()
EnabledStartQ
End Sub

Sub EnabledStartQ()
Dim sMaster_FileSpec As String
Dim sFromRoot_FileSpec As String
Dim sRoot As String

If optMaster.Value = True Then
lblMasterFileSpec.Enabled = True
cboMasterFileSpec.Enabled = True
sMaster_FileSpec = cboMasterFileSpec.Text
cmdStart.Enabled = True
If sMaster_FileSpec < "" And Not sMaster_FileSpec Like "* *" And _
Not sMaster_FileSpec Like "*.*" Then

'Repair if necessary
If sMaster_FileSpec Like ";*" Then
cboMasterFileSpec.Text = Mid(sMaster_FileSpec, 2)
sMaster_FileSpec = cboMasterFileSpec.Text
End If
If sMaster_FileSpec Like "*;" Then
cboMasterFileSpec.Text = Mid(sMaster_FileSpec, 1,
Len(sMaster_FileSpec) - 1)
End If

cmdStart.Enabled = True
Else
cmdStart.Enabled = False
End If
cmdBrowse.Enabled = False
lblRootFolder.Enabled = False
cboRootFolder.Enabled = False
lblFromRootFileSpec.Enabled = False
cboFromRootFileSpec.Enabled = False
Else
cmdBrowse.Enabled = True
lblRootFolder.Enabled = True
cboRootFolder.Enabled = True
lblFromRootFileSpec.Enabled = True
cboFromRootFileSpec.Enabled = True
sRoot = cboRootFolder.Text
sFromRoot_FileSpec = cboFromRootFileSpec.Text
If sRoot < "" And Dir(sRoot, vbDirectory) < "" And _
sFromRoot_FileSpec < "" And Not sFromRoot_FileSpec Like "* *"
Then

'Repair if necessary
If sFromRoot_FileSpec Like ";*" Then
cboFromRootFileSpec.Text = Mid(sFromRoot_FileSpec, 2)
sFromRoot_FileSpec = cboFromRootFileSpec.Text
End If
If sFromRoot_FileSpec Like "*;" Then
cboFromRootFileSpec.Text = Mid(sFromRoot_FileSpec, 1,
Len(sFromRoot_FileSpec) - 1)
End If

cmdStart.Enabled = True
Else
cmdStart.Enabled = False
End If
lblMasterFileSpec.Enabled = False
cboMasterFileSpec.Enabled = False
End If
End Sub

Private Sub cmdBrowse_Click()
Dim sRootFolder As String

sRootFolder = ReturnFolder("Select root folder to search")
If sRootFolder < "" Then cboRootFolder.Text = sRootFolder
End Sub

Private Sub cmdExit_Click()
If cmdExit.Caption = "Exit" Or cmdExit.Caption = "Done" Then
End
Else 'Stop or Wait
Able True
EnabledStartQ
cmdExit.Caption = "Exit"
mbStop = True
End If
End Sub

Private Sub cmdStart_Click()
On Error GoTo ErrHandler

Dim sFolder As String
Dim vFolder As Variant
Dim sFile As String
Dim vFile As Variant
Dim oFolders As New Collection
Dim oAllFiles As New Collection
Dim oMatchingFiles As New Collection
Dim specs() As String
Dim sFromRoot_FileSpec As String
Dim vFromRootFileSpec As Variant
Dim sRoot As String
Dim iFolders As Integer
Dim lAllFiles As Long
Dim lFiles As Long
Dim lRow As Long
Dim lNewerThanCutoff As Long
Dim oWorksheet As Worksheet
Dim dCutoffDate As Date
Dim oRange As Range
Dim oFso As New Scripting.FileSystemObject
Dim oFile As Scripting.file
Dim sPathAndFile As String
Dim sFileName As String
Dim dFileDate As Date
Dim oHyperlink As Hyperlink
Dim sValue As String
Dim sErrMsg As String
Dim oRecurseFiles As New Collection
Dim lListPosition As Long
Dim sRootFolders As String
Dim sFromRoot_FileSpecs As String
Dim sMaster_FileSpecs As String
Dim x As Long

If optMaster.Value Then
SaveSetting gsAppName, gsSection, gsWhereToLook, "optMaster"
Else
SaveSetting gsAppName, gsSection, gsWhereToLook, "optFromRoot"
End If

ProgressBar1.Value = 0
lblNewerThanCutoff.Caption = 0
lblFile.Caption = ""
lblAllFiles.Caption = ""
mbStop = False

Able False

dCutoffDate = MonthView1.Value
msSpin = "\"
Set oWorksheet = ThisWorkbook.ActiveSheet

'Clear all rows in case data already exists from a previous query
(populate spread sheet)
lRow = 2
Do
sValue = CStr(oWorksheet.Cells(lRow, 1).Value)
oWorksheet.Range("a" & lRow).EntireRow.Clear
lRow = lRow + 1
Loop While sValue < ""

'Query (populate spread sheet)
------------------------------------------------------
If optMaster.Value = True Then
Dim vExt As Variant
Dim vSpec As Variant
Dim sCombined As String


sFromRoot_FileSpec = cboMasterFileSpec.Text
For Each vExt In Split(".dwg;.prt;.pdf;.tif;.doc", ";")
For Each vSpec In Split(sFromRoot_FileSpec, ";")
sCombined = sCombined & ";" & vSpec & vExt
Next
Next
If Left(sCombined, 1) = ";" Then sCombined = Mid(sCombined, 2)

specs = Split(sCombined, ";")

'Collect top level folders
sRoot = "J:\Master\"
sFolder = Dir(sRoot, vbDirectory) ' "." if
Do While sFolder < ""
SpinAndDoEvents
If mbStop Then Exit Sub
If sFolder Like "##" Or sFolder Like "[5-9]##" Or sFolder Like
"MERLIN" Then
oFolders.Add sRoot & sFolder & "\"
End If
sFolder = Dir
Loop
sRoot = "J:\!Sorting\CM_MASTER\"
sFolder = Dir(sRoot, vbDirectory) ' "." if
Do While sFolder < ""
SpinAndDoEvents
If mbStop Then Exit Sub
If sFolder Like "###" Then
oFolders.Add sRoot & sFolder & "\"
End If
sFolder = Dir
Loop
iFolders = oFolders.Count

'Collect list of all files matching the spec in the top level
folders (should be fairly quick).
On Error Resume Next 'Needed because oFolders could have some
files if files in the root folder have no file extension.
For Each vFolder In oFolders
'Debug.Print vFolder
For Each vFromRootFileSpec In specs
sFile = Dir(vFolder & vFromRootFileSpec, vbNormal)
'Debug.Print " " & sFile
If sFile < "" Then
Do
SpinAndDoEvents
If mbStop Then Exit Sub
If sFile < "." And sFile < ".." Then 'Not sure if
this is needed.
'Debug.Print " " & sFile
oAllFiles.Add vFolder & sFile
End If
sFile = Dir
Loop While sFile < ""
End If
Next
Next
'Debug.Print oFolders.Count
lAllFiles = oAllFiles.Count
lblAllFiles.Caption = lAllFiles
ProgressBar1.Max = lAllFiles
cmdExit.Caption = "Stop"

'Reorder list (if necessary) and save root folders list
lListPosition = lPositionIn_oList(cboMasterFileSpec,
cboMasterFileSpec.Text)
If lListPosition 0 Or lListPosition = -1 Then

Thanks for the tip Jim, I oviously didn't know that. Do you have suggestions
of what I could do? My guess would be Me.Hide.

I really appreciate the help.


"Jim Thomlinson" wrote:

You have an End in your code. As soon as that runs all of your globally
declared objects are cleared... You need to change this code (and any other
End's in your project...)

If cmdExit.Caption = "Exit" Or cmdExit.Caption = "Done" Then
End

Just a note. End is VERY dangerous code. There are two way sto stop your
car. Press on the brake until the car gently comes to a stop or to point the
car at a brick wall and then wait for the sudden stop. Both will stop your
car, but one is a lot less painful than the other. In code, End is equivalent
to "point your car at the brick wall and then wait for the sudden stop"...
--
HTH...

Jim Thomlinson


"MAB" wrote:

I never destroy the object. When the SheetBeforeRightClick event stops
working is when I repopulate the spread sheet with data. Here's the majority
of the rest of the code (if you want the template containg all code, I can
email it to you.):

'UserForm -----------------------------------------

Option Explicit

Dim mbStop As Boolean
Dim msSpin As String

Private Sub UserForm_Initialize()
Dim sWhereToLook As String
Dim sMaster_FileSpecs As String
Dim sRoots As String
Dim sFromRoot_FileSpecs As String
Dim vList As Variant
Dim vItem As Variant

MonthView1.MaxDate = Fix(Now) + 1
MonthView1.Value = (Now - 7)
EnabledStartQ

sMaster_FileSpecs = GetSetting(gsAppName, gsSection, gsWhereToLook,
"optMaster")
If sMaster_FileSpecs = "optMaster" Then
optMaster.Value = True
Else
optFromRoot.Value = True
End If

sMaster_FileSpecs = GetSetting(gsAppName, gsSection, gsMaster_FileSpecs,
"*")
vList = Split(sMaster_FileSpecs, "|")
For Each vItem In vList
cboMasterFileSpec.AddItem vItem
Next
cboMasterFileSpec.Text = cboMasterFileSpec.List(0)

sRoots = GetSetting(gsAppName, gsSection, gsRoots)
If sRoots < "" Then
vList = Split(sRoots, "|")
For Each vItem In vList
cboRootFolder.AddItem vItem
Next
cboRootFolder.Text = cboRootFolder.List(0)
End If

sFromRoot_FileSpecs = GetSetting(gsAppName, gsSection,
gsFromRoot_FileSpecs)
If sFromRoot_FileSpecs < "" Then
vList = Split(sFromRoot_FileSpecs, "|")
For Each vItem In vList
cboFromRootFileSpec.AddItem vItem
Next
cboFromRootFileSpec.Text = cboFromRootFileSpec.List(0)
End If
End Sub

Private Sub cmdRemoveListItems_Click()
RemoveListItems.Show vbModal
End Sub

Private Sub cboFromRootFileSpec_Change()
EnabledStartQ
End Sub

Private Sub cboRootFolder_Change()
EnabledStartQ
End Sub

Private Sub optMaster_Click()
EnabledStartQ
End Sub

Private Sub optFromRoot_Click()
EnabledStartQ
End Sub

Sub EnabledStartQ()
Dim sMaster_FileSpec As String
Dim sFromRoot_FileSpec As String
Dim sRoot As String

If optMaster.Value = True Then
lblMasterFileSpec.Enabled = True
cboMasterFileSpec.Enabled = True
sMaster_FileSpec = cboMasterFileSpec.Text
cmdStart.Enabled = True
If sMaster_FileSpec < "" And Not sMaster_FileSpec Like "* *" And _
Not sMaster_FileSpec Like "*.*" Then

'Repair if necessary
If sMaster_FileSpec Like ";*" Then
cboMasterFileSpec.Text = Mid(sMaster_FileSpec, 2)
sMaster_FileSpec = cboMasterFileSpec.Text
End If
If sMaster_FileSpec Like "*;" Then
cboMasterFileSpec.Text = Mid(sMaster_FileSpec, 1,
Len(sMaster_FileSpec) - 1)
End If

cmdStart.Enabled = True
Else
cmdStart.Enabled = False
End If
cmdBrowse.Enabled = False
lblRootFolder.Enabled = False
cboRootFolder.Enabled = False
lblFromRootFileSpec.Enabled = False
cboFromRootFileSpec.Enabled = False
Else
cmdBrowse.Enabled = True
lblRootFolder.Enabled = True
cboRootFolder.Enabled = True
lblFromRootFileSpec.Enabled = True
cboFromRootFileSpec.Enabled = True
sRoot = cboRootFolder.Text
sFromRoot_FileSpec = cboFromRootFileSpec.Text
If sRoot < "" And Dir(sRoot, vbDirectory) < "" And _
sFromRoot_FileSpec < "" And Not sFromRoot_FileSpec Like "* *"
Then

'Repair if necessary
If sFromRoot_FileSpec Like ";*" Then
cboFromRootFileSpec.Text = Mid(sFromRoot_FileSpec, 2)
sFromRoot_FileSpec = cboFromRootFileSpec.Text
End If
If sFromRoot_FileSpec Like "*;" Then
cboFromRootFileSpec.Text = Mid(sFromRoot_FileSpec, 1,
Len(sFromRoot_FileSpec) - 1)
End If

cmdStart.Enabled = True
Else
cmdStart.Enabled = False
End If
lblMasterFileSpec.Enabled = False
cboMasterFileSpec.Enabled = False
End If
End Sub

Private Sub cmdBrowse_Click()
Dim sRootFolder As String

sRootFolder = ReturnFolder("Select root folder to search")
If sRootFolder < "" Then cboRootFolder.Text = sRootFolder
End Sub

Private Sub cmdExit_Click()
If cmdExit.Caption = "Exit" Or cmdExit.Caption = "Done" Then
End
Else 'Stop or Wait
Able True
EnabledStartQ
cmdExit.Caption = "Exit"
mbStop = True
End If
End Sub

Private Sub cmdStart_Click()
On Error GoTo ErrHandler

Dim sFolder As String
Dim vFolder As Variant
Dim sFile As String
Dim vFile As Variant
Dim oFolders As New Collection
Dim oAllFiles As New Collection
Dim oMatchingFiles As New Collection
Dim specs() As String
Dim sFromRoot_FileSpec As String
Dim vFromRootFileSpec As Variant
Dim sRoot As String
Dim iFolders As Integer
Dim lAllFiles As Long
Dim lFiles As Long
Dim lRow As Long
Dim lNewerThanCutoff As Long
Dim oWorksheet As Worksheet
Dim dCutoffDate As Date
Dim oRange As Range
Dim oFso As New Scripting.FileSystemObject
Dim oFile As Scripting.file
Dim sPathAndFile As String
Dim sFileName As String
Dim dFileDate As Date
Dim oHyperlink As Hyperlink
Dim sValue As String
Dim sErrMsg As String
Dim oRecurseFiles As New Collection
Dim lListPosition As Long
Dim sRootFolders As String
Dim sFromRoot_FileSpecs As String
Dim sMaster_FileSpecs As String
Dim x As Long

If optMaster.Value Then
SaveSetting gsAppName, gsSection, gsWhereToLook, "optMaster"
Else
SaveSetting gsAppName, gsSection, gsWhereToLook, "optFromRoot"
End If

ProgressBar1.Value = 0
lblNewerThanCutoff.Caption = 0
lblFile.Caption = ""
lblAllFiles.Caption = ""
mbStop = False

Able False

dCutoffDate = MonthView1.Value
msSpin = "\"
Set oWorksheet = ThisWorkbook.ActiveSheet

'Clear all rows in case data already exists from a previous query
(populate spread sheet)
lRow = 2
Do
sValue = CStr(oWorksheet.Cells(lRow, 1).Value)
oWorksheet.Range("a" & lRow).EntireRow.Clear
lRow = lRow + 1
Loop While sValue < ""

'Query (populate spread sheet)
------------------------------------------------------
If optMaster.Value = True Then
Dim vExt As Variant
Dim vSpec As Variant
Dim sCombined As String


sFromRoot_FileSpec = cboMasterFileSpec.Text
For Each vExt In Split(".dwg;.prt;.pdf;.tif;.doc", ";")
For Each vSpec In Split(sFromRoot_FileSpec, ";")
sCombined = sCombined & ";" & vSpec & vExt
Next
Next
If Left(sCombined, 1) = ";" Then sCombined = Mid(sCombined, 2)

specs = Split(sCombined, ";")

'Collect top level folders
sRoot = "J:\Master\"
sFolder = Dir(sRoot, vbDirectory) ' "." if
Do While sFolder < ""
SpinAndDoEvents
If mbStop Then Exit Sub
If sFolder Like "##" Or sFolder Like "[5-9]##" Or sFolder Like
"MERLIN" Then
oFolders.Add sRoot & sFolder & "\"
End If
sFolder = Dir
Loop
sRoot = "J:\!Sorting\CM_MASTER\"
sFolder = Dir(sRoot, vbDirectory) ' "." if
Do While sFolder < ""
SpinAndDoEvents
If mbStop Then Exit Sub
If sFolder Like "###" Then
oFolders.Add sRoot & sFolder & "\"
End If
sFolder = Dir
Loop
iFolders = oFolders.Count

'Collect list of all files matching the spec in the top level
folders (should be fairly quick).
On Error Resume Next 'Needed because oFolders could have some
files if files in the root folder have no file extension.
For Each vFolder In oFolders
'Debug.Print vFolder
For Each vFromRootFileSpec In specs
sFile = Dir(vFolder & vFromRootFileSpec, vbNormal)
'Debug.Print " " & sFile
If sFile < "" Then
Do
SpinAndDoEvents
If mbStop Then Exit Sub