[VBA]Makro tworzace nowa wiadomosc w outlooku

Pytania, uwagi, problemy związane z Microsoft Office Outlook, wersje 2007, 2010, 2013 i 2016.

Moderator: Moderatorzy

[VBA]Makro tworzace nowa wiadomosc w outlooku

Postprzez keizel » Pn 23.07.2012 14:13

Otóż znalazłem gdzieś na internecie Makro do exela które po uruchomieniu tworzy mi nowa wiadomosc w outloku, wstawia podanych adresatów, tytuł wiadomości łaczy mi z komorek B5 i D5 z exela a problem moj polega ze nie wiem jak w pole tresci wiadomosci wkleic tabele z zakresu komorek od d5 do h5 (obecnie wstawia zawartośc jednej komórki). Jeszcze fajnie by było jak by wyskoczyło pole z zapytaniem numeru wiersza jaki ma wkleic czyli jak wpisze ze wiersz 7 wkleja mi od D7 do H7, jak wpisze ze wiersz 28 to wkleja D28 do H28 czyli zakres kolumn jest stały a zmienia sie tylko numer wiersza.
Jakieś propozycje nad rozwiązaniem ????
Kodzik makra poniżej..

Kod: Zaznacz cały
Option Explicit


Private Declare Function ShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long






Sub wyslij_wiadomosc_mailto()


    'deklaracje zmiennych
    Dim sAdresat As String
    Dim sTytul As String
    Dim sTresc As String
    Dim sPolecenie As String 'polecenie wykonane w powloce Shell Windows

    'definicje zmiennych
    sAdresat = "kurs_excel_212@bardzki.pl"
    sTytul = Arkusz1.Range("b5").Value & "| " & Arkusz1.Range("d5").Value
    sTresc = Arkusz1.Range("A10")



    'zamiana " " na "%20"
    sTytul = Application.WorksheetFunction.Substitute(sTytul, " ", "%20")
    sTresc = Application.WorksheetFunction.Substitute(sTresc, " ", "%20")

    'zamiana vbCrFf na %0D%0A
     sTresc = Application.WorksheetFunction.Substitute(sTresc, vbCrLf, "%0D%0A")

    'tworzenie polecenia
    sPolecenie = "mailto:" & sAdresat & "?subject=" & sTytul & "&body=" & sTresc

    'wykonanie polecenia
    ShellExecute 0&, vbNullString, sPolecenie, vbNullString, vbNullString, vbNormalFocus

    'Pauza na otwarcie okna z tworzona wiadomoscia
     Application.Wait (Now + TimeValue("0:00:01"))

    'wyslanie skrotu klawiaturowego wysylajacego wiadomosc
    'Ms Outlook --> Ctrl-Return (Ctrl-Enter)
    'Application.SendKeys "^{Return}"

End Sub 'wyslij_wiadomosc_mailto()
keizel
 
Posty: 33
Dołączył(a): Cz 08.12.2011 18:43

Re: [VBA]Makro tworzace nowa wiadomosc w outlooku

Postprzez OShon » Pn 23.07.2012 16:01

Poniżej masz kod jakie jest odpowiedzią na brak Outlooka w systemie - a wysyłanie wiadomości np pop przez Outlooka Expressa lub inny nieprogramowalny program pocztowy.

Jeśli ci on odpowiada ok - natomiast posiadają Outlooka z Pakietu Office mamy do dyspozycji mnóstwo innych elementów jakie można wykorzystać lub co do jakich można się odwołać tworząc kod.

Niemniej jednak linijkę:
Kod: Zaznacz cały
sTytul = Arkusz1.Range("b5").Value & "| " & Arkusz1.Range("d5").Value

można zamienić na
Kod: Zaznacz cały
dim a: a = inputbox("podaj nr linii jaki ma być pobrany to tematu", "Zapytanie","")
if isnumeric(a) = false then msgbox"Nie podano nr wiersza (liczby)", vbcritical, "informacja o błędzie": exit sub
dim x&
for x = 4 to 8
   sTytul = sTytul & Arkusz1.cells(a,x) & " "
next x
Obrazek
Oskar Shon - MVP Office System/Development 11/19, 3x MCC
Forum moderator: Outlook.pl | ExcelForum.pl | MSDN dział VBA
Zobacz fajne dodatki: Outlooka, Excela, Worda lub PowerPointa
OShon
 
Posty: 9497
Dołączył(a): Cz 19.10.2006 08:31
Lokalizacja: Veracomp SA, VBATools.pl

Re: [VBA]Makro tworzace nowa wiadomosc w outlooku

Postprzez keizel » Pn 23.07.2012 16:41

Wszystko działa super , tylko jest jedno ale:
zaznaczony obszar któremu podaje numer wiersza to tabelka a on mi w pole wiadomosci nie wkleja tabelki, tylko wartosci z wszystkich komorek z podanego zakresu, jest opcja aby to działało cos w stylu kopiuj wklej , tak jak robie do tej pory, wtedy jest zachwane formatowanie i wstawia mi to w formie tabeli??
keizel
 
Posty: 33
Dołączył(a): Cz 08.12.2011 18:43

Re: [VBA]Makro tworzace nowa wiadomosc w outlooku

Postprzez keizel » Wt 24.07.2012 09:00

Oshon
Mam prośbe, znalazłem inne makro które tez tworzy mi wiadomosc w Ms outlooku, z tym ze nie wiem jak polaczyc to z ta twoja funkconalnościa ktor ami napisałes z tym wyborem wiersza.

Tutaj kodzik tego makra
Kod: Zaznacz cały
Sub Mail_TG()

temat = Range("C4")
    adresat = Range("C2")
    adresat_2 = Range("C3")

    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object

    Set rng = Nothing
    On Error Resume Next
   
   

[b]Set rng = Sheets("RIR").Range("b6:d100").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0[/b]

    If rng Is Nothing Then
        MsgBox "Wystapił błąd" & _
               vbNewLine & "Proszę porpawić i spróbować ponownie.", vbOKOnly
        Exit Sub
    End If

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

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

    On Error Resume Next
    With OutMail
        .To = adresat
        .CC = adresat_2
        .BCC = ""
        .Subject = temat
        .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


z tym ze tutaj w tresc wiadomosci ma przekopiowac zakres od b6:d100, a ja chciałbym aby wygladadało to tak jak ty mi to zrobiłes ze podaje numer wiersza i stały zakres kolumn , czyli ten kodzik
Kod: Zaznacz cały
    Dim a: a = InputBox("podaj nr linii jaki ma być pobrany to tematu", "Zapytanie", "")
If IsNumeric(a) = False Then MsgBox "Nie podano nr wiersza (liczby)", vbCritical, "informacja o błędzie": Exit Sub
Dim x&
For x = 1 To 10
   sTresc = sTresc & Arkusz1.Cells(a, x) & " "
Next x
keizel
 
Posty: 33
Dołączył(a): Cz 08.12.2011 18:43

Re: [VBA]Makro tworzace nowa wiadomosc w outlooku

Postprzez OShon » Wt 24.07.2012 09:02

Na razie zajmowaliśmy się tematem a nie treścią wiadomości.
Niestety na poziomie tego kody (uniwersalnego klienta), jak wcześniej napisałem, mamy ograniczone możliwości.

Sprawdź forum i zobacz jak zbudowany jest kod pod Outlooka (o ile masz Outlooka z pakietu Office)
W nim można pobierać dane wraz z formatowaniem.

Pomocne w szukaniu będzie polecenie kluczowe CreateItem(0)
Dodatkowo dla skopiowania zakresu kieruj się kodem Rona
Właściwa dla ciebie procedura nazywa się Mail_Sheet_Outlook_Body()

Po małych przeróbkach (użyj kod jaki napisałem pow.) osiągniesz zakładany cel.
Obrazek
Oskar Shon - MVP Office System/Development 11/19, 3x MCC
Forum moderator: Outlook.pl | ExcelForum.pl | MSDN dział VBA
Zobacz fajne dodatki: Outlooka, Excela, Worda lub PowerPointa
OShon
 
Posty: 9497
Dołączył(a): Cz 19.10.2006 08:31
Lokalizacja: Veracomp SA, VBATools.pl

Re: [VBA]Makro tworzace nowa wiadomosc w outlooku

Postprzez keizel » Wt 24.07.2012 09:11

Ja cały czas pisałem o treści
a problem moj polega ze nie wiem jak w pole tresci wiadomosci wkleic tabele z zakresu komorek od d5 do h5 (obecnie wstawia zawartośc jednej komórki). Jeszcze fajnie by było jak by wyskoczyło pole z zapytaniem numeru wiersza jaki ma wkleic czyli jak wpisze ze wiersz 7 wkleja mi od D7 do H7, jak wpisze ze wiersz 28 to wkleja D28 do H28 czyli zakres kolumn jest stały a zmienia sie tylko numer wiersza.


Prośba moja abys tylko jakoś wkleił ta funkcjonalność z wyborem tego wiersza do tego makra co wkleiłem prze chwilai beidze super pieknie, bo niestety wszedzie jest jakis stały zakres a tutaj to co ty mi podales jest mozliwosc wyboru wiersza na czym mi zalezy
keizel
 
Posty: 33
Dołączył(a): Cz 08.12.2011 18:43

Re: [VBA]Makro tworzace nowa wiadomosc w outlooku

Postprzez OShon » Wt 24.07.2012 10:19

Zasugerowałem sie twoim pierwszym kodem - nie zauważyłem ze podałeś już drugi - pod Outlooka Office
Ok modyfikacja nie jest ciężka - wystarczy zamiast zadeklarowanego rng wpisać ten, który masz w linijce jaką podałem.

Oto cały kod do modułu:
Kod: Zaznacz cały
Option Explicit

Sub Mail_TG()
Dim adresat$, temat$, adresat_2$
temat = Range("C4")
    adresat = Range("C2")
    adresat_2 = Range("C3")

    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object

    Set rng = Nothing
    On Error Resume Next
   
Dim a: a = InputBox("podaj nr wiersza jaki ma być pobrany to tematu", "Zapytanie", "")
If IsNumeric(a) = False Then MsgBox "Nie podano nr wiersza (liczby)", vbCritical, "informacja o błędzie": Exit Sub

With Sheets("RIR")
    Set rng = .Range(.Cells(a, "d"), .Cells(a, "h"))
    'Set rng = .Range("b6:d100").SpecialCells(xlCellTypeVisible) 'co było
End With
    On Error GoTo 0

    If rng Is Nothing Then
        MsgBox "Wystapił błąd" & _
               vbNewLine & "Proszę porpawić i spróbować ponownie.", vbOKOnly
        Exit Sub
    End If

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

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

    On Error Resume Next
    With OutMail
        .To = adresat
        .CC = adresat_2
        .BCC = ""
        .Subject = temat
        .HTMLBody = RangetoHTML(rng)
        .Display '.send 'jak chcesz wysłąć
    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
Obrazek
Oskar Shon - MVP Office System/Development 11/19, 3x MCC
Forum moderator: Outlook.pl | ExcelForum.pl | MSDN dział VBA
Zobacz fajne dodatki: Outlooka, Excela, Worda lub PowerPointa
OShon
 
Posty: 9497
Dołączył(a): Cz 19.10.2006 08:31
Lokalizacja: Veracomp SA, VBATools.pl

Re: [VBA]Makro tworzace nowa wiadomosc w outlooku

Postprzez keizel » Wt 24.07.2012 11:18

Oshon Dzieki wielkie, własnie o to mi chodziło-super
keizel
 
Posty: 33
Dołączył(a): Cz 08.12.2011 18:43

Re: [VBA]Makro tworzace nowa wiadomosc w outlooku

Postprzez keizel » Wt 24.07.2012 13:19

A podpowiesz jeszcze jak dodać jakis stały podpis, czyli po tej tabeli która wklei dac jaksi enter i cos w stylu " Pozdrawiam
Artur"
Mam na mysli stały tekst

Oraz in tersowało by mnie tez aby w polu TEMAT rowniez wklejal mi ten wiersz który podaje w polu jakie mnie pyta, czyli np podam numer wiersza 100 to polu temat ma mi wstawic to co jest wpisane w kolumnie b100
keizel
 
Posty: 33
Dołączył(a): Cz 08.12.2011 18:43

Re: [VBA]Makro tworzace nowa wiadomosc w outlooku

Postprzez OShon » Wt 24.07.2012 14:07

Podpis zamiast:
Kod: Zaznacz cały
.HTMLBody = RangetoHTML(rng)

wpisz w języku html:
Kod: Zaznacz cały
const podpis$ = "<br/> moje imie lub co tam chcesz"
.HTMLBody = RangetoHTML(rng) & podpis


Temat zamiast:
Kod: Zaznacz cały
temat = Range("C4")

wpisz po moim kawałku kodu (przed end with):
Kod: Zaznacz cały
temat = .Cells(a, "b")
Obrazek
Oskar Shon - MVP Office System/Development 11/19, 3x MCC
Forum moderator: Outlook.pl | ExcelForum.pl | MSDN dział VBA
Zobacz fajne dodatki: Outlooka, Excela, Worda lub PowerPointa
OShon
 
Posty: 9497
Dołączył(a): Cz 19.10.2006 08:31
Lokalizacja: Veracomp SA, VBATools.pl

Re: [VBA]Makro tworzace nowa wiadomosc w outlooku

Postprzez karolskolasinski » Pn 12.02.2018 13:33

Cześć,
Makro z pierwszego posta dobrze działa, bo wstawia stopkę do wiadomości, ale chciałbym aby jeszcze dodawało załączniki
    z określonej (zmiennej) lokalizacji. To znaczy, że jeżeli odpalę makro dzisiaj to załączy wszystkie pliki ze ścieżki: U:\Zdjęcia\2018\02\12
    oraz jeden ze stałej lokalizacji, ale ze zmienną nazwą tzn. podsumowanie dnia__12.02.2018.xlsx

Natomiast w treści wklei zawartość skopiowaną w schowku.

Czy mógłby ktoś pomóc?
karolskolasinski
 
Posty: 2
Dołączył(a): Pn 12.02.2018 13:25

Re: [VBA]Makro tworzace nowa wiadomosc w outlooku

Postprzez OShon » Pn 12.02.2018 14:36

Aleś 6-cioletniego suchara odgrzebał.
wszystkie pliki ze ścieżki: U:\Zdjęcia\2018\02\12

Musisz zatem napisać pętlę po plikach - polecam FSO, ale prostsza Dir też ujdzie.
oraz jeden ze stałej lokalizacji, ale ze zmienną nazwą tzn. podsumowanie dnia__12.02.2018.xlsx

Z tym to gorzej, bo albo będziesz znał jak się nazywa (czyli dat dzisiejsza, a jutro data jak jutro (jutrzejsza) czyli jutro dzisiejsza) to wszystko ok.
A jak w poniedziałek będziesz chciał piątkową, lub inną bo byłeś na urlopie to już gorzej. Trzeba grzebać np po parametrach utworzenia pliku.
Obrazek
Oskar Shon - MVP Office System/Development 11/19, 3x MCC
Forum moderator: Outlook.pl | ExcelForum.pl | MSDN dział VBA
Zobacz fajne dodatki: Outlooka, Excela, Worda lub PowerPointa
OShon
 
Posty: 9497
Dołączył(a): Cz 19.10.2006 08:31
Lokalizacja: Veracomp SA, VBATools.pl

Re: [VBA]Makro tworzace nowa wiadomosc w outlooku

Postprzez karolskolasinski » Pn 12.02.2018 16:50

[nieaktualne]
Ostatnio edytowano Pn 19.02.2018 20:54 przez karolskolasinski, łącznie edytowano 1 raz
karolskolasinski
 
Posty: 2
Dołączył(a): Pn 12.02.2018 13:25

Re: [VBA]Makro tworzace nowa wiadomosc w outlooku

Postprzez OShon » Pn 12.02.2018 19:21

Karol. Podałem ci słowa klucze.
Powinieneś teraz spróbować spenetrować internet, help jakie jest w developerze, przejść się do księgarni lub do biblioteki i zmierzyć się z tematem.
Bardzo prosto napisać - nie wiem lub nie mam pojęcia, ale z tego nie przybywa intelektu.
Obrazek
Oskar Shon - MVP Office System/Development 11/19, 3x MCC
Forum moderator: Outlook.pl | ExcelForum.pl | MSDN dział VBA
Zobacz fajne dodatki: Outlooka, Excela, Worda lub PowerPointa
OShon
 
Posty: 9497
Dołączył(a): Cz 19.10.2006 08:31
Lokalizacja: Veracomp SA, VBATools.pl


Powrót do Microsoft Outlook 2007 / 2010 / 2013 / 2016

Kto przegląda forum

Użytkownicy przeglądający ten dział: Brak zidentyfikowanych użytkowników i 6 gości