Problem z Polskimi znakami w mailu z VBA

[JaJakub]

Witam,

Mam problem z polskimi znakami przy wysyłaniu maila przy pomocy makra w Excelu 365 przy wykorzystaniu Outlooka.

Dzieñ dobry,
Proszê o potwierdzenie i realizacjê:

Dzieje się to tylko przy konkretnej maszynie (win 7), na innym działa dobrze. Dodatkowo znaki psują się tylko gdy email jest ściągany z arkusza. Gdy wpiszę go na sztywno wszystko działa.

Kod odpowiedzialny za sczytywanie maili z arkusza:

Kod: Zaznacz cały

    Dim strSentTo As Variant

    strSentTo = Array(Cells(i, "Z").Value, Cells(i, "AA").Value)
    (...)

Kod odpowiedzialny za wysyłanie:

Kod: Zaznacz cały

      (...)
      Dim OutlookApp As Outlook.Application
      Dim OutlookMail As Outlook.MailItem

      Set OutlookApp = New Outlook.Application
      Set OutlookMail = OutlookApp.CreateItem(olMailItem)

      StringVal = Join(strSentTo, ";")

      With OutlookMail
      
      .BodyFormat = olFormatHTML
      .Body = strBody
      .To = StringVal
      .Subject = zzamkniete & tytul
      .Send
      End With



Jeżeli zamiast ".To = StringVal" będę miał ".To =" to wszystko jest dobrze. Ale sczytanie tego samego z komórek rozwala formatowanie maila. Sprawdziłem i nie ma na to wpływu ".BodyFormat", ani też przerobienie treści do ".HTMLBody". Sprawdziłem też język systemu i Excela, w obu przypadkach jest polski i formatowanie komórek z mailami jest ustawione jako Tekst.
Jestem generalnie początkującym w tworzeniu makr i VB (chociaż nie początkującym programistą ogólnie).

[OShon]

Zmień:

Kod: Zaznacz cały

.Body = strBody

na:

Kod: Zaznacz cały

.HTMLBody = strBody

Dlatego że jak dasz zwykłe doby to nie ma sensu walić kod HTML do body.
Poza tym widzę błąd w funkcji join - ja bym to zrobił tak:

Kod: Zaznacz cały

Dim r As Range: Set r = Range(Cells(i, "A"), Cells(i, "g"))
    For Each d In r
      s = s & d.Value & ";"
    Next
    StringVal = s

No i teraz o jakich polskich znakach piszesz - adresy nie mają polskich znaków i nieć nie powinny.

[JaJakub]

Zmień:

Kod: Zaznacz cały

.Body = strBody

na:

Kod: Zaznacz cały

.HTMLBody = strBody

Dlatego że jak dasz zwykłe doby to nie ma sensu walić kod HTML do body.

Rozumiem, powinienem mieć:
.BodyFormat = olFormatPlain
Ale nie rozwiązuje to problemu.

Poza tym widzę błąd w funkcji join - ja bym to zrobił tak:

Kod: Zaznacz cały

Dim r As Range: Set r = Range(Cells(i, "A"), Cells(i, "g"))
    For Each d In r
      s = s & d.Value & ";"
    Next
    StringVal = s

Nie rozumiem, ten kod wygląda jak rozwinięcie tego co powinien robić Join. Po co to robić, skoro mamy dedykowaną funkcję. Czy może ze wczytywaniem, tak jak ja mam to zrobione jest coś nie tak?
Ta linia:
(strSentTo = Array(Cells(i, "Z").Value, Cells(i, "AA").Value))

No i teraz o jakich polskich znakach piszesz - adresy nie mają polskich znaków i nieć nie powinny.

Tak, oczywiście nie mają, ale to jest najciekawsze, że sama treść maila traci polskie znaki (zastępowane są "krzaczkami" ñ곿æ) jeżeli adres mailowy jest pobrany z arkusza. Gdy wpiszę natomiast na sztywno (.To = AdresatMaila), to wszystko jest w porządku. Co ciekawe dzieję się tak tylko na jednym konkretnym komputerze (z win7), a na innych jest dobrze.

[OShon]

A skąd bierzesz treść i jak ona wygląda.
Jak czytasz go z pliku, to podejrzewam że jest on innego standard niż Outlook czyli nie 1250/ANSI ale UTF8 i to powoduje zamianę polskich literek na krzaki.
Jeśli czytał być z arkusza Excela, to nie ma żadnej konwersji i krzaków być nie powinno, a jak tak jest to pokaz, bo w twoim kodzie tylko zmienna.

Moim zdaniem adres email nie ma wpływu na kształt treści body maila, przynajmniej była by to sytuacja z jaką prze 30 lat się nie spotkałem.

[JaJakub]

Nie chciałem wysyłać całego makro, bo jest dosyć długie i wydawało mi się, że problem jest w tym co opisałem.

Kod: Zaznacz cały

Sub wyslij_zamowienie()
   
    Dim objNotesSession As Object
    Dim objNotesMailFile As Object
    Dim objNotesDocument As Object
    Dim strSentTo As Variant
    Dim tytul As Variant
    Dim tresc As Variant
    Dim strTmpPath As String
    Dim strAttName As String
    Dim strBody As String
    Dim zzamkniete As String
    Dim i As Integer
    Dim j As Integer
    Dim tablica(12) As String
    Dim Data As Date
    Dim StringVal As String
   
Sheets("historia zamowien").Select
    Rows("1:1").Select
    Selection.AutoFilter
     
     
Sheets("wykaz referencji").Select
   
ostatni = Range("A65536").End(xlUp).Row 'pobranie indeksu ostatniej komórki w danej kolumnie
tresc = ""

For i = 3 To ostatni   'wchodzi w pierwszą 1 od góry
    If Cells(i, "A") = 1 Then
        trescglowna = ""
        strSentTo = Array(Cells(i, "Z").Value, Cells(i, "AA").Value)
        tytul = "Zamówienie z **** dla dostawcy " & Cells(i, "D").Value
       
               
        For n = i To ostatni 'pobiera wszyskie 1 dla danego dostawcy
            If Cells(n, "A") = 1 And Cells(n, "D") = Cells(i, "D").Value Then
           
            Cells(n, "AK") = Cells(n, "AI")
            Cells(n, "AL") = Cells(n, "AJ")
                       
            Cells(n, "AI") = Cells(n, "AG")
            Cells(n, "AJ") = Cells(n, "AH")
       
            Cells(n, "AG") = Cells(n, "Y")
            Cells(n, "AH") = Cells(n, "M")
           
           
                tresc = Cells(n, "X").Value & Cells(n, "Y").Value
                trescglowna = trescglowna + vbNewLine + tresc
                j = 1
                tablica(j) = Cells(n, "B")
                j = j + 1
                tablica(j) = Cells(n, "C")
                j = j + 1
                tablica(j) = Cells(n, "D")
                j = j + 1
                tablica(j) = Cells(n, "M")
                j = j + 1
                tablica(j) = Cells(n, "L")
                j = j + 1
                tablica(j) = Date
                j = j + 1
                Data = Cells(i, "Y")
                'tablica(j) = Cells(n, "Y")
                'j = j + 1
                'tablica(j) = Cells(i, "X")  / tresc zamowienia
                j = j + 1
                tablica(j) = Cells(n, "Z")
                j = j + 1
                tablica(j) = Cells(n, "AA")
                Sheets("historia zamowien").Select
                ost_wiersz_spisu = Range("A65536").End(xlUp).Row + 1
                For j = 1 To 11
                    Cells(ost_wiersz_spisu, j).Value = tablica(j)
                    Cells(ost_wiersz_spisu, 6).Value = Date
                    Cells(ost_wiersz_spisu, 7).Value = Data
                Next
                Sheets("wykaz referencji").Select
                Cells(n, "A") = 0
            End If
        Next
                zzamkniete = ""
                strBody = "Dzień dobry," _
                & vbNewLine & vbNewLine _
                & "Proszę o potwierdzenie i realizację:" _
                & vbNewLine & vbNewLine _
                & zzamkniete & trescglowna _
                & vbNewLine & vbNewLine _
                & "Proszę o umieszczanie na fakturach numeru W-Z zamawianego towaru." _
                & vbNewLine & vbNewLine _
                & "Brak tej informacji wydłuża czas obiegu faktury, a tym samym może przyczynić się do opóźnienia płatności." _
            
            '(...)

                             
                If Cells(i, "U") = "Z" Then
                    Range("B" & i, "C" & i).Copy
                    MsgBox "Referencja: " & Cells(i, "B") & " " & Cells(i, "C") & vbNewLine _
                    & "Data dostawy: " & Cells(i, "Y") & vbNewLine _
                    & "Ilość: " & Cells(i, "M") & Cells(i, "L") & vbNewLine _
                    & "Dostawca: " & Cells(i, "D"), , "Stwórz DA w SACHA"
                    zzamkniete = InputBox("Podaj numer DA", "Numer DA")
                    zzamkniete = "Nr DA: " & zzamkniete & "- "
                End If
               
                Dim OutlookApp As Outlook.Application
                Dim OutlookMail As Outlook.MailItem
       
                Set OutlookApp = New Outlook.Application
                Set OutlookMail = OutlookApp.CreateItem(olMailItem)
       
                StringVal = Join(strSentTo, ";")
       
                With OutlookMail
                .BodyFormat = olFormatPlain
                .Body = strBody
                .To = StringVal
                .Subject = zzamkniete & tytul
                .Send

                End With
            MsgBox tytul & vbNewLine & trescglowna & vbNewLine & "Zostało wysłane"
    End If
Next
Sheets("wykaz referencji").Range("a3:A65536") = ""
ActiveWorkbook.Save
End Sub

[OShon]

Nic takiego ciekawego i podejrzanego u ciebie nie widzę.
Dane zbierane są z Excela (nie z jakiś innych plików o formatach mu nieznanych)
Odpal ten kod [F5] i powiedz czy widzisz poprawnie literki:

Kod: Zaznacz cały

Sub test_tresci()
Dim trescglowna$: trescglowna = "jakas treść którą nie chcesz pokazać"
Dim strBody$: strBody = "Dzień dobry," _
                & vbNewLine & vbNewLine _
                & "Proszę o potwierdzenie i realizację:" _
                & vbNewLine & vbNewLine _
                & zzamkniete & trescglowna _
                & vbNewLine & vbNewLine _
                & "Proszę o umieszczanie na fakturach numeru W-Z zamawianego towaru." _
                & vbNewLine & vbNewLine _
                & "Brak tej informacji wydłuża czas obiegu faktury, a tym samym może przyczynić się do opóźnienia płatności."

Dim OutlookApp As Outlook.Application:    Set OutlookApp = New Outlook.Application
Dim OutlookMail As Outlook.MailItem:      Set OutlookMail = OutlookApp.CreateItem(olMailItem)
               
With OutlookMail
      .To = "jakismail@a.pl"
      .Subject = "temat"
      .HTMLBody = Replace(strBody, vbNewLine, "<br>")
      .Display
End With
End Sub

Potem podmień adres przyporządkowany do adresata na wynik pętli jaki napisałem i znowu przetestuj.
Powinny się podłączyć te z komórek. Jeśli poprawnie to szukanie wymaga dalszej uwagi, a treść jak i adresy są poza podejrzeniem.

[JaJakub]

Zrobiłem tak:
Stworzyłem nowy plik Excel i stworzyłem w nim dwa przyciski jeden z takim makro:

Kod: Zaznacz cały

Sub test_tresci1()
Dim strBody$: strBody = "Dość gróźb fuzją, klnę, pych i małżeństw! jeden"

Dim OutlookApp As Outlook.Application:    Set OutlookApp = New Outlook.Application
Dim OutlookMail As Outlook.MailItem:      Set OutlookMail = OutlookApp.CreateItem(olMailItem)
               
With OutlookMail
      .To = "jakub.witonski@hutchinson.com"
      .Subject = "testuTestu"
      .HTMLBody = Replace(strBody, vbNewLine, "<br>")
      .Display
      .Send
End With
End Sub

Drugi z takim makro:

Kod: Zaznacz cały

Sub test_tresci2()
Dim strBody$: strBody = "Dość gróźb fuzją, klnę, pych i małżeństw! dwa"

Dim OutlookApp As Outlook.Application:    Set OutlookApp = New Outlook.Application
Dim OutlookMail As Outlook.MailItem:      Set OutlookMail = OutlookApp.CreateItem(olMailItem)
Dim stringVal As String
Dim adress(0 To 1) As String

adress(0) = Range("A1").Value
adress(1) = Range("A2").Value

stringVal = Join(adress, ";")

With OutlookMail
      .To = stringVal
      .Subject = "testuTestu"
      .HTMLBody = Replace(strBody, vbNewLine, "<br>")
      .Display
      .Send
End With
End Sub


Oto treść pierwszego maila:

Dość gróźb fuzją, klnę, pych i małżeństw! jeden

A to treść drugiego maila:

Doœæ gróŸb fuzj¹, klnê, pych i ma³¿eñstw! dwa

Oczywiście dzieje się tak tylko na tym felernym komputerze z win 7.

[OShon]

Ok no to skupmy się nad tym złym efektem końcowym.
Zamiast Joina nad którym się upierasz

Kod: Zaznacz cały

adress(0) = Range("A1").Value
adress(1) = Range("A2").Value

stringVal = Join(adress, ";")

wrzuć pętlę jaką ci napisałem pow.

Kod: Zaznacz cały

Dim r As Range: Set r = Range(Cells(1, "A"), Cells(2, "A"))
    For Each d In r
      s = s & d.Value & ";"
    Next
    StringVal = s

[JaJakub]

Sprawdziłem taki kod:

Kod: Zaznacz cały

Sub test_tresci2()
Dim strBody$: strBody = "Dość gróźb fuzją, klnę, pych i małżeństw! dwa"

Dim OutlookApp As Outlook.Application:    Set OutlookApp = New Outlook.Application
Dim OutlookMail As Outlook.MailItem:      Set OutlookMail = OutlookApp.CreateItem(olMailItem)
Dim arTesting As Variant
Dim stringVal As String
Dim adress(0 To 1) As String

Dim r As Range: Set r = Range(Cells(1, "A"), Cells(2, "A"))
    For Each d In r
      s = s & d.Value & ";"
    Next
    stringVal = s

With OutlookMail
      .To = stringVal
      .Subject = "testuTestu"
      .HTMLBody = Replace(strBody, vbNewLine, "<br>")
      .Display
      .Send
End With
End Sub

Daje takie rezultaty:

Doœæ gróŸb fuzj¹, klnê, pych i ma³¿eñstw! dwa

Ale sprawdziłem jeszcze w ten sposób:

Kod: Zaznacz cały

Sub test_tresci2()
Dim strBody$: strBody = "Dość gróźb fuzją, klnę, pych i małżeństw! dwa"

Dim OutlookApp As Outlook.Application:    Set OutlookApp = New Outlook.Application
Dim OutlookMail As Outlook.MailItem:      Set OutlookMail = OutlookApp.CreateItem(olMailItem)
Dim stringVal As String
Dim adress(0 To 1) As String

adress(0) = Range("A1").Value
'adress(1) = Range("A2").Value

'stringVal = Join(adress, ";")
stringVal = adress(0)

With OutlookMail
      .To = stringVal
      .Subject = "testuTestu"
      .HTMLBody = Replace(strBody, vbNewLine, "<br>")
      .Display
      .Send
End With
End Sub


I dostałem:

Dość gróźb fuzją, klnę, pych i małżeństw! dwa

Więc okazuje się, że formatowanie wywala wrzucenie więcej niż jednego odbiorcy wiadomości, a nie sczytanie ich z komórek czy funkcja Join.

[JaJakub]

Nie, jednak nie, spróbowałem poprzedni kod tj.:

Kod: Zaznacz cały

Sub test_tresci2()
Dim strBody$: strBody = "Dość gróźb fuzją, klnę, pych i małżeństw! dwa"

Dim OutlookApp As Outlook.Application:    Set OutlookApp = New Outlook.Application
Dim OutlookMail As Outlook.MailItem:      Set OutlookMail = OutlookApp.CreateItem(olMailItem)
Dim stringVal As String
Dim adress(0 To 1) As String

adress(0) = Range("A1").Value
adress(1) = Range("A2").Value

stringVal = Join(adress, ";")

With OutlookMail
      .To = stringVal
      .Subject = "testuTestu"
      .HTMLBody = Replace(strBody, vbNewLine, "<br>")
      .Display
      .Send
End With
End Sub

Z wyczyszczoną komórką A2 i mam to samo:

Doœæ gróŸb fuzj¹, klnê, pych i ma³¿eñstw! dwa

Może... nie wiem, średnik w adresatach?

[OShon]

Średnik w adresach jest po to aby zaznaczyć że strong należy podzielić na części ponieważ są to pojedyncze adresy email.
Bardzo dziwna przypadłość - nie spotkałem się z tym aby adresat (wiele adresatów) powoduje zmianę treści body.

ok a zrób w takim razie pobranie jedynie z jednej komórki.
ale w tej komorę zrób konkatenacje przy użyciu znaku & albo formuły złącz.teksty() dodając oczywiście ";"

[JaJakub]

W sensie do np. A3 mam wpisać:

=A1 & ";" & A2

I w makro np. w ten sposób:

Kod: Zaznacz cały

Sub test_tresci2()
Dim strBody$: strBody = "Dość gróźb fuzją, klnę, pych i małżeństw! dwa"

Dim OutlookApp As Outlook.Application:    Set OutlookApp = New Outlook.Application
Dim OutlookMail As Outlook.MailItem:      Set OutlookMail = OutlookApp.CreateItem(olMailItem)
Dim stringVal As String
Dim adress(0 To 1) As String

adress(0) = Range("A3").Value
stringVal = adress(0)

With OutlookMail
      .To = stringVal
      .Subject = "testuTestu"
      .HTMLBody = Replace(strBody, vbNewLine, "<br>")
      .Display
      .Send
End With
End Sub

Dostaje wtedy:

Doœæ gróŸb fuzj¹, klnê, pych i ma³¿eñstw! dwa

Wygląda na to, że to naprawdę ten średnik.

[JaJakub]

Spróbowałem jeszcze zkomentować .Send i dać " " zamiast ";"

Kod: Zaznacz cały

Sub test_tresci2()
Dim strBody$: strBody = "Dość gróźb fuzją, klnę, pych i małżeństw! dwa"

Dim OutlookApp As Outlook.Application:    Set OutlookApp = New Outlook.Application
Dim OutlookMail As Outlook.MailItem:      Set OutlookMail = OutlookApp.CreateItem(olMailItem)
Dim stringVal As String
Dim adress(0 To 1) As String

adress(0) = Range("A1").Value
adress(1) = Range("A2").Value

stringVal = Join(adress, " ")

With OutlookMail
      .To = stringVal
      .Subject = "testuTestu"
      .HTMLBody = Replace(strBody, vbNewLine, "<br>")
      .Display
      '.Send
End With
End Sub

Pomyślałem, że wystarczy uzupełniać adresatów o ";", ale niestety nie i teść z automatu jest:

Doœæ gróŸb fuzj¹, klnê, pych i ma³¿eñstw! dwa

[OShon]

No to jeszcze inaczej, choc podejrzewam że się coś temu Outlookowi odkleiło i nie działa prawidłowo.
Zamiast adresowania .to dodaj na końcu już bez twojego Joina

Kod: Zaznacz cały

Dim strBody$: strBody = "Dość gróźb fuzją, klnę, pych i małżeństw! dwa"
Dim OutlookApp As Outlook.Application:    Set OutlookApp = New Outlook.Application
Dim OutlookMail As Outlook.MailItem:      Set OutlookMail = OutlookApp.CreateItem(olMailItem)
Dim recip as object: Set recip = OutlookMail.Recipients

With OutlookMail
      '''''''''''tego nie dajemy .To = stringVal
      .Subject = "testuTestu"
      .HTMLBody = Replace(strBody, vbNewLine, "<br>")
'i teraz w pętli dodanie adresów do kolekcji
      Dim r As Range: Set r = Range(Cells(1, "A"), Cells(2, "A")) 'adresy z komórek A1:A2
          For Each d In r
            recip.add d.Value
          Next
      recip.ResolveAll     
      .Display
      '''''''' no to albo wysyłanie albo pokazywanie bo razem to po co? .Send
End With
End Sub

[JaJakub]

No i ponownie mamy:

Doœæ gróŸb fuzj¹, klnê, pych i ma³¿eñstw! dwa

[OShon]

No to coś sie pierniczy w samym Outlooku.
Sorry - naprawa albo reinstalka.
magiczne sztuczki sie już skończyły.