none
VBA - PrintScrin cola caminho em célula no Excel (Não quero que cole o caminho) RRS feed

  • Pergunta

  • Bom dia pessoal,

    Estou com um código aqui, vou explicar ele primeiro:

    Tiro o print de um UserForm, salvo em uma pasta da rede e depois colo ele no corpo do e-mail. Até ai tudo certo, só meu problema é que quando ele tira o print e faz os processos, salva o caminho que foi salvo em uma célula do Excel, para ser mais preciso, na célula que estava selecionada. Não quero que isso aconteça, pois quando salva, substitui o conteúdo que tem na célula...

    Segue código:

    Dim cob As Excel.ChartObject
      Dim wks As Excel.Worksheet
      Dim shp As Excel.Shape
      Dim cht As Excel.Chart
      Dim objOutlook As Object 'Outlook.Application
      Dim objMailItem As Object 'Outlook.MailItem
      Dim strImagePath As String
      
      '___________________________
    
      
      
      strImagePath = Environ("save") & "M:\GEF-NOVO\10 Logistica\05 - Central\Agendamento de Prancha\Imagens - Novo Agendamento\PrintsNew\print.jpg" 'Local onde vai ser salvo
      
      Application.SendKeys "(%{1068})", True
      DoEvents
      Application.Wait Now + TimeSerial(0, 0, 1)
      
      Selection = strImagePath
       
      Application.ScreenUpdating = False
        
      Set wks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
      wks.Paste
      Set shp = wks.Shapes(1)
      Set cht = wks.ChartObjects.Add(0, 0, shp.Width, shp.Height).Chart
      cht.Paste
      cht.Export strImagePath, "jpg"
      
      wks.Parent.Close savechanges:=False
      Application.ScreenUpdating = True
      
    'tratar imagens para inserir no email
     Dim imagem, arrImagens
    'celula onde colocamos a localização da imagem
     imagem = Plan4.Cells(6, 1)
     If Len(imagem) > 0 Then
    
     arrImagens = Split(imagem, ";")
     imagem = "<p>Imagem</p>"
    
     For i = LBound(arrImagens) To UBound(arrImagens)
     If Dir(arrImagens(i)) <> "" Then
     
     imagem = "<p><img src=""cid:" & Environ(arrImagens(i)) & """ /></p>"
     End If
      Next i
      Set OutApp = CreateObject("Outlook.Application")
        OutApp.Session.Logon
        Set OutMail = OutApp.CreateItem(0)
        
        On Error Resume Next
        With OutMail
        .To = "fcvelho@klabin.com.br"
        .cc = ""
        .BCC = ""
        .Subject = "Agendamento de pranchas"
        .Attachments.Add "M:\GEF-NOVO\10 Logistica\05 - Central\Agendamento de Prancha\Imagens - Novo Agendamento\PrintsNew\print.jpg"
        .Attachments.Add arrImagens(i)
        
        
        .HTMLBody = "<A1>" & "Segue nova solicitação para agendamento de prancha: " & "</A1>" & "<BR><BR>" & _
        vbLf & "Solicitante: " & tb_solicitante.Text & vbLf & "<BR>" & _
        "Máquina: " & tb_maquina.Text & vbLf & "<br>" & _
        "Ordem: " & TextBox17.Text & vbLf & "<br>" & _
        "Origem: " & cb_origem.Text & vbLf & "<br>" & _
        "Destino: " & cb_destino.Text & vbLf & "<br>" & _
        "Responsável: " & ComboBox20.Text & vbLf & "<BR>" & _
        "Observação: " & tb_observacao.Text & vbLf & "<br><br>" & vbLf & "<br><br>" & _
        "Agendamento: " & imagem
        
        .Send 'or use .Display
    
    
    End With
    
        Set OutMail = Nothing
        Set OutApp = Nothing

    Nesse mesmo código, encontro outro problema... Ele desativa o NumLook :s

    Obrigado pela atenção pessoal.

    Att.

    quinta-feira, 30 de outubro de 2014 13:05

Respostas

  • Pessoal, consegui resolver meu problema de estar gravando em uma célula. Só deletei a seleção da imagem e ficou funcionando:

     Selection = strImagePath
    Único problema é o NumLock que continua desativando...

    • Marcado como Resposta fcvelho quinta-feira, 30 de outubro de 2014 16:52
    quinta-feira, 30 de outubro de 2014 16:52