Boa tarde.

Pessoal(Wagner) hehehehe.... Peguei o codigo que voce colocou como exemplo a uns topicos abaixo.
está funcionando perfeitamente mais gostaria de saber se é possivel colocar uma caixa de dialogo para informar o e-mail que deseja que o relatorio seja enviado.

Segue Codigo vou marcar onde desejo que apareça a caixa de dialogo para inserir o e-mail desejado.

Desde já agradeço!

Private Sub bt_email_Click()
Worksheets("Relatorio").Select
Application.ScreenUpdating = False
    Range("B4:G6018").Select
    Selection.Copy
    Sheets("email").Select
    Range("B4").Select
    ActiveSheet.Paste

    '========================================================
    'Essa macro requer que sejam acrescentadas as referências
    'Microsoft Outlook 12.0 (ou maior) Object Library
    'Microsoft Scriping Runtime
    '========================================================

    Dim OL As Object
    Dim EmailItem As Object
    Dim Wb As Workbook
    
    Application.ScreenUpdating = False
    Set OL = CreateObject("Outlook.Application")
    Set EmailItem = OL.CreateItem(olMailItem)
    ActiveSheet.UsedRange.Select
    
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        ActiveWorkbook.Path & "Temp.pdf", Quality:=xlQualityStandard _
        , IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish _
        :=False
    
    With EmailItem
        .Subject = "Relatorio dos projetos"
        .Body = "Segue anexo seus projetos para avaliação." & vbCrLf & _
        "" & vbCrLf & _
        "Obrigado!"
      [color=#FF0040] [b][size=150] .To = "AQUI abrir uma caixa de dialogo para poder colocar o email desejado" 'Destinatário do email[/size][/b][/color]
        .CC = "AQUI ficar um fixo mesmo" 'Destinatários em cópia
        .Importance = olImportanceNormal
        .Attachments.Add ActiveWorkbook.Path & "Temp.pdf"
        .Send
        
        MsgBox "RELATÓRIO ENVIADO COM SUCESSO!", vbInformation, "ENVIADO"
    End With
    
    
    Application.ScreenUpdating = True
    
    Set Wb = Nothing
    Set OL = Nothing
    Set EmailItem = Nothing

    Range("B4:G6018").Select
    Selection.EntireRow.Delete
    
    Sheets("Relatorio").Select
    Range("B4").Select
    
    Application.ScreenUpdating = True
     
End Sub