Excel Forum - Porady, Pomoc,  Excel Help, Excel FAQ Strona Główna
 FAQ  RegulaminRegulamin  Szukaj   Użytkownicy   Grupy   Rejestracja   Profil   Twoje wiadomości   Zaloguj 


Poprzedni temat «» Następny temat
Przesunięty przez: Kaper
14-05-2020, 18:46
dodanie do treści wiadomości zakresu jako obraz (VBA)
Autor Wiadomość
kamilkamil
Stały bywalec Excelforum


Wersja: Win Office 365
Posty: 281
Wysłany: 08-05-2020, 10:35   dodanie do treści wiadomości zakresu jako obraz (VBA)

Cześć.

Mam kod do wysyłania meila, chciałbym jeszcze troszkę go "zautomatyzować".

Po linijce "tresc" , pod spodem, chciałbym aby zakres od D4:J15 (jest to tabela z danymi) w tym samym arkuszu umieszczała się jako obraz.

Kod:

Sub mail()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim xPrompt As String
    Dim xOkOrCancel As Integer
    Dim tresc As String
   
     
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
 
 
  tresc = "<html><body><p style=""font-family:Calibri; font-size:11pt;"">" & _
                                Range("A20").Value & "<BR>xxx." & _
                                 "</p></body></html>"

... tutaj ten zakres jako obraz ...
   
    With OutMail
        .Display
        .To = Range("N1")
        .Cc = Range("N2")
        .BCC = Range("N3")
        .Subject = "wynik"
        .HTMLBody = tresc & .HTMLBody
        .Attachments.Add ("C:\test\aa.pdf")
     
  End With
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub


Dziękuję
ID posta: 387064 Skopiuj do schowka
 
 
Tajan


Pomógł: 4688 razy
Posty: 10353
Wysłany: 08-05-2020, 11:16   

Poszukaj na forum i dodaj do swojego kodu funkcję RangeToHtml.
Następnie zmień linię:
Kod:
.HTMLBody = tresc & .HTMLBody

na:
Kod:
.HTMLBody = tresc & RangeToHtml(Range("D4:J15")) & .HTMLBody

Wprawdzie nie wstawia treści jak obrazu lecz jako tabelę, ale jest dość proste do wykonania.
ID posta: 387068 Skopiuj do schowka
 
 
kamilkamil
Stały bywalec Excelforum


Wersja: Win Office 365
Posty: 281
Wysłany: 12-05-2020, 12:13   

Cześć,

Mam juz kod z funkcją.
Czy można to jakoś mienić, żeby wklejony zakres był obrazem a nie tabelą ??

Kod:


Sub mail()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim xPrompt As String
    Dim xOkOrCancel As Integer
    Dim tresc As String
    Dim rng As Range

Set rng = Sheets("obraz").Range("B2:K70")
   
    If TypeName(rng) <> "Range" Then
    MsgBox "The selection is not a range" & vbLf & "please correct and try again."
    Exit Sub
  End If
   
     
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
 
 
  tresc = "<html><body><p style=""font-family:Calibri; font-size:11pt;"">" & _
                                Range("A20").Value & "<BR>xxx." & _
                                 "</p></body></html>"

   
    With OutMail
        .Display
        .To = Range("N1")
        .Cc = Range("N2")
        .BCC = Range("N3")
        .Subject = "wynik"
        .HTMLBody = tresc & RangetoHTML(rng) & .HTMLBody
        .Attachments.Add ("C:\test\aa.pdf")
     
  End With
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

Function RangetoHTML(rng As Range)
 
 
  Dim TempFile As String, ddo As Long
  TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
 
 
  ddo = ActiveWorkbook.DisplayDrawingObjects
  ActiveWorkbook.DisplayDrawingObjects = xlHide
  With ActiveWorkbook.PublishObjects.Add( _
       SourceType:=xlSourceRange, _
       Filename:=TempFile, _
       Sheet:=ActiveSheet.Name, _
       Source:=Union(rng, rng).Address, _
       HtmlType:=xlHtmlStatic)
    .Publish True
    .Delete
  End With
  ActiveWorkbook.DisplayDrawingObjects = ddo
 
 
  With CreateObject("Scripting.FileSystemObject").GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = Replace(.ReadAll, "align=center x:publishsource=", "align=left x:publishsource=")
    .Close
  End With
 
 
  Kill TempFile
 
End Function


ID posta: 387234 Skopiuj do schowka
 
 
kamilkamil
Stały bywalec Excelforum


Wersja: Win Office 365
Posty: 281
Wysłany: 13-05-2020, 09:56   

Sorki że piszę pod swoim postem, ale posklejałem co nieco i już prawie jest to czego oczekuje.

Kod:

Sub mail()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim xPrompt As String
    Dim xOkOrCancel As Integer
    Dim tresc As String
    Dim wordEditor As Object

    Range("B2:K91").CopyPicture
   
   
   
     
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
 
 
  tresc = "<html><body><p style=""font-family:Calibri; font-size:11pt;"">" & _
                                Range("A20").Value & "<BR>xxx." & _
                                 "</p></body></html>"

   
    With OutMail
        .Display
        .To = Range("N1")
        .Cc = Range("N2")
        .BCC = Range("N3")
        .Subject = "wynik"
        .HTMLBody = tresc & .HTMLBody
        .Attachments.Add ("C:\test\aa.pdf")
     
  End With

        Set wordEditor = OutApp.ActiveInspector.wordEditor
    wordEditor.Application.Selection.Paste


    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub


Jedyny mankament, że ten obraz z podanego zakresu ląduje na samym początku wiadomości email, a chciałbym , żeby był pod treścią
ID posta: 387287 Skopiuj do schowka
 
 
Tajan


Pomógł: 4688 razy
Posty: 10353
Wysłany: 13-05-2020, 13:38   

Spróbuj w taki sposób:
Kod:
Sub mail()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim tresc As String
    Dim rng As Range
    Dim imgFile As String

    Const fNamePicture As String = "rangePicture.jpg"

    Set rng = Sheets("obraz").Range("B2:K70")
    imgFile = RangeToPicture(rng, fNamePicture)
     
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
 
    tresc = "<html><body><p style=" & _
            """font-family:Calibri; font-size:11pt;"">" & _
            Range("A20").Value & "<BR>" & _
            "<img src=""cid:" & fNamePicture & """height=auto width=auto><BR>" & _
            "xxx." & _
            "</p></body></html>"
   
    With OutMail
        .Display
        .To = Range("N1")
        .Cc = Range("N2")
        .BCC = Range("N3")
        .Subject = "wynik"
        .Attachments.Add imgFile
        .HTMLBody = tresc & .HTMLBody
        .Attachments.Add ("C:\test\aa.pdf")
    End With
   
    Set OutMail = Nothing
    Set OutApp = Nothing

End Sub

Function RangeToPicture(rng As Range, fName As String)
  Dim TempFile As String
  Dim oCht As ChartObject
 
  TempFile = Environ$("temp") & "\" & fName
 
   If Dir(TempFile) <> "" Then Kill TempFile

    With rng
       .CopyPicture xlScreen, xlBitmap
       Set oCht = ActiveSheet.ChartObjects.Add(Left:=.Left, Top:=.Top, _
                               Width:=.Width, Height:=.Height)
    End With
   
    With oCht.Chart
          .Paste
          .Export Filename:=TempFile, Filtername:="JPG"
          .Parent.Delete
    End With
     
    RangeToPicture = TempFile
 
End Function
Takim kodem będziesz mógł umieścić obraz w dowolnym miejscu.
ID posta: 387317 Skopiuj do schowka
 
 
kamilkamil
Stały bywalec Excelforum


Wersja: Win Office 365
Posty: 281
Wysłany: 14-05-2020, 08:52   

Taja, dzięki za pomoc.

Kod działa, ale nie do końca. Wklejany obraz ma same ramki a w środku jest pusty (białe pole)
ID posta: 387380 Skopiuj do schowka
 
 
Tajan


Pomógł: 4688 razy
Posty: 10353
Wysłany: 14-05-2020, 08:54   

Załącz przykładowy plik.
ID posta: 387382 Skopiuj do schowka
 
 
kamilkamil
Stały bywalec Excelforum


Wersja: Win Office 365
Posty: 281
Wysłany: 14-05-2020, 09:14   

proszę załącznik
ID posta: 387383 Skopiuj do schowka
 
 
Tajan


Pomógł: 4688 razy
Posty: 10353
Wysłany: 14-05-2020, 09:25   

Nie widzę :-) Gdyby plik miał nazwę "Zeszyt1" to zmień na inną bo czasem forum nie chce takiej nazwy zaakceptować.
ID posta: 387384 Skopiuj do schowka
 
 
kamilkamil
Stały bywalec Excelforum


Wersja: Win Office 365
Posty: 281
Wysłany: 14-05-2020, 10:12   

wysyłam jeszcze raz załącznik

mail.xlsm
Pobierz Plik ściągnięto 39 raz(y) 69.27 KB

ID posta: 387388 Skopiuj do schowka
 
 
Tajan


Pomógł: 4688 razy
Posty: 10353
Wysłany: 14-05-2020, 12:16   

No, nie wiem. U mnie działa. Zobacz załącznik. Być może to kwestia wersji Excela?
Jakiej używasz?

mail.png
Plik ściągnięto 12 raz(y) 16.94 KB

ID posta: 387397 Skopiuj do schowka
 
 
Tajan


Pomógł: 4688 razy
Posty: 10353
Wysłany: 14-05-2020, 13:33   

Gdyby nadal był problem dodaję kod wykorzystujący twój sposób, ale wstawiający obraz na końcu wiadomości:
Kod:
Sub mail()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim tresc As String
    Dim rng As Range
    Dim foot As String

    Set rng = Sheets("obraz").Range("B2:K86")
     
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
 
    tresc = "<html><body><p style=" & _
            """font-family:Calibri; font-size:11pt;"">" & _
            Range("U1").Value & "<BR>" & _
            "xxx." & _
            "</p></body></html>"
           
           
   
    With OutMail
        .Display
        .To = Range("N1")
        .Cc = Range("N2")
        .BCC = Range("N3")
        .Subject = "wynik"
        foot = .Body
        .HTMLBody = tresc
       
        rng.Copy
   
        With .GetInspector.WordEditor.Range
             .Start = Len(OutMail.Body)
             .End = .Start
             .Paste
             .Start = .End
             .insertParagraph
             .Text = foot
        End With
     
    End With
   
    Set OutMail = Nothing
    Set OutApp = Nothing

End Sub
ID posta: 387403 Skopiuj do schowka
 
 
kamilkamil
Stały bywalec Excelforum


Wersja: Win Office 365
Posty: 281
Wysłany: 18-05-2020, 09:03   

Cześć Tajan,

Używam najnoweszego ms office.

Kod , który podesłałeś dalej wkleja mi nie obraz , a wartości (po wklejeniu mogę je sobie pozmieniać w outlook)
ID posta: 387528 Skopiuj do schowka
 
 
Artik 



Wersja: Win Office 365
Pomógł: 3015 razy
Posty: 9948
Wysłany: 20-05-2020, 04:02   

Spróbuj

Artik
_________________
Persistence is a virtue in the world of programming.
ID posta: 387620 Skopiuj do schowka
 
 
kamilkamil
Stały bywalec Excelforum


Wersja: Win Office 365
Posty: 281
Wysłany: 02-06-2020, 13:30   

Dzięki Artik za sugestię.
Niestety mam błąd, pisze:
The code in this project must be updated for use on 64bit systems.
ID posta: 388249 Skopiuj do schowka
 
 
Wyświetl posty z ostatnich:   
Odpowiedz do tematu
Nie możesz pisać nowych tematów
Nie możesz odpowiadać w tematach
Nie możesz zmieniać swoich postów
Nie możesz usuwać swoich postów
Nie możesz głosować w ankietach
Nie możesz załączać plików na tym forum
Możesz ściągać załączniki na tym forum
Dodaj temat do Ulubionych
Wersja do druku

Skocz do:  

Powered by phpBB modified by Przemo © 2003 phpBB Group
Theme xandgreen created by spleen& Programosy modified v0.3 by warna
Opieka techniczna www.marketingNET.pl

Archiwum

Strona używa plików cookies.

Kliknij tutaj, żeby dowiedzieć się jaki jest cel używania cookies oraz jak zmienić ustawienia cookie w przeglądarce.
Korzystając ze strony użytkownik wyraża zgodę na używanie plików cookies, zgodnie z bieżącymi ustawieniami przeglądarki.
Sprawdź, w jaki sposób przetwarzamy dane osobowe