Sub SendMail0()

    Selection.WholeStory
    Selection.Copy

    Dim olapp As Object
    Dim olemail As Object
    Dim olInsp As Object
    Dim wddoc As Object

    On Error Resume Next
    Set olapp = GetObject(, "Outlook.Application")
    If Err <> 0 Then Set olapp = CreateObject("Outlook.Application")
    On Error GoTo 0
    Set olemail = olapp.CreateItem(0)
    With olemail
        .SentOnBehalfOfName = "travelconcierge.im@pg.com"
        .BodyFormat = 3
        .Body = 3
        .To = "кому"
        .Subject = "Запрос "
        .Display
        Set olInsp = .GetInspector
        Set wddoc = olInsp.wordeditor
        wddoc.Content.Paste
        wddoc.Application.Selection.InsertBefore "Подскажите, как добавить перед этим текстом в тело письма просто текст" & vbCrLf

    End With
End Sub

Function Read_Text(Путь_К_Файлу As String) As String
    With CreateObject("ADODB.Stream")
    .Type = 2
    .Charset = "utf-8"
    .Open
    .LoadFromFile Путь_К_Файлу
    Read_Text = .ReadText
    .Close
   End With
End Function

' Код разместить в ThisOutlookSession

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    Dim subj As String, filename As String
    filename = "C:\1.csv"
    If Item.Class = olMail Then
        subj = Item.Subject
        With CreateObject("Scripting.FileSystemObject")
            If .FileExists(filename) Then
                Set obj = .OpenTextFile(filename, 8)
            Else
                Set objf = .CreateTextFile(filename)
                Set objf = Nothing
                Set obj = .OpenTextFile(filename, 8)
            End If
            obj.Write subj & vbCrLf
            obj.Close
            Set obj = Nothing
        End With

    End If
End Sub

Public Function Arr_init(arr() As String) As Dictionary
    Dim count&
    Dim arr_tmp(), arr_coord As Dictionary
   set arr_coord = new Dictionary

    For i = 1 To UBound(arr())

        If Not arr_coord.Exists(arr(i)) Then  ' добавляю уникальное значение в словарь
            arr_coord.Item(arr(i)) = Array(i)
        Else
            arr_tmp = arr_coord.Item(arr(i))
            count = UBound(arr_tmp) + 1
            ReDim Preserve arr_tmp(count)
            arr_tmp(count) = i
            arr_coord.Item(arr(i)) = arr_tmp
        End If

    Next i

    Set Arr_init = arr_coord
End Function

Set SelectList = oIE.Document.getElementbyid("metrology_org_type")
SelectList.Value = "measurements"
SelectList.Value = "docs_expertise"
 '

Sub GetCoordinates()
    Set appACAD = CreateObject("AutoCAD.Application")
    appACAD.Visible = True
    Set Doc = appACAD.activedocument
    Dim plineObj As Variant
    Dim points(0 To 7) As Double
    points(0) = 310: points(1) = 15:
    points(2) = 10: points(3) = 10:
    points(4) = 100: points(5) = 110:
    points(6) = 310: points(7) = 15:
    Set plineObj = Doc.ModelSpace.AddLightWeightPolyline(points)
    plineObj.Closed = True
    Dim offsetObj1 As Variant, offsetObj2 As Variant
    offsetObj1 = plineObj.Offset(10)
    offsetObj2 = plineObj.Offset(-10)
    Coordinates = plineObj.Coordinates
    Coordinates1 = offsetObj1(0).Coordinates
    Coordinates2 = offsetObj2(0).Coordinates
    Doc.Close (False)
    appACAD.Quit
    Set appACAD = Nothing
End Sub