Private Sub Workbook_Open() ' Written by Authors ' Last updated 02/23/2011 ' Open a Message Box informing the user that they MUST save the workbook before use. MsgBox ("This workbook MUST be saved to the I: drive before use.") Dim Show_Box As Boolean Dim Response As Variant ' Set the Show_Dialog variable to True. Show_Box = True ' Begin While loop. While Show_Box = True ' Show the Save File Instructions Input Bbox. Response = InputBox("User Instructions", _ "Save File Formatting Instructions") ' Check to ensure the user entered a file name. If Response = "" Then Else ' Test to make sure an entry was made. If Response <> "" Then ' Set the path on the I: drive to save the file to MyPath = "Specified Path" ' Set the format of the saved file as a macro-enabled workbook ActiveWorkbook.SaveAs Filename:=MyPath & "" & Response, FileFormat:=51 Show_Box = False Else End If End If ' End the While loop. Wend End SubI know the FileFormat should be set to 52 for a macro-enable workbook, but I have it set to 51 for now because if the saved file is macro-enabled (as I need it to be), when it is opened later it will run the macro again asking for a file name. There are other macros I plan to insert into the template workbook for use in the saved macro-enabled workbook, so I need to disable the macro above once the new workbook is saved.
VB: Sub Save_as_new_workbook() '\\\\\\\\\\\ ' ********* SAVE AS A NEW WORKBOOK ************* '/////////////////////////////////////////////// Dim C As String, directory As String Windows(MasterFileName).Activate sheets("Save").Select C = Range("d2").Value directory = Range("A2") ActiveWorkbook.SaveAs Filename:=directory & C & ".xls", _ FileFormat:=xlNormal, Password:="", WriteResPassword:="", _ ReadOnlyRecommended:=False, CreateBackup:=False End Sub If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
Sub cmdSaveReport_Click() Application.ScreenUpdating = False ActiveSheet.Select ActiveSheet.Copy ActiveSheet.Range("Type_Of_Call").Select ThisFile = Range("FileName").Value 'ActiveSheet.SaveAs Filename:="upstairsshareddocsIncident Reports2010 Incident Reports" & ThisFile & ".xls" ActiveSheet.SaveAs Filename:="C:UsersUserDocumentsFire Departmentdummy reports" & ThisFile & ".xls" Application.ScreenUpdating = True ActiveWorkbook.Close 'Call RemoveRequestNumber End SubI am using excel 2007 but in compatability mode, (since the computer that the end users work with are all 2003). The file I am working on is a .xls file and I am saving it as the same.
VB: Sub SaveButton_Click() If Range("e3") > 0 Then MsgBox "Please Specify A file Name and/or Superintendent", vbOKOnly, "Warning!" Range("b4").Select Else Dim sfile As String Dim uname sfile = Range("B4").Value & ".xlsm" uname = Range("H4").Value ActiveWorkbook.Save ActiveWorkbook.SaveAs Filename:="S:Proposal Worksheets2011 Worksheets" & uname & "" & sfile End If End Sub If you like these VB formatting tags please consider sponsoring the author in support of injured Royal MarinesI am trying to also think ahead as I know we still have some users on 2003 Excel, so I am not sure how this will affect them (when trying to save a document as xlsm) and I also wouldn't mind adding code to automatically create a subfolder in the directory for the initials that the user inputs. Any help would be greatly appreciated!
1. Code in the ThisWorkbook module: Private Sub Workbook_Open() 'Runs a macro at 4:00 PM Application.OnTime TimeValue("16:00:00"), "Sample_Macro_Name()” End Sub 2. Then in a regular module the code: Sub Sample_Macro_Name() [Macro code goes here] End SubFolks, I appreciate your wise guidance.
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) Dim varFileName As Variant If SaveAsUI = True Then Cancel = True Application.EnableEvents = False varFileName = Application.GetSaveAsFilename("somefilename.xlsm", " Excel Macro Enabled Workbook (*.xlsm), *.xlsm,", 2) If varFileName = vbFalse Then Cancel = True Else Me.SaveAs varFileName, 52 End If Application.EnableEvents = True End If End Sub
VB: Function RangetoHTML(rng As Range) ' Changed by Ron de Bruin 28-Oct-2006 ' Working in Office 2000-2010 Dim fso As Object Dim ts As Object Dim TempFile As String Dim TempWB As Workbook TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm" 'Copy the range and create a new workbook to past the data in Application.DisplayAlerts = False rng.Copy [B]Set TempWB = Workbooks.Add(template:="[URL="file://dartgroup.plcdata1Jet2FlightOperationsJet2FltOpsEFBChange"]dartgroup.plcdata1Jet2FlightOperationsJet2FltOpsEFBChange[/URL] RequestsChangeTemplate.xltm") [/B] With TempWB.Worksheets("Sheet1") .Cells(2, 1).PasteSpecial Paste:=8 .Cells(2, 1).PasteSpecial xlPasteValues, , False, False .Cells(2, 1).PasteSpecial xlPasteFormats, True, False, False .Cells(2, 1).Select Application.CutCopyMode = False On Error Resume Next .DrawingObjects.Visible = True .DrawingObjects.Delete On Error Goto 0 End With Application.DisplayAlerts = True 'Publish the sheet to a htm file With TempWB.PublishObjects.Add( _ SourceType:=xlSourceRange, _ Filename:=TempFile, _ Sheet:=TempWB.Worksheets("Sheet1").Name, _ Source:=TempWB.Worksheets("Sheet1").UsedRange.Address, _ HtmlType:=xlHtmlStatic) .Publish (True) End With 'Read all data from the htm file into RangetoHTML Set fso = CreateObject("Scripting.FileSystemObject") Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2) RangetoHTML = ts.ReadAll ts.Close RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _ "align=left x:publishsource=") 'Define the unique file name and save the document in the user's folder. Dim TempSaveAs As String TempSaveAs = "[URL="file://dartgroup.plc/data1/Jet2FlightOperations/Jet2FltOps/EFB/Change"]dartgroup.plcdata1Jet2FlightOperationsJet2FltOpsEFBChange[/URL] Requests" & Me.txtcvalue.Value & "" & "EFB" & Me.txtConfigNo.Value & " " & Me.txtTitle.Value TempWB.SaveAs (TempSaveAs) TempWB.Close 'Delete the htm file we used in this function Kill TempFile Set ts = Nothing Set fso = Nothing Set TempWB = Nothing End Function If you like these VB formatting tags please consider sponsoring the author in support of injured Royal MarinesI have changed a few bits and pieces from Ron de Bruin's original code, but it is using the template (in bold) which has caused it to stop working. The debugger doesn't highlight any lines, it just doesn't populate the body of the email.
VB: Dim OutApp As Object Dim OutMail As Object Dim cell As Range Dim rng As Range Dim CellRng As Range Dim cvalue As String Dim TempHyperlink As String Application.ScreenUpdating = False Set OutApp = CreateObject("Outlook.Application") Set rng = TempSheet.Rows("1:16") With ThisWorkbook.Worksheets("Log") Set CellRng = .Range(.Cells(iRow, 6), .Cells(iRow, 26)) End With On Error Goto cleanup For Each cell In CellRng If cell.Value Like "?*@?*.?*" Then txtcvalue.Value = Left(cell.Value, WorksheetFunction.Search("@", cell.Value, 1) - 1) TempHyperlink = "[URL="file://dartgroup.plcdata1Jet2FlightOperationsJet2FltOpsEFBChange"]dartgroup.plcdata1Jet2FlightOperationsJet2FltOpsEFBChange[/URL] Requests" & Me.txtcvalue.Value Set OutMail = OutApp.CreateItem(0) On Error Resume Next With OutMail .To = cell.Value & vbNewLine .Subject = Me.txtTitle.Value .ToDoTaskOrdinal = DeadlineDate .TaskDueDate = DeadlineDate .TaskStartDate = Me.txtIssueDate.Value .FlagStatus = 2 .FlagRequest = strFlagRequest .FlagIcon = 6 .HTMLBody = EmailContent & " Record - Please complete the relevant Department Specific Information Fields " & RangetoHTML(rng) & "Thanks,
" & "
" & "
" & "Should you require further information regarding the Change Request prior to providing this feedback, please see" & Me.txtOriginator.Value & " prior to the deadline." .Send End With On Error Goto 0 Set OutMail = Nothing End If Next cell cleanup: Set OutApp = Nothing If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines