I have made comments where I would like things to happen in red.
Option Explicit
Private Sub Workbook_Open()
<<<<<<<<I need this code to run if spreadsheet name = SSR.xls>>>>>>>>>>> If it is named something different then move on
Dim x As String
On Error GoTo ErrorHandler
One:
Open "\\servername\share\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 "\\servername\share\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 '\\servername\share\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 Workbook_Open1()
'disables save and saves in menu
Application.CommandBars("Worksheet Menu Bar").Controls("File").Controls("Save As...").Enabled = False
Application.CommandBars("Worksheet Menu Bar").Controls("File").Controls("Save").Enabled = False
End Sub
'Disable Save and SaveAs
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
If SaveAsUI Then
MsgBox "The 'Save As' function has been disabled." & Chr(10) & "Only 'Save' will work.", vbInformation, "Save As Disabled"
Cancel = True
End If
<<<<<<<I need this to be work as a submit button. The submit button should email and save document. This all works if I just run the code but not as a submit button.>>>>>>>
Dim SaveName As String
SaveName = ActiveSheet.Range("A1").Text
ActiveWorkbook.SaveAs Filename:="\\servername\share\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
Bookmarks