Can you have a Work button in Excel like you can in Word?

[amandarose80]

I know in Word you can add a premade button that says Work... when you click on this your most used files appear (after you have added them). Can you do this in Excel? If so, how?

Thanks!!

 

[Nareik]

I have seen it doen with an add-in crated by Ian Sharpe.

I have customised it a bit, but the following work is basically his.
I have not used it for some time, but I beleive that it is workable, however to remove an itme still requires that you use the toolbar customeise command I think,

THe utility is alos not very good at trapping the occurence wher the excel file is open eleswhere (no 'read only' message)

Bundle the following up into an addin and see if it suffices.

Option Explicit
Sub auto_add()
' Runs when add-in enabled. Installs Work menu on Worksheet menu bar
Dim WorkMenu
Dim NewItem As CommandBarControl

' Is it installed already?
Set WorkMenu = CommandBars.FindControl(Type:=msoControlPopup, Tag:="IansExcelWorkMenu&quot
If Not WorkMenu Is Nothing Then
MsgBox "Work menu already present under " & WorkMenu.Parent.Name
Exit Sub
End If

' Install on to Worksheet menu bar
Set WorkMenu = CommandBars(1).Controls.Add(Type:=msoControlPopup)
WorkMenu.Caption = "Work"
WorkMenu.Tag = "IansExcelWorkMenu"

' Add 'Add current workbook' item to it
Set NewItem = WorkMenu.Controls.Add(Type:=msoControlButton)
With NewItem
.Caption = "Add current workbook"
.OnAction = "AddToWork"
End With

MsgBox "Work menu installed on Worksheet menu bar"
End Sub

Sub auto_remove()
' Runs when add-in is disabled. Removes Work menu
Dim WorkMenu As CommandBarControl

' Find menu
Set WorkMenu = CommandBars.FindControl(Type:=msoControlPopup, Tag:="IansExcelWorkMenu&quot
' And delete it
If Not WorkMenu Is Nothing Then ' In case the user has already deleted it manually
WorkMenu.Delete
End If
End Sub

Sub AddToWork()
' Called by 'Add current workbook' menu item.
Dim WorkMenu, NewItem, Cntrl As CommandBarControl
Dim f, p As Integer
Dim FileNameToAdd As String
Dim FileExists As Boolean

If ActiveWorkbook Is Nothing Then ' Shouldn't happen, but just in case...
Exit Sub
End If

' In case the user has relocated the Work menu, find it...
Set WorkMenu = CommandBars.FindControl(Type:=msoControlPopup, Tag:="IansExcelWorkMenu&quot

' isolate file name from file name and path
f = 0
Do
p = f + 1
f = InStr(p, ActiveWorkbook.FullName, "\&quot
Loop Until f = 0
FileNameToAdd = Mid(ActiveWorkbook.FullName, p)

' check to see if file exists on list already
FileExists = False
For Each Cntrl In WorkMenu.Controls
If Cntrl.Caption = FileNameToAdd Then
FileExists = True
Exit For
End If
Next

If WorkMenu.Controls.Count > 11 Then
' 11 equates to 9 files as there is a separator and add command at the top of the menu

f = MsgBox("You have more than 9 files listed." & vbCrLf _
& "This may be a good time to think about clearing up the old entries on the list.", _
vbInformation, "A message from the good housekeeper magazine...&quot
End If

' Add worksheet name as new item
If FileExists = False Then
Set NewItem = WorkMenu.Controls.Add(Type:=msoControlButton)
With NewItem
.Caption = FileNameToAdd
.DescriptionText = ActiveWorkbook.FullName
.OnAction = "WorkMenuLoadFile"
End With

' If this is the first file in the list, make it start of new group
If NewItem.Index = 2 Then
NewItem.BeginGroup = True
End If

Else
f = MsgBox("The file " & FileNameToAdd & _
" already is on the list. It has not been added again", _
vbOKOnly, "File not added to Work Menu&quot
End If

End Sub

Sub WorkMenuLoadFile()
' Called by workbook entries on Work menu.
Dim CallerIndex As Integer
Dim WorkMenu As CommandBarControl
Dim f As Integer
Dim FileOpenStatus As Variant

' Find current location of Work menu...
Set WorkMenu = CommandBars.FindControl(Type:=msoControlPopup, Tag:="IansExcelWorkMenu&quot
' Which menu item invoked this Sub?
CallerIndex = Application.Caller(1) - 1 ' - 1 compensates for group divider

' Check if file open
FileOpenStatus = IsFileOpen(WorkMenu.Controls.Item(CallerIndex).DescriptionText)

If FileOpenStatus = True Then
f = MsgBox("The file : " & WorkMenu.Controls.Item(CallerIndex).Caption & " is already open" _
& vbCrLf & Error(Err.Number), vbInformation, "Read only mode activated&quot
ElseIf FileOpenStatus <> False Then
MsgBox FileOpenStatus & &quot;Error&quot;, vbOKOnly, &quot;It's buggered&quot;
End If
'f = MsgBox(GetClosedFileProperty(WorkMenu.Controls.Item(CallerIndex).Caption, &quot;WriteReservedBy&quot)

' Open file & run auto_open macro if it exists
On Error GoTo FileOpenError
Application.Workbooks.Open filename:=WorkMenu.Controls.Item(CallerIndex).DescriptionText, _
Notify:=True
ActiveWorkbook.RunAutoMacros xlAutoOpen
Exit Sub


FileOpenError:
If Err.Number = 1004 And Err.Source <> &quot;VBAProject&quot; Then
f = MsgBox(&quot;The file &quot; & WorkMenu.Controls.Item(CallerIndex).Caption & &quot; was not opened&quot; & _
vbCrLf & _
&quot;Probably due to the file already being open, or does not exist/renamed/moved&quot;, _
vbInformation, &quot;File not Opened&quot
Resume Next
Else
f = MsgBox(&quot;The following error details occurred trying to open file :&quot; _
& WorkMenu.Controls.Item(CallerIndex).Caption & vbCrLf & _
Error(Err.Number), vbInformation, &quot;File open error&quot
End If
End Sub

Function IsFileOpen(filename As String)
Dim filenum As Integer, errnum As Integer

On Error Resume Next ' Turn error checking off.
filenum = FreeFile() ' Get a free file number.
' Attempt to open the file and lock it.
Open filename For Input Lock Read As #filenum
Close filenum ' Close the file.
errnum = Err ' Save the error number that occurred.
On Error GoTo 0 ' Turn error checking back on.

' Check to see which error occurred.
Select Case errnum

' No error occurred.
' File is NOT already open by another user.
Case 0
IsFileOpen = False

' Error number for &quot;Permission Denied.&quot;
' File is already opened by another user.
Case 70
IsFileOpen = True

' Another error occurred.
Case Else
Error errnum
End Select
End Function



Private Function GetClosedFileProperty(FilePathAndName As String, Property As String)
' Retrieves a property from a closed workbook
Dim arg As String

' Create the argument
arg = &quot;&quot;&quot;&quot; + FilePathAndName & &quot;.&quot; & Property + &quot;&quot;&quot;&quot;
' Execute an XLM macro
GetClosedFileProperty = ExecuteExcel4Macro(arg)
End Function



Kieran