送信者の名前を持つvba Outlookの署名

Question

私は多くの質問を検索しましたが、私がしようとしているものに一致するものを見つけることができませんでした。

このOutlookコードでは、Pedidosというメールを電子メールで送信しています。

Sub Mail_ActiveSheet() 

    Dim FileExtStr As String 
    Dim FileFormatNum As Long 
    Dim Sourcewb As Workbook 
    Dim Destwb As Workbook 
    Dim TempFilePath As String 
    Dim TempFileName As String 
    Dim OutApp As Object 
    Dim OutMail As Object 
    Dim sCC As String 
    Dim Signature As String 

    sCC = Range("copia").Value 
    With Application 
     .ScreenUpdating = False 
     .EnableEvents = False 
    End With 

    Set Sourcewb = ActiveWorkbook 

    Sheets("Pedidos").Copy 
    Set Destwb = ActiveWorkbook 

    ' Determine the Excel version, and file extension and format. 
    With Destwb 
     If Val(Application.Version) < 12 Then 
      ' For Excel 2000-2003 
      FileExtStr = ".xls": FileFormatNum = -4143 
     Else 
      ' For Excel 2007-2010, exit the subroutine if you answer 
      ' NO in the security dialog that is displayed when you copy 
      ' a sheet from an .xlsm file with macros disabled. 
      If Sourcewb.Name = .Name Then 
       With Application 
        .ScreenUpdating = True 
        .EnableEvents = True 
       End With 
       MsgBox "You answered NO in the security dialog." 
       Exit Sub 
      Else 
       Select Case Sourcewb.FileFormat 
       Case 51: FileExtStr = ".xlsx": FileFormatNum = 51 
       Case 52: 
        If .HasVBProject Then 
         FileExtStr = ".xlsm": FileFormatNum = 52 
        Else 
         FileExtStr = ".xlsx": FileFormatNum = 51 
        End If 
       Case 56: FileExtStr = ".xls": FileFormatNum = 56 
       Case Else: FileExtStr = ".xlsb": FileFormatNum = 50 
       End Select 
      End If 
     End If 
    End With 


    ' With Destwb.Sheets(1).UsedRange 
    '  .Cells.Copy 
    '  .Cells.PasteSpecial xlPasteValues 
    '  .Cells(1).Select 
    ' End With 
    ' Application.CutCopyMode = False 

    ' Save the new workbook, mail, and then delete it. 
    TempFilePath = Environ$("temp") & "\" 
    TempFileName = Sourcewb.Sheets("Consulta").Range("F2:G2").Value & " " _ 
       & IIf(Len(Day(Now)) = 1, "0" & Day(Now), Day(Now)) & IIf(Len(Month(Now)) = 1, "0" & Month(Now), Month(Now)) & Year(Now) & Hour(Now) & Minute(Now) & Second(Now) 

    Set OutApp = CreateObject("Outlook.Application") 

    Set OutMail = OutApp.CreateItem(0) 

    With Destwb 
     .SaveAs TempFilePath & TempFileName & FileExtStr, _ 
       FileFormat:=FileFormatNum 
     On Error Resume Next 
     On Error GoTo 0 
     ' Change the mail address and subject in the macro before 
     ' running the procedure. 
     With OutMail 
      .to = "example@example.com" 
      .CC = sCC 
      .BCC = "" 
      .Subject = "[PEDIDOS 019] " & TempFileName 
      .HTMLBody = "<font face=""calibri"" color=""black""> Olá Natalia, <br>" 
      .HTMLBody = .HTMLBody & " Por favor, fazer a requisição dos pedidos em anexo. <br>" & " Obrigado!<br>" & xxxxx & "</font>" 
      .Attachments.Add Destwb.FullName 
      ' You can add other files by uncommenting the following statement. 
      '.Attachments.Add ("C:\test.txt") 
      ' In place of the following statement, you can use ".Display" to 
      ' display the mail. 
      .SEND 
     End With 
     On Error GoTo 0 
     .Close SaveChanges:=False 
    End With 

    ' Delete the file after sending. 
    Kill TempFilePath & TempFileName & FileExtStr 

    Set OutMail = Nothing 
    Set OutApp = Nothing 

    With Application 
     .ScreenUpdating = True 
     .EnableEvents = True 
    End With 
End Sub 

あなたが見ることができるように、以下の行でxxxxxは、私は（私が送信していたように）私の電子メールを取得し、そこにそれを書く（または名前と姓）にしたい私の署名を表します。

.HTMLBody = "<font face=""calibri"" color=""black""> Olá Natalia, <br>" 
    .HTMLBody = .HTMLBody & " Por favor, fazer a requisição dos pedidos em anexo. <br>" & " Obrigado!<br>" & xxxxx & "</font>" 

だから私このxxxxxは、たとえば、私の名前多分私-メール、またはすることが本当に何を。

私はすでにMailItem.SenderNameのプロパティをチェックしましたが、使用方法がわかりませんでした。これはVBAを使用した初めての電子メールですので、どんな提案も高く評価されます。

Answer 1

あなたの署名にその「.TO」を追加します.TOでXXXXXを置き換えるこれは

.HTMLBody = .HTMLBody & " Por favor, fazer a requisição dos pedidos em anexo. <br>" & " Obrigado!<br>" & .To & "</font>" 

に動作します以下のコードを試してみてください送信されます。

Option Explicit 

Sub Signature_Insert() 

    Dim OutApp As Object 
    Dim OutMail As Object 
    Dim nS As Object 

    Dim signature As String 

    Set OutApp = CreateObject("Outlook.Application") 
    Set nS = OutApp.GetNamespace("mapi") 

    Debug.Print nS.CurrentUser 
    Debug.Print nS.CurrentUser.name ' default property 

    Debug.Print nS.CurrentUser.Address 
    Debug.Print nS.CurrentUser.AddressEntry.GetExchangeUser.PrimarySmtpAddress 

    signature = nS.CurrentUser 
    'signature = nS.CurrentUser.Address 

    Set OutMail = OutApp.CreateItem(0) 

    With OutMail 
     .To = "example@example.com" 
     .CC = "sCC" 
     .BCC = "" 
     .Subject = "[PEDIDOS 019] " & "TempFileName" 
     .HTMLBody = "<font face=""calibri"" color=""black""> Olá Natalia, <br>" 
     .HTMLBody = .HTMLBody & " Por favor, fazer a requisição dos pedidos em anexo. <br>" & " Obrigado!<br>" & signature & "</font>" 
     .Display 
    End With 

ExitRoutine: 
    Set OutApp = Nothing 
    Set nS = Nothing 
    Set OutMail = Nothing 

End Sub 

Answer 2

ただ、それはメールがあるまでSENDERNAMEは利用できません