Sub ssd()
Dim myOlApp As New Outlook.Application
    Dim myOlExp As Outlook.Explorer
    Dim myOlSel As Outlook.Selection
    Dim MsgTxt, ToWho As String
    Dim x As Integer
    MsgTxt = "You have selected items from: "
    Set myOlExp = myOlApp.Explorers.Item( 1 )
    
    Set myOlSel = myOlExp.Selection
    ToWho = InputBox("Введите адрессата для выбранных сообщений")
    For x =  1  To myOlSel.Count
          myOlSel.Item(x).To = ToWho
          myOlSel.Item(x).Save
         'myOlSel.Item(x).Send 'отправлять лучше пересылкой в исходящие - вручную
  Next x
End Sub

Dim iMsg
Dim iBp
Dim Flds
Dim Subj
Dim TextB
Dim ToWho


Const cdoSendUsingMethod = "http://schemas.microsoft.com/cdo/configuration/cdoSendUsingMethod"
Const cdoSendPassword = "http://schemas.microsoft.com/cdo/configuration/cdoSendPassword"
Const cdoSMTPServer = "http://schemas.microsoft.com/cdo/configuration/smtpserver"
Const smtpserverport = "http://schemas.microsoft.com/cdo/configuration/smtpserverport"
Const CdoSendUsing = "http://schemas.microsoft.com/cdo/configuration/sendusing"


Dim iConf
Set iConf = CreateObject("CDO.Configuration")
Set Flds = iConf.Fields
'Flds(cdoSendUsingMethod) = 2 
'Flds(cdoSMTPServer) = "MySMTPServer"
'Flds(smtpserverport) = 25
'Flds("cdoSMTPAuthenticate") = 0 
Flds.Update

ToWho = InputBox("Введите адрессата")
Subj = InputBox("Введите тему сообщения")
TextB = InputBox("Введите текст сообщения")
FolderPath=InputBox("Введите путь к файлам, к примеру: C:\windows\")


Dim fso, fld, f1, fc, s, FolderPath
Set fso = CreateObject("Scripting.FileSystemObject")

if FolderPath <> "" then 
Set fld = fso.GetFolder(FolderPath)
Set fc = fld.Files





For Each f1 In fc
s =FolderPath & f1.Name
iMsg=null

Set iMsg = CreateObject("CDO.Message")

With iMsg
Set .Configuration = iConf
.To = ToWho
.From = "radgdf@sdfs.ru"
.Sender = "авпукук"
.Subject = Subj
.TextBody = TextB
Set iBp = .AddAttachment(s)
iBp.ContentMediaType="application/msword"
.Send
End With
Msgbox s
Next

end if

Sub ssd()
Dim myOlApp As New Outlook.Application   ' переменная оутлука
    Dim myOlExp As Outlook.Explorer        ' переменная папки оутлука
    Dim myOlSel As Outlook.Selection     ' переменная выделенных сообщений оутлука
    Dim ToWho As String
    Dim x As Integer
    Set myOlExp = myOlApp.Explorers.Item( 1 )  'выбираем одну из выделенных папок оутлука
    Set myOlSel = myOlExp.Selection              'выбираем выделенные сообщения
    ToWho = InputBox("Введите адрессата для выбранных сообщений")
    For x =  1  To myOlSel.Count      'во всех выделенных сообщениях выполнить
          myOlSel.Item(x).To = ToWho       'проставить адрессата
          myOlSel.Item(x).Save                 'сохранить письмо
         'myOlSel.Item(x).Send 'отправлять лучше пересылкой в исходящие - вручную
  Next x
End Sub