Consulting

Results 1 to 5 of 5

Thread: Need a little help

  1. #1

    Need a little help

    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
    Last edited by macropod; 03-19-2017 at 06:29 PM. Reason: Added code tags

  2. #2
    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
    Graham Mayor - MS MVP (Word)
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  3. #3

    Text not showing in To: line of email

    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







    Quote Originally Posted by gmayor View Post
    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

  4. #4
    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
    Graham Mayor - MS MVP (Word)
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  5. #5
    Thanks again GM.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •