Question

我想在我的word文档的下拉字段中提取标题＆＃34;电子邮件地址＆＃34;。

我希望选择的名称自动显示在电子邮件中。 - 我将Activedocument详细信息添加到主题行，但是想要删除主题行的.docx部分。

我是否需要单独的Outlook代码才能实现此目标？

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

Answer 1

要获取没有扩展程序的文档名称，您可以使用：

Left(ActiveDocument.Name, InStrRev(ActiveDocument.Name, ".") - 1)

InStrRev找到最后一个＆＃34;点＆＃34; .
左截断名称直到该位置
-1应用于找到的位置也是删除.本身

例如，

strSubject = "VR*** Request:   " & Left(ActiveDocument.Name, InStrRev(ActiveDocument.Name, ".") - 1) & "    CUSTOMER IS xx xx xx"

<强>附录

要从标题为＆＃34;电子邮件地址＆＃34;的内容控件中获取电子邮件地址，您可以使用此功能：

Function getEmailAddress()
    Dim sh As ContentControl
    For Each sh In ThisDocument.Range.ContentControls
        If sh.Title = "email address" Then
            getEmailAddress = sh.Range.Text
            Exit Function
        End If
    Next
End Function

即

With olkApp.createitem(0) 
    .To = getEmailAddress
    ' etc...

需要一点指导

1 个答案: