Hi guys,
I have been given a macro to fix for my boss who thinks he deleted something by mistake but can't for the life of me find out what the problem is.
I have stepped through it (the spreadsheet is a leave request form which automatically generates messages and a email to approvers folllowing completion) and the problem seems to be at the top of the code but any further thoughts would be most welcome as it's doing my head in!
Many thanks in advance!
J
---
Full code:
Option Explicit '** means all variables must be properly declared with dim ... **
'***********************************************************
Public Declare Function GetUserName Lib "advapi32.dll" _
Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function GetLongPathName Lib "kernel32.dll" Alias "GetLongPathNameA" _
(ByVal lpszShortPath As String, ByVal lpszLongPath As String, ByVal cchBuffer As Long) As Long
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" _
(ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
'***********************************************************
Const Default_FN = "Expenses Claim Form (email)"
'***********************************************************
'** Reads the WINDOWS Login Identity **
'***********************************************************
Public Function ReturnUserName() As String
Dim rString As String * 255, sLen As Long, tString As String
tString = ""
On Error Resume Next
sLen = GetUserName(rString, 255)
sLen = InStr(1, rString, Chr(0))
If sLen > 0 Then
tString = Left(rString, sLen - 1)
Else
tString = rString
End If
On Error GoTo 0
ReturnUserName = UCase(Trim(tString))
End Function
'***************************************************************************************
'** This function uses Windows API GetTempPath to get the temporary folder **
'** It then converts the returned "short path" or dos8.3 path with ~ into a long path **
'***************************************************************************************
Private Function TempFldrPath()
Dim sShortPath As String, sLongPath As String
Dim l As Long
sShortPath = String(255, vbNullChar) '** pads out a 255 character string **
sLongPath = String(255, vbNullChar) '** pads out a 255 character string **
l = GetTempPath(255, sShortPath)
If l = 0 Then
TempFldrPath = vbNullString
Else
sShortPath = Left(sShortPath, l)
l = GetLongPathName(sShortPath, sLongPath, 255)
TempFldrPath = Left$(sLongPath, l)
End If
End Function
'** to test above function **
Sub Get_Temporary_Folder()
Debug.Print TempFldrPath
End Sub
Private Sub Wholeapprovalmacro()
Dim iAns As Integer
Application.DisplayAlerts = False
' iAns = MsgBox(prompt:= _
' "Are you sure you want to approve?" & vbCr _
' & "Answering yes automatically sends an email from you approving the request." & vbCr _
' & vbCr _
' & "(NB: This file is attached to the message, and a copy is saved in your sent items)" _
' , Title:="APPROVE AND EMAIL THE HOLIDAY FORM" _
' , Buttons:=vbYesNo)
' iAns = MsgBox(Title:="APPROVE AND SUBMIT LEAVE DATES" _
' prompt:="PLEASE ENSURE" & vbCr _
' & "- You have checked the dates and want to approve it" & vbCr _
' & "- You have the authority to do so" _
' & vbCr & vbCr _
' & "PLEASE NOTE" & vbCr _
' & "- Clicking 'OK' will save this file and submit the claim by email." & vbCr _
' & "- A copy will be saved in your email program's SENT folder." & vbCr _
' & vbCr _
' & "Continue?" _
' , Buttons:=vbOKCancel)
If iAns = vbOK Then Run "TestFile"
If iAns = vbCancel Then Run "CancelSend"
Application.DisplayAlerts = True
End Sub
Private Sub TestFile()
Dim sFileStatus As String
Dim sTempDir As String
Dim iAns As Integer
sTempDir = TempFldrPath
'** SAVED - A file saved in a folder (ie not a temp folder )**
'** New - file is 'new' created from a template (eg filename.xlt) **
'** Tmp - file is saved in a temp folder as it was likely opened from an email message **
If ThisWorkbook.Path = "" Then
sFileStatus = "new and unsaved"
ElseIf sTempDir = Left(ThisWorkbook.Path, Len(sTempDir)) _
Or InStr(ThisWorkbook.Path, "Temporary Internet Files") <> 0 Then
sFileStatus = "only temporarily saved"
Else: sFileStatus = "saved"
End If
'** Tmp or New **
If sFileStatus <> "saved" Then
iAns = MsgBox(Title:="SAVE A COPY OF THIS FILE?", prompt:="" _
& "A copy of the expense claim will be saved in your email program's SENT folder. However, " & vbCr _
& "this file is currently " & sFileStatus & vbCr _
& vbCr _
& "Do you also want to save a second copy on your C:\ drive or the network (eg S:\ drive)?" & vbCr _
, Buttons:=vbYesNoCancel)
End If
If iAns = vbCancel Then Run "CancelSend"
If iAns = vbYes Then Run "GetSaveAsFN"
If iAns = vbNo And sFileStatus = "new and unsaved" Then
ThisWorkbook.SaveAs TempFldrPath & ThisWorkbook.Name
Else: ThisWorkbook.Save
End If
Run "EmailIt"
End Sub
Private Sub CancelSend()
MsgBox Title:="FYI" _
, prompt:="File NOT saved and expense claim NOT submitted." _
, Buttons:=vbOKOnly + vbCritical
End
End Sub
Private Sub GetSaveAsFn()
Dim sFN As String, sExtn As String, iExtn As Integer
Dim sFldr As String
sFldr = Application.DefaultFilePath
If sFldr = "" Then sFldr = "c:\"
ChDir sFldr
ChDrive sFldr
sFN = Default_FN & " - " & ReturnUserName & " " & Replace(Fix(Now()), "/", "-") & ".xls"
sFN = Application.GetSaveAsFilename(InitialFileName:=sFN _
, FileFilter:="Excel 97-03 , *.xls, Excel 07 binary, *.xlsb, Excel 07 macro, *.xlsm" _
, FilterIndex:=1 _
, Title:="Choose a Filename and Save")
If sFN = "False" Then Run "CancelSend"
sExtn = Right(sFN, InStr(StrReverse(sFN), "."))
Select Case sExtn
Case ".xls": iExtn = 56
Case ".xlsb": iExtn = 50
Case ".xlsm": iExtn = 52
End Select
ThisWorkbook.SaveAs Filename:=sFN, FileFormat:=iExtn
'50 = xlExcel12 (Excel Binary Workbook in 2007 with or without macro’s, xlsb)
'51 = xlOpenXMLWorkbook (without macro's in 2007, xlsx)
'52 = xlOpenXMLWorkbookMacroEnabled (with or without macro's in 2007, xlsm)
'56 = xlExcel8 (97-2003 format in Excel 2007, xls)
End Sub
Private Sub EmailIt()
'** Choose Email Program Method **
Dim sTo As String, sCC As String, sSubject As String, sBody As String
sTo = [D9]
sCC = [D8]
sSubject = " electronic leave request"
sBody = "I approve this" & sSubject _
& " for the dates submitted"
Call EmailWithOutlook(sTo, sCC, sSubject, sBody)
End Sub
Private Sub EmailWithOutlook(sTo As String, sCC As String _
, sSubject As String, sBody As String)
Dim oOutlookApp As Object, oItem As Object
Dim bStarted As Boolean
'** see if Outlook is running and if so turn your attention there **
On Error GoTo StartOutlook
Set oOutlookApp = GetObject(, "Outlook.Application")
GoTo skip
StartOutlook:
Resume ResetErrorHandling
ResetErrorHandling:
On Error GoTo ErrSendMessageManually
Set oOutlookApp = CreateObject("Outlook.Application")
bStarted = True
skip:
'** Open a new e-mail message **
Set oItem = oOutlookApp.CreateItem(0) '** zero 0 = olMailItem **
With oItem 'and add the detail to it
.To = sTo
.cc = sCC
.Subject = sSubject
.body = sBody
.Attachments.Add ActiveWorkbook.FullName
'.display
.SEND
End With
MsgBox Title:="FYI" _
, prompt:="Leave approval email sent" _
, Buttons:=vbInformation
'** If the macro started Outlook, stop it again. **
If bStarted Then oOutlookApp.Quit
'** Clean up **
Set oItem = Nothing
Set oOutlookApp = Nothing
Exit Sub
ErrSendMessageManually:
UserForm_ManuallySendMsg.Show
End Sub
I have been given a macro to fix for my boss who thinks he deleted something by mistake but can't for the life of me find out what the problem is.
I have stepped through it (the spreadsheet is a leave request form which automatically generates messages and a email to approvers folllowing completion) and the problem seems to be at the top of the code but any further thoughts would be most welcome as it's doing my head in!
Many thanks in advance!
J
---
Full code:
Option Explicit '** means all variables must be properly declared with dim ... **
'***********************************************************
Public Declare Function GetUserName Lib "advapi32.dll" _
Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function GetLongPathName Lib "kernel32.dll" Alias "GetLongPathNameA" _
(ByVal lpszShortPath As String, ByVal lpszLongPath As String, ByVal cchBuffer As Long) As Long
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" _
(ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
'***********************************************************
Const Default_FN = "Expenses Claim Form (email)"
'***********************************************************
'** Reads the WINDOWS Login Identity **
'***********************************************************
Public Function ReturnUserName() As String
Dim rString As String * 255, sLen As Long, tString As String
tString = ""
On Error Resume Next
sLen = GetUserName(rString, 255)
sLen = InStr(1, rString, Chr(0))
If sLen > 0 Then
tString = Left(rString, sLen - 1)
Else
tString = rString
End If
On Error GoTo 0
ReturnUserName = UCase(Trim(tString))
End Function
'***************************************************************************************
'** This function uses Windows API GetTempPath to get the temporary folder **
'** It then converts the returned "short path" or dos8.3 path with ~ into a long path **
'***************************************************************************************
Private Function TempFldrPath()
Dim sShortPath As String, sLongPath As String
Dim l As Long
sShortPath = String(255, vbNullChar) '** pads out a 255 character string **
sLongPath = String(255, vbNullChar) '** pads out a 255 character string **
l = GetTempPath(255, sShortPath)
If l = 0 Then
TempFldrPath = vbNullString
Else
sShortPath = Left(sShortPath, l)
l = GetLongPathName(sShortPath, sLongPath, 255)
TempFldrPath = Left$(sLongPath, l)
End If
End Function
'** to test above function **
Sub Get_Temporary_Folder()
Debug.Print TempFldrPath
End Sub
Private Sub Wholeapprovalmacro()
Dim iAns As Integer
Application.DisplayAlerts = False
' iAns = MsgBox(prompt:= _
' "Are you sure you want to approve?" & vbCr _
' & "Answering yes automatically sends an email from you approving the request." & vbCr _
' & vbCr _
' & "(NB: This file is attached to the message, and a copy is saved in your sent items)" _
' , Title:="APPROVE AND EMAIL THE HOLIDAY FORM" _
' , Buttons:=vbYesNo)
' iAns = MsgBox(Title:="APPROVE AND SUBMIT LEAVE DATES" _
' prompt:="PLEASE ENSURE" & vbCr _
' & "- You have checked the dates and want to approve it" & vbCr _
' & "- You have the authority to do so" _
' & vbCr & vbCr _
' & "PLEASE NOTE" & vbCr _
' & "- Clicking 'OK' will save this file and submit the claim by email." & vbCr _
' & "- A copy will be saved in your email program's SENT folder." & vbCr _
' & vbCr _
' & "Continue?" _
' , Buttons:=vbOKCancel)
If iAns = vbOK Then Run "TestFile"
If iAns = vbCancel Then Run "CancelSend"
Application.DisplayAlerts = True
End Sub
Private Sub TestFile()
Dim sFileStatus As String
Dim sTempDir As String
Dim iAns As Integer
sTempDir = TempFldrPath
'** SAVED - A file saved in a folder (ie not a temp folder )**
'** New - file is 'new' created from a template (eg filename.xlt) **
'** Tmp - file is saved in a temp folder as it was likely opened from an email message **
If ThisWorkbook.Path = "" Then
sFileStatus = "new and unsaved"
ElseIf sTempDir = Left(ThisWorkbook.Path, Len(sTempDir)) _
Or InStr(ThisWorkbook.Path, "Temporary Internet Files") <> 0 Then
sFileStatus = "only temporarily saved"
Else: sFileStatus = "saved"
End If
'** Tmp or New **
If sFileStatus <> "saved" Then
iAns = MsgBox(Title:="SAVE A COPY OF THIS FILE?", prompt:="" _
& "A copy of the expense claim will be saved in your email program's SENT folder. However, " & vbCr _
& "this file is currently " & sFileStatus & vbCr _
& vbCr _
& "Do you also want to save a second copy on your C:\ drive or the network (eg S:\ drive)?" & vbCr _
, Buttons:=vbYesNoCancel)
End If
If iAns = vbCancel Then Run "CancelSend"
If iAns = vbYes Then Run "GetSaveAsFN"
If iAns = vbNo And sFileStatus = "new and unsaved" Then
ThisWorkbook.SaveAs TempFldrPath & ThisWorkbook.Name
Else: ThisWorkbook.Save
End If
Run "EmailIt"
End Sub
Private Sub CancelSend()
MsgBox Title:="FYI" _
, prompt:="File NOT saved and expense claim NOT submitted." _
, Buttons:=vbOKOnly + vbCritical
End
End Sub
Private Sub GetSaveAsFn()
Dim sFN As String, sExtn As String, iExtn As Integer
Dim sFldr As String
sFldr = Application.DefaultFilePath
If sFldr = "" Then sFldr = "c:\"
ChDir sFldr
ChDrive sFldr
sFN = Default_FN & " - " & ReturnUserName & " " & Replace(Fix(Now()), "/", "-") & ".xls"
sFN = Application.GetSaveAsFilename(InitialFileName:=sFN _
, FileFilter:="Excel 97-03 , *.xls, Excel 07 binary, *.xlsb, Excel 07 macro, *.xlsm" _
, FilterIndex:=1 _
, Title:="Choose a Filename and Save")
If sFN = "False" Then Run "CancelSend"
sExtn = Right(sFN, InStr(StrReverse(sFN), "."))
Select Case sExtn
Case ".xls": iExtn = 56
Case ".xlsb": iExtn = 50
Case ".xlsm": iExtn = 52
End Select
ThisWorkbook.SaveAs Filename:=sFN, FileFormat:=iExtn
'50 = xlExcel12 (Excel Binary Workbook in 2007 with or without macro’s, xlsb)
'51 = xlOpenXMLWorkbook (without macro's in 2007, xlsx)
'52 = xlOpenXMLWorkbookMacroEnabled (with or without macro's in 2007, xlsm)
'56 = xlExcel8 (97-2003 format in Excel 2007, xls)
End Sub
Private Sub EmailIt()
'** Choose Email Program Method **
Dim sTo As String, sCC As String, sSubject As String, sBody As String
sTo = [D9]
sCC = [D8]
sSubject = " electronic leave request"
sBody = "I approve this" & sSubject _
& " for the dates submitted"
Call EmailWithOutlook(sTo, sCC, sSubject, sBody)
End Sub
Private Sub EmailWithOutlook(sTo As String, sCC As String _
, sSubject As String, sBody As String)
Dim oOutlookApp As Object, oItem As Object
Dim bStarted As Boolean
'** see if Outlook is running and if so turn your attention there **
On Error GoTo StartOutlook
Set oOutlookApp = GetObject(, "Outlook.Application")
GoTo skip
StartOutlook:
Resume ResetErrorHandling
ResetErrorHandling:
On Error GoTo ErrSendMessageManually
Set oOutlookApp = CreateObject("Outlook.Application")
bStarted = True
skip:
'** Open a new e-mail message **
Set oItem = oOutlookApp.CreateItem(0) '** zero 0 = olMailItem **
With oItem 'and add the detail to it
.To = sTo
.cc = sCC
.Subject = sSubject
.body = sBody
.Attachments.Add ActiveWorkbook.FullName
'.display
.SEND
End With
MsgBox Title:="FYI" _
, prompt:="Leave approval email sent" _
, Buttons:=vbInformation
'** If the macro started Outlook, stop it again. **
If bStarted Then oOutlookApp.Quit
'** Clean up **
Set oItem = Nothing
Set oOutlookApp = Nothing
Exit Sub
ErrSendMessageManually:
UserForm_ManuallySendMsg.Show
End Sub
