Excel vba - ajustar tamanho imagem email.

[RAIMUNDO LIMA DE ARAUJO]

Boa noite, pessoal, tudo bem? 

 

Estou usando o codigo abaixo para enviar e-mail e colar uma imagem que é copiado em um determinado intervalo, como faço, para ajustar o tamanho da imagem ao coloar no outlook? 

 

'codigo abaixo seleciona esse intervalo e cola email
   WH.Range("B1:L11").Select





Sub Enviar_INFORMATIVO()

Dim WH      As Worksheet
Dim OutProg As Object
Dim OutMail As Object
Dim OutApp  As Object

Set WH = Planilha1 ' PRINT QUE VAI NO E-MAIL PARA COLAR TGL01
Set OutProg = CreateObject("Outlook.Application")
Set OutMail = OutProg.CreateItem(0)

Application.ScreenUpdating = False

WH.Select

Application.ScreenUpdating = True

Application.DisplayAlerts = False

Set WH = Planilha5 ' ONDE PEGA OS E-MAIL PARA ENVIAR CONFIGURAAO EMAIL

Dim Anexo   As String

'Anexo = ThisWorkbook.Path ' NOME DO ARQUIVO PARA ANEXAR
'Anexo = Anexo & "\" & "ORDEM DE CARREGAMENTO.xlsm"

Anexo = MaisRecentArq(ThisWorkbook.Path & "\")
    
With OutMail
    .Display
    .To = WH.Range("D10").Value 'Para
    .CC = WH.Range("D12").Value 'Copia
    .Subject = WH.Range("D14").Value ' Assunto
    .bcc = "[email protected]"
    .Attachments.Add Anexo
    .Body = WH.Range("D16").Value ' Corpo e-mail
    '.Send
    
End With

Application.DisplayAlerts = True

Set OutMail = Nothing
Set OutApp = Nothing
Set OutProg = Nothing

Set WH = Planilha1 ' INFORMATIVO

'o codigo abaixo, seleciona a ultima linha preenchida e dá print para ser enviado e-mail
' WH.Range("B1:L" & Cells(Rows.Count, "L").End(xlUp).Row).Select ' usamos a coluna E para localizar a ultima linha preenchida
   
   'codigo abaixo seleciona esse intervalo e cola email
   WH.Range("B1:L11").Select
    Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    WH.Range("A1").Select

    ' Salva pasta de trabalho
    
End Sub

 

[OreiaG]

Experimente esta outra versão. Não testei a parte que anexa um arquivo.
 

Sub Enviar_INFORMATIVO()
 Dim ws As Worksheet, Anexo As String
  Application.ScreenUpdating = False
  Sheets("Planilha2").Range("B1:L11").CopyPicture xlScreen, xlPicture 'PRINT QUE VAI NO E-MAIL PARA COLAR TGL01 _
   coloque aqui o nome que está na guia da planilha
  Sheets.Add
  ActiveSheet.Paste Destination:=Range("A1")
  With Selection
   .ShapeRange.LockAspectRatio = msoTrue
   .ShapeRange.Width = .ShapeRange.Width * 1.2  'este parâmetro irá aumentar o print da planilha em 20%, _
    mas se você quiser reduzir o tamnaho para 80% então coloque 0.8 no lugar de 1.2
  End With
  ActiveWorkbook.EnvelopeVisible = True
  Set ws = Sheets("Planilha3") 'ONDE PEGA OS E-MAIL PARA ENVIAR CONFIGURAAO EMAIL _
    coloque aqui o nome que está na guia da planilha
    
'  Anexo = ThisWorkbook.Path ' NOME DO ARQUIVO PARA ANEXAR
'  Anexo = Anexo & "\" & "ORDEM DE CARREGAMENTO.xlsm"
'  Anexo = MaisRecentArq(ThisWorkbook.Path & "\")

  With ActiveSheet.MailEnvelope
   .Item.To = ws.Range("D10").Value 'Para
   .Item.CC = ws.Range("D12").Value 'Copia
   .Item.Subject = ws.Range("D14").Value 'Assunto
   '.bcc = "[email protected]"
   '.Attachments.Add Anexo
   .Item.send
  End With
  Application.DisplayAlerts = False
  ActiveSheet.Delete
End Sub