filipebessa9
05-22-2015, 07:07 AM
Hi everyone,
I'm currently doing a timesheet module for work and am struggling with a bit of code.
I have found here a bit of code which is perfect for what I want and need done but unfortunately it's interfering with other part of my code.
I am using the following code to make people enable the macro:
Option Explicit
Const WelcomePage = "Macros"
Private Sub Workbook_BeforeClose(Cancel As Boolean)
'Turn off events to prevent unwanted loops
Application.EnableEvents = False
'Evaluate if workbook is saved and emulate default propmts
With ThisWorkbook
If Not .Saved Then
Select Case MsgBox("Do you want to save the changes you made to '" & .Name & "'?", _
vbYesNoCancel + vbExclamation)
Case Is = vbYes
'Call customized save routine
Call CustomSave
Case Is = vbNo
'Do not save
Case Is = vbCancel
'Set up procedure to cancel close
Cancel = True
End Select
End If
'If Cancel was clicked, turn events back on and cancel close,
'otherwise close the workbook without saving further changes
If Not Cancel = True Then
.Saved = True
Application.EnableEvents = True
.Close savechanges:=False
Else
Application.EnableEvents = True
End If
End With
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'Turn off events to prevent unwanted loops
Application.EnableEvents = False
'Call customized save routine and set workbook's saved property to true
'(To cancel regular saving)
Call CustomSave(SaveAsUI)
Cancel = True
'Turn events back on an set saved property to true
Application.EnableEvents = True
ThisWorkbook.Saved = True
End Sub
Private Sub Workbook_Open()
'Unhide all worksheets
Application.ScreenUpdating = False
Call ShowAllSheets
Application.ScreenUpdating = True
End Sub
Private Sub CustomSave(Optional SaveAs As Boolean)
Dim ws As Worksheet, aWs As Worksheet, newFname As String
'Turn off screen flashing
Application.ScreenUpdating = False
'Record active worksheet
Set aWs = ActiveSheet
'Hide all sheets
Call HideAllSheets
'Save workbook directly or prompt for saveas filename
If SaveAs = True Then
newFname = Application.GetSaveAsFilename( _
fileFilter:="Excel Files (*.xls), *.xls")
If Not newFname = "False" Then ThisWorkbook.SaveAs newFname
Else
ThisWorkbook.Save
End If
'Restore file to where user was
Call ShowAllSheets
aWs.Activate
'Restore screen updates
Application.ScreenUpdating = True
End Sub
Private Sub HideAllSheets()
'Hide all worksheets except the macro welcome page
Dim ws As Worksheet
Worksheets(WelcomePage).Visible = xlSheetVisible
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = WelcomePage Then ws.Visible = xlSheetVeryHidden
Next ws
Worksheets(WelcomePage).Activate
End Sub
Private Sub ShowAllSheets()
'Show all worksheets except the macro welcome page
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = WelcomePage Then ws.Visible = xlSheetVisible
Next ws
Worksheets(WelcomePage).Visible = xlSheetVeryHidden
End Sub
------
When using this, unfortunately, it's then stopping my worksheet from being saved with the name I want it to have.
When not using the veryhidden code it does it by using the following code:
Public Sub Send_Email()
On Error Resume Next
Application.DisplayAlerts = False
MkDir ("C:\Timesheets\")
ActiveWorkbook.SaveAs "C:\Timesheets\" & Range("A3").Value & " " & Replace(Range("B3"), "/", "-") & ".xlsm"
Dim linsOutlookApp As Object
Dim linsMailItem As Object
Dim lstrFileName As String
Dim lstrOldFileName As String
Dim MailAddress As String
Dim CCMailAddress As String
Dim MailSubject As String
Dim EmailComments As Variant
Sheets("Time Entry").Activate
ActiveWorkbook.Save
If MsgBox("Press OK to send email", vbOKCancel, "Email Confirmation") = vbOK Then
Set linsOutlookApp = CreateObject("Outlook.Application")
linsOutlookApp.Session.Logon
Set linsMailItem = linsOutlookApp.CreateItem(0)
linsMailItem.Attachments.Add ActiveWorkbook.FullName
linsMailItem.Recipients.Add "myemail"
linsMailItem.Subject = "Timesheet for " & Range("A3").Value & " for w/c " & (Range("B3").Value)
linsMailItem.Body = "This file was sent automatically from Excel. " & _
linsMailItem.DeleteAfterSubmit = False
linsMailItem.Send
Else: End
End If
End Sub
------
I guess what I'm trying to get out of the help is:
1 - I want to keep using my initial code "Veryhidden" so that the users must enable macros to use this spreadsheet other it will not do what's meant to
2 - when I use the "veryhidden" bit of cade, my spreadsheet is using whatever name the spreadsheet has instead of renaming it according to the user that has input it's name and the date.
Could someone please help me tie these two up?
I need the veryhidden code to let my macro save the spreadsheet so it can then be sent with the right name and date.
Thank you for all your help! :)
Regards,
Andre Bessa
I'm currently doing a timesheet module for work and am struggling with a bit of code.
I have found here a bit of code which is perfect for what I want and need done but unfortunately it's interfering with other part of my code.
I am using the following code to make people enable the macro:
Option Explicit
Const WelcomePage = "Macros"
Private Sub Workbook_BeforeClose(Cancel As Boolean)
'Turn off events to prevent unwanted loops
Application.EnableEvents = False
'Evaluate if workbook is saved and emulate default propmts
With ThisWorkbook
If Not .Saved Then
Select Case MsgBox("Do you want to save the changes you made to '" & .Name & "'?", _
vbYesNoCancel + vbExclamation)
Case Is = vbYes
'Call customized save routine
Call CustomSave
Case Is = vbNo
'Do not save
Case Is = vbCancel
'Set up procedure to cancel close
Cancel = True
End Select
End If
'If Cancel was clicked, turn events back on and cancel close,
'otherwise close the workbook without saving further changes
If Not Cancel = True Then
.Saved = True
Application.EnableEvents = True
.Close savechanges:=False
Else
Application.EnableEvents = True
End If
End With
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'Turn off events to prevent unwanted loops
Application.EnableEvents = False
'Call customized save routine and set workbook's saved property to true
'(To cancel regular saving)
Call CustomSave(SaveAsUI)
Cancel = True
'Turn events back on an set saved property to true
Application.EnableEvents = True
ThisWorkbook.Saved = True
End Sub
Private Sub Workbook_Open()
'Unhide all worksheets
Application.ScreenUpdating = False
Call ShowAllSheets
Application.ScreenUpdating = True
End Sub
Private Sub CustomSave(Optional SaveAs As Boolean)
Dim ws As Worksheet, aWs As Worksheet, newFname As String
'Turn off screen flashing
Application.ScreenUpdating = False
'Record active worksheet
Set aWs = ActiveSheet
'Hide all sheets
Call HideAllSheets
'Save workbook directly or prompt for saveas filename
If SaveAs = True Then
newFname = Application.GetSaveAsFilename( _
fileFilter:="Excel Files (*.xls), *.xls")
If Not newFname = "False" Then ThisWorkbook.SaveAs newFname
Else
ThisWorkbook.Save
End If
'Restore file to where user was
Call ShowAllSheets
aWs.Activate
'Restore screen updates
Application.ScreenUpdating = True
End Sub
Private Sub HideAllSheets()
'Hide all worksheets except the macro welcome page
Dim ws As Worksheet
Worksheets(WelcomePage).Visible = xlSheetVisible
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = WelcomePage Then ws.Visible = xlSheetVeryHidden
Next ws
Worksheets(WelcomePage).Activate
End Sub
Private Sub ShowAllSheets()
'Show all worksheets except the macro welcome page
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = WelcomePage Then ws.Visible = xlSheetVisible
Next ws
Worksheets(WelcomePage).Visible = xlSheetVeryHidden
End Sub
------
When using this, unfortunately, it's then stopping my worksheet from being saved with the name I want it to have.
When not using the veryhidden code it does it by using the following code:
Public Sub Send_Email()
On Error Resume Next
Application.DisplayAlerts = False
MkDir ("C:\Timesheets\")
ActiveWorkbook.SaveAs "C:\Timesheets\" & Range("A3").Value & " " & Replace(Range("B3"), "/", "-") & ".xlsm"
Dim linsOutlookApp As Object
Dim linsMailItem As Object
Dim lstrFileName As String
Dim lstrOldFileName As String
Dim MailAddress As String
Dim CCMailAddress As String
Dim MailSubject As String
Dim EmailComments As Variant
Sheets("Time Entry").Activate
ActiveWorkbook.Save
If MsgBox("Press OK to send email", vbOKCancel, "Email Confirmation") = vbOK Then
Set linsOutlookApp = CreateObject("Outlook.Application")
linsOutlookApp.Session.Logon
Set linsMailItem = linsOutlookApp.CreateItem(0)
linsMailItem.Attachments.Add ActiveWorkbook.FullName
linsMailItem.Recipients.Add "myemail"
linsMailItem.Subject = "Timesheet for " & Range("A3").Value & " for w/c " & (Range("B3").Value)
linsMailItem.Body = "This file was sent automatically from Excel. " & _
linsMailItem.DeleteAfterSubmit = False
linsMailItem.Send
Else: End
End If
End Sub
------
I guess what I'm trying to get out of the help is:
1 - I want to keep using my initial code "Veryhidden" so that the users must enable macros to use this spreadsheet other it will not do what's meant to
2 - when I use the "veryhidden" bit of cade, my spreadsheet is using whatever name the spreadsheet has instead of renaming it according to the user that has input it's name and the date.
Could someone please help me tie these two up?
I need the veryhidden code to let my macro save the spreadsheet so it can then be sent with the right name and date.
Thank you for all your help! :)
Regards,
Andre Bessa