Excel VBA save file as word document in default folder - excel

Sub Submit_Click()
Dim wApp As Object
Dim wDoc As Object
Set wApp = CreateObject("Word.Application")
wApp.Visible = True
'Retrieves the word doc template and inserts values from the userform using bookmarks
Set wDoc = wApp.Documents.Open(Filename:="C:\Users\Documents\template1.docx ", ReadOnly:=False)
With wDoc
.Bookmarks("bookmark1").Range.Text = Me.TextBox1.Value
.Bookmarks("bookmark2").Range.Text = Me.TextBox3.Value
.Bookmarks("bookmark3").Range.Text = Me.TextBox4.Value
.Bookmarks("bookmark4").Range.Text = Me.TextBox5.Value
'set the default filename
ProposedFileName = Format(Now(), "DD-MMM-YYYY") & "Serial Number" & " " & TextBox1.Value _
& " " & TextBox2.Value & "- RMA" & ".docx"
'trying to save file back to .doc instead of the default .xlms format
Set fd = Application.FileDialog(msoFileDialogSaveAs)
With fd
.FilterIndex = 2
.InitialFileName = ProposedFileName
If .Show Then
ActiveDocument.SaveAs2 Filename:=.SelectedItems(1), _
FileFormat:=wdFormatDocumentDefault
Else
Call CommandButton4_Click 'cancel save
End If
End With
Set fd = Nothing
End Sub
Hi all,
My script above is only a partial one that is taken from my userform. Basicall the scenario is my userform opens a word document template and inserts texts in the document from the excel userform using bookmarks.
After I click submit on the userform, the filedialog opens with the default .xlms and does not allow me to save it back to .doc
I have been searching and modifying my script for ages and cannot seem to get it right. I would appreciate if someone can tell me how. Thank you.
Regards,
Kev

Private Sub SubmitButton_Click()
'set default file name and file path
ProposedFileName = Format(Now(), "DDMMMYYYY") & " " & TextBox1.Value & "-" & TextBox2.Value & ".doc"
ProposedFilePath = "C:\Users\"
'save the word document called by excel to a .doc format
With wApp.FileDialog(msoFileDialogSaveAs)
wDoc.SaveAs2 ProposedFilePath & ProposedFileName, _
FilterIndex = 1, _
FileFormat:=wdFormatDocument
End With
'unloads the userforms and .doc file after the document is saved
Unload Me
wApp.Quit
'a dialog box pops up after document is saved to say where the file is saved since I was't unable to implement the browse folder option
MsgBox "The document is saved in " & ProposedFilePath, vbOKOnly
Cancel = False
Exit Sub
End Sub
Hi All,
Thank you for the help. I have managed to solve my problem with the above code but unfortunately could not do it with the browse location dialog box. I hope this will become useful for everyone who needs it.
However, if anyone knows how to implement the browse folder location with this code will be better and useful for others.

Related

Button to show Save As dialog, then save to a set location

I've been stuck on this for some time now, help would be greatly appreciated.
I've got this concept working when the workbook is closed, but all it does is save to the location specified. Now, I would like to adapt it so once a button is pressed, it will ask the user to save to a location, then once saved, excel will save it to another location of my choosing.
I keep getting an error message "Argument not optional" when the button is pressed.
Thank you.
Private Sub Save(Cancel As Boolean)
NameOfWorkbook = Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".", -1, vbTextCompare) - 1))
Dim varResult As Variant
'displays the save file dialog
varResult = Application.GetSaveAsFilename
'checks to make sure the user hasn't canceled the dialog
If varResult <> False Then
Cells(2, 1) = varResult
MyMsg = NameOfWorkbook + " " & "saved to return note folder"
MsgBox MyMsg
'Create and assign variables
Dim saveLocation As String
saveLocation = "S:\Office information\Returns\Return Notes\" + NameOfWorkbook
'Save Active Sheet(s) as PDF
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=saveLocation
End If
End Sub
You dont use the sub argument so, as Siddharth pointed out, you should correct Private Sub Save().
Furthermore, Save is a reserved word in excel, so I wouldn't use it as a Sub name.

VBA: SaveCopyAs Method Outputting Cannot Find File Error

I'm modifying a Gantt chart excel template I found online by Vertex42 for added functionality.
One of these modifications is a checkbox inside a sheet called "Config" that, when ticked, creates a backup of the Gantt chart whenever the document is opened.
For some reason, I cannot get this simple task to work.
I've tried using both the Form control and ActiveX control check boxes, with different error messages. As far as I can tell, the Form controls are unrecommended, so I'm using the code below in the ThisWorkbook excel object, based on what I've seen online.
Private Sub Workbook_open()
Dim backupFilename As String
Dim formattedDateTime As String
If Sheets("Config").OLEObjects("AutoBackupCheckbox").Object.Value = True Then
formattedDateTime = Format(Now, "d-MMMM-yyyy, h:mm:ss")
backupfilename = Replace(ActiveWorkbook.Name, ".xlsm", " - backup " & DateTime & ".xlsm")
ActiveWorkbook.SaveCopyAs (backupfilename)
End If
End Sub
This code is getting me the error message whenever I open the document or run the debugger,
Run-time error '1004':
Sorry, we couldn't find the <filename> - backup <day>-<month>-<year>, <hour>:<minute>:<seconds>.xlsm. Is it possible it was moved, renamed or deleted?
Any ideas?
UPDATE: After running the debugger, it's complaining on the ActiveWorkbook.SaveAs line.
UPDATE 2: Changed format of 'backupFilename' to remove the '.xlsm' in the middle.
UPDATE 3: Replaced Date with date/time without slashes, and replaced SaveAs with SaveCopyAs. Updated error message.
The argument for the SaveCopyAs call is missing the path of the file.
Replace code with
Private Sub Workbook_open()
Dim backupFilename As String
Dim formattedDate As String
Dim tempFilename As String
Dim workingPath As String
Dim i As Integer
i = 1
If Sheets("Config").OLEObjects("AutoBackupCheckbox").Object.Value = True Then
formattedDate = Format(Date, "d-MMMM-yyyy, ver " & i)
workingPath = Application.ActiveWorkbook.FullName
backupFilename = Replace(workingPath, ".xlsm", " - backup " & formattedDate & ".xlsm")
tempFilename = Dir(backupFilename)
While tempFilename <> "" ' if file already exists
i = i + 1
formattedDate = Format(Date, "d-MMMM-yyyy, ver " & i)
backupFilename = Replace(workingPath, ".xlsm", " - backup " & formattedDate & ".xlsm")
tempFilename = Dir(backupFilename)
Wend
ActiveWorkbook.SaveCopyAs (backupFilename)
End If
End Sub

How to rename a word document according to a mail merge attribute in VBA?

The title may be a bit gory, but here we are.
Currently I've got a word document that uses mail merge to insert two attributes from an Excel sheet (date and name). Once the merge is generated, I then have a macro to split each page of the resultant document into it's own separate document. The macro I'm using is just copied and pasted from VBA Express here, seen below.
Sub SplitIntoPages()
Dim docMultiple As Document
Dim docSingle As Document
Dim rngPage As Range
Dim iCurrentPage As Integer
Dim iPageCount As Integer
Dim strNewFileName As String
Application.ScreenUpdating = False 'Makes the code run faster and reduces screen _
flicker a bit.
Set docMultiple = ActiveDocument 'Work on the active document _
(the one currently containing the Selection)
Set rngPage = docMultiple.Range 'instantiate the range object
iCurrentPage = 1
'get the document's page count
iPageCount = docMultiple.Content.ComputeStatistics(wdStatisticPages)
Do Until iCurrentPage > iPageCount
If iCurrentPage = iPageCount Then
rngPage.End = ActiveDocument.Range.End 'last page (there won't be a next page)
Else
'Find the beginning of the next page
'Must use the Selection object. The Range.Goto method will not work on a page
Selection.GoTo wdGoToPage, wdGoToAbsolute, iCurrentPage + 1
'Set the end of the range to the point between the pages
rngPage.End = Selection.Start
End If
rngPage.Copy 'copy the page into the Windows clipboard
Set docSingle = Documents.Add 'create a new document
docSingle.Range.Paste 'paste the clipboard contents to the new document
'remove any manual page break to prevent a second blank
docSingle.Range.Find.Execute Findtext:="^m", ReplaceWith:=""
'build a new sequentially-numbered file name based on the original multi-paged file name and path
strNewFileName = Replace(docMultiple.FullName, ".doc", "_" & Right$("000" & iCurrentPage, 4) & ".doc")
docSingle.SaveAs strNewFileName 'save the new single-paged document
iCurrentPage = iCurrentPage + 1 'move to the next page
docSingle.Close 'close the new document
rngPage.Collapse wdCollapseEnd 'go to the next page
Loop 'go to the top of the do loop
Application.ScreenUpdating = True 'restore the screen updating
'Destroy the objects.
Set docMultiple = Nothing
Set docSingle = Nothing
Set rngPage = Nothing
End Sub
However, there are over 90 pages of the mail merge and, as seen in the code above, they are all named by just adding numbers to the end of the file name. Instead of this, I would like to have it so that it would read the merged Date attribute from each page and use that as the file name instead. I've tried tinkering around with the code and reading up about it on the MS Dev Centre, but I've had no luck.
Can anyone help? Thanks.
A far better approach is to create the separate documents from the outset. By adding the following macro to your mailmerge main document, you can generate one output file per record. Files are saved to the same folder as the mailmerge main document, using the 'Date' field in the data source for the filenames. PDF & DOCX output formats are catered for. Do be aware that, should your data source have duplicate dates, only the last one processed will survive.
Sub Merge_To_Individual_Files()
'Merges one record at a time to the folder containing the mailmerge main document.
' Sourced from: http://www.msofficeforums.com/mail-merge/21803-mailmerge-tips-tricks.html
Application.ScreenUpdating = False
Dim StrFolder As String, StrName As String, MainDoc As Document, i As Long, j As Long
Set MainDoc = ActiveDocument
With MainDoc
StrFolder = .Path & Application.PathSeparator
For i = 1 To .MailMerge.DataSource.RecordCount
With .MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = i
.LastRecord = i
.ActiveRecord = i
If Trim(.DataFields("Date")) = "" Then Exit For
StrName = Format(.DataFields("Date"), "YYYY-MM-DD")
End With
.Execute Pause:=False
If Err.Number = 5631 Then
Err.Clear
GoTo NextRecord
End If
End With
With ActiveDocument
.SaveAs FileName:=StrFolder & StrName & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
' and/or:
.SaveAs FileName:=StrFolder & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
.Close SaveChanges:=False
End With
NextRecord:
Next i
End With
Application.ScreenUpdating = True
End Sub
Note 1: The above code defaults to saving the output to the mailmerge main document's folder. You can change the destination folder by editing:
StrFolder = .Path & Application.PathSeparator
Note 2: If you rename the above macro as 'MailMergeToDoc', clicking on the 'Edit Individual Documents' button will intercept the merge and the process will run automatically. The potential disadvantage of intercepting the 'Edit Individual Documents' process this way is that you no longer get to choose which records to merge at that stage. However, you can still achieve the same outcome - and with greater control - via the 'Edit Recipient List' tools.

relocate a dynamic file in VBA

I am trying to have an user select a file and choose a to upload to another location ( like a shared drive). I am using the name function but I realized I am having trouble getting the file name and put into the "toPath" since it is up to the user. Below is my completed code and please any advice or suggestions would help.
At the same time, I hope my codes may help someone is trying to do the samething. Thanks
To Pick a file to upload:
Private Sub Command2_Click()
Dim fDialog As Variant
' Clear listbox contents. '
Me.Path1.Value = ""
' Set up the File Dialog. '
Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
With fDialog
' Allow user to make multiple selections in dialog box '
.AllowMultiSelect = False
' Set the title of the dialog box. '
.Title = "Please select one file"
' Clear out the current filters, and add our own.'
.Filters.Clear
.Filters.Add "All Files", "*.*"
' Show the dialog box. If the .Show method returns True, the '
' user picked at least one file. If the .Show method returns '
' False, the user clicked Cancel. '
If .Show = True Then
'add selected path to text box
Me.Path1.Value = .SelectedItems(1)
Else
MsgBox "No File Selected."
End If
End With
End Sub
To Pick a upload path to upload the file:
Private Sub Command10_Click()
Dim FromPath As String
Dim ToPath As String
Dim fDialog2 As Variant
' Clear listbox contents. '
Me.Path2.Value = ""
FromPath = Me.Path1
ToPath = Me.Path2
' Set up the File Dialog. '
Set fDialog2 = Application.FileDialog(msoFileDialogFolderPicker)
With fDialog2
If .Show = True Then
'add selected path to text box
Me.Path2.Value = .SelectedItems(1)
Else
MsgBox "No file uploaded."
End If
End With
Name FromPath As ToPath & "\" & 'ummmmmmmmmmm I am stucked :(
MsgBox "You can find the files and subfolders from " & FromPath & " in " & ToPath
End Sub
Refactor the end of Command10_Click as shown below. User can pick new file name.
....
End With
Dim ToName as String
ToName = InputBox("Please Enter New File Name","New File Name")
Name FromPath As ToPath & "\" & ToName
....
I am not sure which file types you are relocating, but you can grab the extension type from FromPath and add to end of ToName

How to get VBA excel addin .xlam to replace itself by a remote updated .xlam?

I need some way to update an excel addin shared among my staffs so as everyone don't have to download & install it manually.
I have googled and see that we can write file to the OS file system so the task ends up with writing the new-version addin, i.e. the .xlam file, to overwrite itself.
I have no idea on how to do this. If you do have ones, please share! Thank you!
I don't know if there's a less crude way of doing it, but I have "hacked" a solution that involves SendKeys. Yuck, I know. Hopefully someone else will have a better solution.
As I recall, you need to uninstall an addin before you can overwrite the .xla(m) file and I couldn't find a way to do this purely using built-in objects.
The code below basically uninstalls the add-in, invokes the "Add-ins" dialog box and uses SendKeys to remove it from the list, before copying the new file and reinstalling the add-in.
Amend it for your circumstances - it will depend on your users having their security settings low enough to let it run, of course.
Sub UpdateAddIn()
Dim fs As Object
Dim Profile As String
If Workbooks.Count = 0 Then Workbooks.Add
Profile = Environ("userprofile")
Set fs = CreateObject("Scripting.FileSystemObject")
AddIns("MyAddIn").Installed = False
Call ClearAddinList
fs.CopyFile "\\SourceOfLatestAddIn\MyAddIn.xla", Profile & "\Application Data\Microsoft\AddIns\", True
AddIns.Add Profile & "\Application Data\Microsoft\AddIns\MyAddIn.xla"
AddIns("MyAddIn").Installed = True
End Sub
Sub ClearAddinList()
Dim MyCount As Long
Dim GoUpandDown As String
'Turn display alerts off so user is not prompted to remove Addin from list
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Do
'Get Count of all AddIns
MyCount = Application.AddIns.Count
'Create string for SendKeys that will move up & down AddIn Manager List
'Any invalid AddIn listed will be removed
GoUpandDown = "{Up " & MyCount & "}{DOWN " & MyCount & "}"
Application.SendKeys GoUpandDown & "~", False
Application.Dialogs(xlDialogAddinManager).Show
Loop While MyCount <> Application.AddIns.Count
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I use a reversioning addin-manager to do this: basically its a small xla/xlam that never changes thats installed on each users machine. It checks a network share for the latest version of the real addin(s) and opens it as if it was an ordinary workbook: this has the effect of loading the real Addin(s) for the user.
There is a downloadable working example which you can customise here
Another option, this is what I do.
Key points.
Addin version is "some number", file name is always the same.
Installation directory must be known
When asked, the current addin, looks to see if a new version is available. I do this via a system that has a version number in the file name of the "update" and a version number as a const in the code.
Having established I we can update, I go and get the update "package" - in my case I am using an installer and a small vb.net app. If you cant do this then you might want to spin up an insatnce of PPT or word, and use that complete the install.
Next close yourself, or ask the user to close Excel.
Now all we need to do is save the new addin over the old one, with the same file name.
Tell the user its updated, and they should re-open Excel, close the install program.
This works well for me - although you need to remember the numbering system , in the file name and how that code works.
The below is the main guts of the code bit messy, but might help you out.
Private Sub CommandButton1_Click()
Dim RetVal As Long
MsgBox "To install the update, follow the installer programes directions." & vbNewLine & vbNewLine & _
"You will need to then closed down and restart Excel.", vbInformation + vbOKOnly, "::::UPDATE TRS:::::"
RetVal = Shell(gsDataBase1 & "\" & gsUpdatefolder & "\" & GetUpdateFileName(), 1)
ThisWorkbook.Close
Unload Me
End Sub
Private Sub CommandButton2_Click()
gbInUpdate = False
Unload Me
End Sub
Private Sub UserForm_Initialize()
Me.lbNew = GetServerVersion2
Me.lbCurrent.Caption = gcVersionNumber
'CheckVersionNumbers
End Sub
'''This method might be better, but is quite slow.
Public Sub GetServerVersion()
Set objshell = CreateObject("Shell.Application")
Set objFolder = objshell.Namespace(gsDataBase1 & "\" & gsUpdatefolder)
For Each strFileName In objFolder.Items
Me.lbNew.Caption = objFolder.GetDetailsOf(strFileName, 11)
Next
Set objshell = Nothing
End Sub
Public Function IsNewer() As Boolean
Dim curVer As Long
Dim newVer As Long
On Error GoTo Catch
curVer = CLng(Left(Replace(Me.lbCurrent, ".", ""), 2))
newVer = CLng(Left(Replace(Me.lbNew, ".", ""), 2))
If curVer < newVer Then
IsNewer = True
Else
IsNewer = False
End If
Exit Function
Catch:
IsNewer = False
End Function
Private Function GetServerVersion2() As String
On Error GoTo LEH
Dim strDocPath As String
Dim strCurrentFile As String
strDocPath = gsDataBase1 & "\" & gsUpdatefolder & "\"
strCurrentFile = Dir(strDocPath & "*.*")
'gets last file - randomly? should onl;y be one anyway!
'Do While strCurrentFile <> ""
GetServerVersion2 = Right(strCurrentFile, 11)
GetServerVersion2 = Left(GetServerVersion2, 7)
'Loop
Exit Function
LEH:
GetServerVersion2 = "0.Error"
End Function
'Basiclly a coop of GetSeverVerion, but just get the file name so the exe can be called by the shell operation under the update button
''seems clumbys, but works!
Private Function GetUpdateFileName() As String
On Error GoTo LEH
Dim strDocPath As String
Dim strCurrentFile As String
strDocPath = gsDataBase1 & "\" & gsUpdatefolder & "\"
GetUpdateFileName = Dir(strDocPath & "*.*")
Exit Function
LEH:
GetUpdateFileName = "0.Error"
End Function

Resources