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 
    
    
    Formatting tags added by mark007
    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 
    
    
    Formatting tags added by mark007
    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 
    
    
    Formatting tags added by mark007

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

  5. #5

Posting Permissions

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