[Miedzcu]

#excel #vba #visual #basic

Witam. Od razu się przyznam że jestem VBA’owym ignorantem. Żadnego macro nie napisałem (noo oprócz czyszczenia komórek), zawsze posiłkuje się publicznie dostępnymi kompilacjami (Ctrl+C i Ctrl+V + drobne poprawki by dopasować, czasami na oślep). Będę wiec prosił Was o pomoc z poziomu 0 – totalnego amatora.

Sprawa: na koniec zmiany chce wysłać raport. Raport wypełniany w Excelu, a zadanie macro to:
- otwarcie Outlooka
-wygenerowanie nowej wiadomości
-zaadresowanie wiadomości
-wypełnienie tytułu wiadomości zgodnie z data i zmianą

Te kroki udaje się osiągnąć ale napotykam pewien problem:
-tabele są formatowane w HTML. Niestety zanikają wtedy wszelkie bajery graficzne excela (wypełnia warunkowego). Główne ofiary to paski postępu i gradienty komórek. Są one istotne bo bez wczytywania się w raport od razu sygnalizują problem. Niestety w wiadomości są pustym białym tłem z wartością komórki bez efektu graficznego.

Od tygodnia (nieskutecznie i nieumiejętnie) poszukuje rozwiązania.

a) Plan A (ambitniejszy): komórki C2:N67 są wciąż formatowane w HTML (zachowanie możliwości kopiowania tekstu, wciąż czytelność HTML jest dużo ponad obrazek), komórki C68:N96 w tej samej wiadomości wklejają się już jako obrazek zaraz pod przednim formatowaniem HTML (najlepiej powiększony obrazek), a pod tym obrazkiem ponownie od komórek C97:N180 wróciło formatowanie HTML w wiadomości
b) Plan B mniej ambitny: całość od C2 do N180 wklejało się w nową wiadomość jako obrazek – i to się udało – nie podoba mi się jednak jedna rzecz (oprócz utraty kopiowania testu i mniejszej wyrazistości)- obrazek raportu wlepia się dość wąski a właściwie mały bo wciąż zachowane są proporcje. Zajmuje raptem 1/3 szerokości dostępnej w wiadomości. Czy można go w jakiś sposób inteligentny (na zasadzie jakiegoś dopasowania do dostępnej szerokości) powiększyć po przez komendę VBA lub mniej inteligentnie po przez stałe wartości (np. powiększenie 200%?)

Także plan A zawodzi mnie gdyż nie potrafię zmusić dwa makra do współpracy w jednej i tej samej wiadomości (generują osobne wiadomości).
A plan B udaje się połowicznie gdyż obrazek jest po prostu za mały.

Będę wdzięczny za pomoc. Jak macie gotowce które działają to bardzo chętnie im się przyjże. Być może problemu nie ma tylko jako amator Ctrl+C skopiowałem linijki kodu przez które kombinuje jak „koń pod górę”. Chat GPT zaproponował mi kompilacje obu dwóch kodów w jeden ale z niepowodzeniem. Radził też posłużeniem się komendą Set wordDoc = objWord.ActiveDocument ale też bez sukcesu.

Tutaj kody:

działające macro po całości walące HTML

Sub MailTSO()

    Dim Rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim shift As String
    Dim SDATE As Date
    Dim x As Integer
    Dim mailCC As String
    Dim text As String

    'text = ""
    'mailCC = ""

    shift = Sheets("Wash").Range("G3")

    If shift = "DAY" Then
    SDATE = Date
    Else
    SDATE = Date - 1
    End If

    Set Rng = Sheets("Wash").Range("B2:O183")

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    Sciezka = ActiveWorkbook.Path
    With OutMail
        .to = ""
        .CC = ""
        .BCC = ""
        .Subject = "Raport" & SDATE & " " & shift
        .HTMLBody = RangetoHTML(Rng)
        .Display
    End With
    On Error GoTo 0

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

    Set OutMail = Nothing
    Set OutApp = Nothing

End Sub

Function RangetoHTML(Rng As Range)

    Dim FSO As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    Rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set ts = FSO.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    TempWB.Close SaveChanges:=False

    Kill TempFile

    Set ts = Nothing
    Set FSO = Nothing
    Set TempWB = Nothing
End Function

Drugie macro wrzucający newralgiczny element jako obrazek:

Sub send_email_with_table_as_pic()

Dim OutApp As Object
Dim table As Range
Dim pic As Picture
Dim ws As Worksheet
Dim wordDoc

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

'grab table, convert to image, and cut
Set ws = ThisWorkbook.Sheets("Wash")
Set table = ws.Range("C2:N180")
ws.Activate
table.Copy
Set pic = ws.Pictures.Paste
pic.Cut

'create email message
On Error Resume Next
    With OutMail
        .to = ""
        .CC = ""
        .BCC = ""
        .Subject = "" & Format(Date, "mm-dd-yy")
        .Display

        Set wordDoc = OutMail.GetInspector.WordEditor
            With wordDoc.Range
                .PasteandFormat wdChartPicture
            End With

    End With
    On Error GoTo 0

Set OutApp = Nothing
Set OutMail = Nothing

End Sub

[rrobot]

@Miedzcu: wrzuciles do chatgpt?

[Miedzcu]

@rrobot: Dzięki za odpowiedź. Tak wrzuciłem wspomniałem o tym w mojej przydługawej wiadomości:

Chat GPT zaproponował mi kompilacje obu dwóch kodów w jeden ale z niepowodzeniem. Radził też posłużeniem się komendą Set wordDoc = objWord.ActiveDocument ale też bez sukcesu.

To co zaproponował:

Sub MailTSOwithPic()

    Dim Rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim shift As String
    Dim SDATE As Date
    Dim x As Integer
    Dim mailCC As

[53845714N]

@Miedzcu: poproś chat gpt żeby zmodyfikował ten pierwszy kod który wkleiłeś, żeby formatowanie warunkowe przed wysłaniem wiadomości zostało zamienione na statyczne, wtedy będziesz miał chyba to czego szukasz. Nie zapomnij tylko żeby tworzyć przed wysłaniem wiadomości kopii arkusza i na niej dokonywać zmian z formatowania warunkowego na statyczne bo tych zmian już nie cofniesz, a po wysłaniu wiadomości ten skopiowany arkusz należy usunąć.

https://stackoverflow.com/questions/4692918/make-conditional-formatting-static

[brak_nicku]

@Miedzcu: jeśli w drugim (oryginalnym) kodzie dodasz po wklejeniu:

.InlineShapes(1).ScaleHeight = 100

To wklejony obraz będzie miał wielkość zgodną z oryginałem (100%).