Below is the code that I have.
Option Explicit
'Disable Save and SaveAs
Dim flg As Boolean
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
If flg Then MsgBox "The 'Save and Save As' function has been disabled." & Chr(10) & "Only 'Submit Button' will work.", vbInformation, "Save and Save As Disabled"
Cancel = True
End Sub
Private Sub Workbook_Open()
flg = True
Dim x As String
If Me.Name <> "SSR.xls" Then Exit Sub
On Error GoTo ErrorHandler
One:
Open "\\server\sharename\Forms\" & ThisWorkbook.Name & _
" Counter.txt" For Input As #1
Input #1, x
Close #1
x = x + 1
Two:
'******THIS LINE IS OPTIONAL******
Sheets(1).Range("A1").Value = x
'********************************
Open "\\server\sharename\Forms\" & ThisWorkbook.Name & _
" Counter.txt" For Output As #1
Write #1, x
Close #1
Exit Sub
ErrorHandler:
Select Case Err.Number
Case 53 'If Counter file does not exist...
NumberRequired:
x = InputBox("Enter a Number greater than " & _
"zero to Begin Counting With", _
"Create '\\server\sharename\Forms\" & ThisWorkbook.Name & _
" Counter.txt' File")
If Not IsNumeric(x) Then GoTo NumberRequired
If x <= 0 Then GoTo NumberRequired
Resume Two
Case Else
Resume Next
End Select
End Sub
Private Sub CommandButton1_Click()
Sub Save_File()
Dim SaveName As String
SaveName = ActiveSheet.Range("A1").Text
ActiveWorkbook.SaveAs Filename:="\\server\sharename\forms\" & _
SaveName & ".xls"
End Sub
'Will Email Document
Sub SendMail1()
'need a reference to MS Outlook object library
Dim olFolder As Outlook.MAPIFolder
Dim olMailItem As Outlook.MailItem
Dim olContact As Outlook.Recipient
Dim r, ToContact
Set olFolder = GetObject("", _
"Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
For r = 1 To LastRow(ActiveSheet)
If Trim(ActiveSheet.Cells(r, 1)) <> "" Then
Set olMailItem = olFolder.Items.Add ' creates a new e-mail message
With olMailItem
.Subject = "KCI SSR has been created file link enclosed" ' message subject
Set olContact = .Recipients.Add(ActiveSheet.Cells(2, 1)) ' add To recip
If Trim(ActiveSheet.Cells(r, 2)) <> "" Then 'set up cc if email address available
Set olContact = .Recipients.Add(ActiveSheet.Cells(r, 2)) ' add cc recipient
olContact.Type = olCC ' set latest recipient as CC
End If
.Body = " SSR has been created to view/edit please click following link " & ActiveSheet.Cells(1, 3) & vbCrLf & vbCrLf & "Regards" & vbCrLf & "IT"
.Send ' sends the e-mail message (puts it in the Outbox)
End With
Set ToContact = Nothing
Set olMailItem = Nothing
End If
Next r
Set olFolder = Nothing
End Sub
Function LastRow(ws As Worksheet) As Single
'uses worksheet object
'returns last used row
On Error Resume Next
With ws
LastRow = .Cells.Find(What:="*", _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByRows).Row
End With
End Function
End Sub
Bookmarks