Need a little help

[realitydrm]

Hello all. I'm new to VBA and I'm trying to automate a process. I want to save a word document as the file name from my the content control boxes for license plate number first than customer name and I would like to save it to a particular location, close it out and open a new outlook email that has the text i chose in the subject line. Here is what i have so far:

Dim strFilename As String
strText = ThisDocument.SelectContentControlsByTitle("License Plate Number")(1).Range.Text
strText = ThisDocument.SelectContentControlsByTitle("Customer Name")(1).Range.Text

Dim strFilename As String
strFilename = strText & ("License Plate Number") & ("Customer Name") & ".docx"


ThisDocument.SaveAs strFilename

[gmayor]

You need to make better use of the variables e.g. as follows, though do note that the following will save in the currently active document folder, makes no correction for illegal filenames and will overwrite any existing file of the same name present in the folder. To accommodate those issues see the CleanFilename, FileNameUnique and BrowseforFolder functions at http://www.gmayor.com/useful_vba_functions.htm


Sub SaveExample()
Dim strPlate As String
Dim strName As String
Dim strFilename As String
Dim oCC As ContentControl

On Error GoTo err_Handler
Set oCC = ActiveDocument.SelectContentControlsByTitle("License Plate Number").Item(1)
If oCC.ShowingPlaceholderText Then
MsgBox "Complete the License plate number!"
oCC.Range.Select
GoTo lbl_Exit
Else
strPlate = oCC.Range.Text
End If

Set oCC = ActiveDocument.SelectContentControlsByTitle("Customer Name").Item(1)
If oCC.ShowingPlaceholderText Then
MsgBox "Complete the Customer Name!"
oCC.Range.Select
GoTo lbl_Exit
Else
strName = oCC.Range.Text
End If

strFilename = strPlate & "_" & strName & ".docx"
ActiveDocument.SaveAs2 FileName:=strFilename, FileFormat:=12
lbl_Exit:
Set oCC = Nothing
Exit Sub
err_Handler:
MsgBox Err.Number & vbCr & Err.Description
Err.Clear
GoTo lbl_Exit
End Sub

[realitydrm]

Thanks for the help! How do I save to a folder besides the Documents folder. I would like to save to a folder on my desk top.

[gmayor]

The following will save to a named folder on the desktop (which it will create if not present) or you could use the browsefor folder function as I suggested earlier, to pick any folder.


Sub SaveExample2()
'Graham Mayor - http://www.gmayor.com - Last updated - 13/03/2017
Dim strPath As String
Dim strPlate As String
Dim strName As String
Dim strFilename As String
Dim oCC As ContentControl

strPath = Environ("USERPROFILE") & "\Desktop\Documents Folder\"
CreateFolders strPath
'Or using the BrowseForFolder function from my web site to pick a folder
'strPath = BrowseForFolder
On Error GoTo err_Handler
Set oCC = ActiveDocument.SelectContentControlsByTitle("License Plate Number").Item(1)
If oCC.ShowingPlaceholderText Then
MsgBox "Complete the License plate number!"
oCC.Range.Select
GoTo lbl_Exit
Else
strPlate = oCC.Range.Text
End If

Set oCC = ActiveDocument.SelectContentControlsByTitle("Customer Name").Item(1)
If oCC.ShowingPlaceholderText Then
MsgBox "Complete the Customer Name!"
oCC.Range.Select
GoTo lbl_Exit
Else
strName = oCC.Range.Text
End If

strFilename = strPlate & "_" & strName & ".docx"
ActiveDocument.SaveAs2 FileName:=strPath & strFilename, FileFormat:=12
lbl_Exit:
Set oCC = Nothing
Exit Sub
err_Handler:
MsgBox Err.Number & vbCr & Err.Description
Err.Clear
GoTo lbl_Exit
End Sub

Private Sub CreateFolders(strPath As String)
'A Graham Mayor/Greg Maxey AddIn Utility Macro
Dim oFSO As Object
Dim lngPathSep As Long
Dim lngPS As Long
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
lngPathSep = InStr(3, strPath, "\")
If lngPathSep = 0 Then GoTo lbl_Exit
Set oFSO = CreateObject("Scripting.FileSystemObject")
Do
lngPS = lngPathSep
lngPathSep = InStr(lngPS + 1, strPath, "\")
If lngPathSep = 0 Then Exit Do
If Len(Dir(Left(strPath, lngPathSep), vbDirectory)) = 0 Then Exit Do
Loop
Do Until lngPathSep = 0
If Not oFSO.FolderExists(Left(strPath, lngPathSep)) Then
oFSO.CreateFolder Left(strPath, lngPathSep)
End If
lngPS = lngPathSep
lngPathSep = InStr(lngPS + 1, strPath, "\")
Loop
lbl_Exit:
Set oFSO = Nothing
Exit Sub
End Sub

[realitydrm]

Thanks a lot for the help! I also added an outlook function and run all. See below.





Sub RunAll()
Call Save

Call sendeMail
End Sub

Sub Save()

Dim strPath As String
Dim strPlate As String
Dim strName As String
Dim strFilename As String
Dim oCC As ContentControl

strPath = "C:\Users\myusername.myusername\Desktop\"
CreateFolders strPath

On Error GoTo err_Handler
Set oCC = ActiveDocument.SelectContentControlsByTitle("License Plate Number").Item(1)
If oCC.ShowingPlaceholderText Then
MsgBox "Complete the License plate number!"
oCC.Range.Select
GoTo lbl_Exit
Else
strPlate = oCC.Range.Text
End If

Set oCC = ActiveDocument.SelectContentControlsByTitle("Customer Name").Item(1)
If oCC.ShowingPlaceholderText Then
MsgBox "Complete the Customer Name!"
oCC.Range.Select
GoTo lbl_Exit
Else
strName = oCC.Range.Text
End If

strFilename = strPlate & "_" & strName & ".docx"
ActiveDocument.SaveAs2 FileName:=strPath & strFilename, FileFormat:=12
lbl_Exit:
Set oCC = Nothing
Exit Sub
err_Handler:
MsgBox Err.Number & vbCr & Err.Description
Err.Clear
GoTo lbl_Exit
End Sub


Private Sub CreateFolders(strPath As String)

Dim oFSO As Object
Dim lngPathSep As Long
Dim lngPS As Long
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
lngPathSep = InStr(3, strPath, "\")
If lngPathSep = 0 Then GoTo lbl_Exit
Set oFSO = CreateObject("Scripting.FileSystemObject")
Do
lngPS = lngPathSep
lngPathSep = InStr(lngPS + 1, strPath, "\")
If lngPathSep = 0 Then Exit Do
If Len(Dir(Left(strPath, lngPathSep), vbDirectory)) = 0 Then Exit Do
Loop
Do Until lngPathSep = 0
If Not oFSO.FolderExists(Left(strPath, lngPathSep)) Then
oFSO.CreateFolder Left(strPath, lngPathSep)
End If
lngPS = lngPathSep
lngPathSep = InStr(lngPS + 1, strPath, "\")
Loop
lbl_Exit:
Set oFSO = Nothing
Exit Sub
End Sub

Private Sub sendeMail()
Dim olkApp As Object
Dim strSubject As String
Dim strTo As String
Dim strBody As String
Dim strAtt As String

strSubject = ""
strBody = ""
strTo = ""
If ActiveDocument.FullName = "" Then
MsgBox "activedocument not saved, exiting"
Exit Sub
Else
If ActiveDocument.Saved = False Then
If MsgBox("Activedocument NOT saved, Proceed?", vbYesNo, "Error") <> vbYes Then Exit Sub
End If
End If
strAtt = ActiveDocument.FullName

Set olkApp = CreateObject("outlook.application")
With olkApp.createitem(0)
.to = strTo
.Subject = strSubject
.body = strBody
.attachments.Add strAtt
'.send
.Display
End With
Set olkApp = Nothing
End Sub