Need a little help

[realitydrm]

Hello all. I need a little help. I have the following code below.

- In the sendeMail() portion of my code I would like to extract the values in a drop-down field in my word document with the title "email address". I would like the name selected to appear automatically in the email to line.
- I'm adding the Activedocument details to the subject line but would like to remove the .docx portion of the subject line. Do i need a separate outlook code to accomplish this?

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\******x\Desktop\Test 4"
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 = "VR*** Request: " + ActiveDocument + " CUSTOMER IS xx xx xx"
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

[gmayor]

You don't need a separate code, but the document name in the subject seems superfluous, as the following will demonstrate. The code assumes no illegal filename characters in the fields used for the filename.


Option Explicit

Sub RunAll()
Call Save(True) 'change to false to save only
End Sub

Sub Save(bSend As Boolean)
Dim strPath As String
Dim strPlate As String
Dim strName As String
Dim strFilename As String
Dim strEmail As String
Dim oCC As ContentControl

strPath = Environ("USERPROFILE") & "\Desktop\Test 4\"
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

Set oCC = ActiveDocument.SelectContentControlsByTitle("email address").Item(1)
If oCC.ShowingPlaceholderText Then
MsgBox "Select the email address!"
oCC.Range.Select
GoTo lbl_Exit
Else
strEmail = oCC.Range.Text
End If


strFilename = strPlate & "__" & strName & ".docx"
ActiveDocument.SaveAs2 FileName:=strPath & strFilename, FileFormat:=12

If bSend = True Then sendeMail strName, strEmail, strPlate

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(strCustomer As String, strEmail As String, strLicence)
Dim olkApp As Object
Dim strSubject As String
Dim strTo As String
Dim strBody As String
Dim strAtt As String
Dim strDocName As String


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
strDocName = ActiveDocument.Name
strDocName = Left(strDocName, InStrRev(strDocName, Chr(46)) - 1)

strSubject = "VR " & strLicence & " Request: " & strDocName & " CUSTOMER IS " & strCustomer
strBody = ""
strTo = ""

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

[realitydrm]

Hi Gmayor-

When I type some text in the place of my document labeled email address; it doesn't show-up in the to line of my email.

Set oCC = ActiveDocument.SelectContentControlsByTitle("email address").Item(1) If oCC.ShowingPlaceholderText Then
MsgBox "Select the email address!"
oCC.Range.Select
GoTo lbl_Exit
Else
strEmail = oCC.Range.Text
End If








You don't need a separate code, but the document name in the subject seems superfluous, as the following will demonstrate. The code assumes no illegal filename characters in the fields used for the filename.


Option Explicit

Sub RunAll()
Call Save(True) 'change to false to save only
End Sub

Sub Save(bSend As Boolean)
Dim strPath As String
Dim strPlate As String
Dim strName As String
Dim strFilename As String
Dim strEmail As String
Dim oCC As ContentControl

strPath = Environ("USERPROFILE") & "\Desktop\Test 4\"
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

Set oCC = ActiveDocument.SelectContentControlsByTitle("email address").Item(1)
If oCC.ShowingPlaceholderText Then
MsgBox "Select the email address!"
oCC.Range.Select
GoTo lbl_Exit
Else
strEmail = oCC.Range.Text
End If


strFilename = strPlate & "__" & strName & ".docx"
ActiveDocument.SaveAs2 FileName:=strPath & strFilename, FileFormat:=12

If bSend = True Then sendeMail strName, strEmail, strPlate

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(strCustomer As String, strEmail As String, strLicence)
Dim olkApp As Object
Dim strSubject As String
Dim strTo As String
Dim strBody As String
Dim strAtt As String
Dim strDocName As String


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
strDocName = ActiveDocument.Name
strDocName = Left(strDocName, InStrRev(strDocName, Chr(46)) - 1)

strSubject = "VR " & strLicence & " Request: " & strDocName & " CUSTOMER IS " & strCustomer
strBody = ""
strTo = ""

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

[gmayor]

My fault I didn't copy it correctlly change the section below as follows



strSubject = "VR " & strLicence & " Request: " & strDocName & " CUSTOMER IS " & strCustomer
strBody = "This is the body text"

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

[realitydrm]

Thanks again GM.