Hi all,
I'm having an issue when attempting to generate an email with a link to a file that is generated within the same macro.
I'm trying to make it so that specific people will receive the email and then will be able to open the link without error.
I've include the script below;
I'm having an issue when attempting to generate an email with a link to a file that is generated within the same macro.
I'm trying to make it so that specific people will receive the email and then will be able to open the link without error.
I've include the script below;
VBA Code:
Sub SuperCB_Click()
'Search last row last row in all sheets
Dim Answer As String
Answer = InputBox("What's the password?", "Password")
If Answer = "smt1234" Then
Dim WSheet As Worksheet
Dim lastRow As Long
Dim oWbLog As Workbook
Dim oWsDue As Worksheet
Dim iStatus As Long
Application.ScreenUpdating = False
Dim Found As Boolean
Dim InxWbk As Long
Dim MasterList As Workbook
Found = False
For InxWbk = 1 To Workbooks.Count
If Workbooks(InxWbk).Name = "Book1.xlsm" Then
Set MasterList = Workbooks(InxWbk)
Found = True
Exit For
End If
Next
If Not Found Then
Set MasterList = Workbooks.Open(ThisWorkbook.Path & "\Book1.xlsm")
End If
Set oWsDue = Workbooks.Add.Sheets(1)
Application.DisplayAlerts = False
oWsDue.Parent.SaveAs ("F:\HLA\Torque System\Due.xls")
Application.DisplayAlerts = True
Workbooks("Book1.xlsm").Activate
For Each WSheet In Worksheets
With WSheet
lastRow = .Range("A" & Rows.Count).End(xlUp).row
If .Range("J" & lastRow).Value = "<>" Then
ElseIf .Range("A" & lastRow).Value < Date Then
Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim lCopyLastRow As Long
Dim lastCol As Long
Dim lDestLastRow As Long
Set wsCopy = WSheet
Set wsDest = Workbooks("Due.xls").Worksheets("Sheet1")
lCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, 1).End(xlUp).row
lastCol = wsCopy.Cells(2, wsCopy.Columns.Count).End(xlToLeft).Column
lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).row
With wsCopy
.Range(.Cells(1, 1), .Cells(lCopyLastRow, lastCol)).Copy wsDest.Range("A" & lDestLastRow)
End With
End If
End With
Next WSheet
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
If ActiveWorkbook.Path <> "" Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "!!!THIS IS A TEST!!!<br><br><br>""Please use the following link to access the" & " " & _
ActiveWorkbook.Name & "</B> spreadsheet document.<br>" & _
"Review past due torque verifications by employee number.<br>" & _
"Click on this link to open the file : " & _
"<A HREF=""F:/HLA/Torque System/Due.xls"">Link to the file</A><br><br>" & _
"Please update all past due torques.<br>" & _
"<br><br>Thank you."
On Error Resume Next
With OutMail
.To = "dans@teamsmt.local"
.Subject = "Overdue Torque Calibration" & " - " & Date
.HTMLBody = strbody
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Else
MsgBox "The ActiveWorkbook does not have a path, Save the file first."
End If
Workbooks("due.xls").Worksheets("sheet1").Activate
Workbooks("due.xls").Worksheets("sheet1").Columns("A:K").AutoFit
Workbooks("due.xls").Save
Else: MsgBox "Wrong password", vbCritical + vbOKCancel, "Incorrect Password"
End If
End Sub