• Úvod
• Excel návod
• Excel šablony
• Nástěnka
• Mobility
• Tipy na výlet
• Galerie
• Fórum

MS Excel

Téma: Makro EMAIL zmena

Zaslal/a Peterrrr 25.7.2014 13:14

Ahoj, potreboval by som zmeniť postup makra nasledovne : teraz je tam definovaný postup, že berie mailovu adresu z riadkov 20,20 a ja potrebujem aby bola pevne stanovená jedna adresa : napr. honzo@gmail.net (problém je v riadku mailADRESA
Vedel by mi niekto poradiť ? ďakujem.

Sub EmailSKLAD()

Dim Resp As Integer
Dim poleADR(9, 1) As String, polozka As Variant
Dim poleZAK(7, 7) As String, mailAdresa As String, polePOPIS(7) As String
Dim text_zpravy As String, P1 As Variant, P2 As Variant
Dim VJ As Object
Set VJ = Worksheets("Vyjadreni")

' ----------------------------------------------------------------------------------
' --- v mailu MUSÍ být nastaveno takové písmo, které má stejnou šířku každého znaku
' --- to je například Courier New, nebo Consolas-----------------------------------
' ----------------------------------------------------------------------------------
' ---jinak bude text mailu rozházený -----------------------------------------------
Resp = MsgBox(prompt:="ANO - zkontrolovat email, NE - bez kontroly, nebo STORNO.", _
Title:="KONTROLA EMAILU PŘED ODESLÁNÍM ?", _
Buttons:=3 + 32)
' -----------------------------------------
' --- načtení potřebných hodnot a adres ---
' -----------------------------------------
With VJ

' ------------------------------------------------------------
mailAdresa = .Cells(20, 20)
' ---------------------------------------------------------
polozka = 0
For pocetPolozek = 37 To 51 Step 2
If .Cells(pocetPolozek, 2) = "" Then Exit For
poleZAK(polozka, 1) = .Cells(pocetPolozek, 2) 'cislo SKP
poleZAK(polozka, 2) = .Cells(pocetPolozek, 4) 'nazev vyrobku
poleZAK(polozka, 3) = .Cells(pocetPolozek, 7) 'počet kusu
poleZAK(polozka, 4) = .Cells(pocetPolozek, 8) 'čísko dan. dokl.
poleZAK(polozka, 5) = .Cells(pocetPolozek, 11) 'způsob vyřízení
poleZAK(polozka, 6) = .Cells(pocetPolozek, 14) 'vyjádření
' --- kontrola počtu reklamací ----------------------
If poleZAK(polozka, 2) = "" And poleZAK(polozka, 3) = "" Then Exit For
polozka = polozka + 1
Next pocetPolozek
polePOPIS(0) = "ČÍSLO VÝROBKU (SKP) "
polePOPIS(1) = "NÁZEV VÝROBKU "
polePOPIS(2) = "POČET KUSŮ "
polePOPIS(3) = "ČÍSLO DAŇ. DOKLADU "
polePOPIS(4) = "ZPŮSOB VYŘÍZENÍ REKLAMACE "
polePOPIS(5) = "VYJÁDŘENÍ "
End With
' --- nastavení stejné délky polí ----------------------------

For P1 = 0 To 7
For P2 = 0 To 7
Do While Len(poleZAK(P1, P2)) < 28
poleZAK(P1, P2) = poleZAK(P1, P2) & " "
Loop
Next P2
Next P1

' -----------------------------------------------
' --- vytvoření vlastního textu mailové zpráy ---
' -----------------------------------------------
' --- CHr(13) = další řádek ------------------

text_zpravy = "Automaticky generovaný email - Informace o nové reklamaci / servisní opravě:" & Chr(13) _
& Chr(13) _
& poleADR(1, 0) & " " & poleADR(1, 1) & Chr(13) _
& poleADR(2, 0) & " " & poleADR(2, 1) & Chr(13) _
& poleADR(3, 0) & " " & poleADR(3, 1) & Chr(13) _
& poleADR(4, 0) & " " & poleADR(4, 1) & Chr(13) _
& poleADR(5, 0) & " " & poleADR(5, 1) & Chr(13) _
& poleADR(7, 0) & " " & poleADR(7, 1) & Chr(13) _
& poleADR(8, 0) & " " & poleADR(8, 1) & Chr(13) _
& Chr(13) _
& poleADR(9, 0) & " " & poleADR(9, 1) & Chr(13) _
& poleADR(0, 0) & " " & poleADR(0, 1) & Chr(13) _
& Chr(13) _
& poleADR(6, 0) & " " & poleADR(6, 1) & Chr(13) _
& Chr(13)

For Z = 0 To polozka - 1
dalsi_text = "---- " & Z + 1 & ". reklamace ------------------------------------------ " & Chr(13) _
& polePOPIS(0) & ": " & poleZAK(Z, 1) & Chr(13) _
& polePOPIS(1) & ": " & poleZAK(Z, 2) & Chr(13) _
& polePOPIS(2) & ": " & poleZAK(Z, 3) & Chr(13) _
& polePOPIS(3) & ": " & poleZAK(Z, 4) & Chr(13) _
& polePOPIS(4) & ": " & poleZAK(Z, 5) & Chr(13) _
& polePOPIS(5) & ": " & poleZAK(Z, 6) & Chr(13) _
& "------------------------------------------------------------ " & Chr(13)
text_zpravy = text_zpravy & dalsi_text
Next Z
' & "Vystavil : "

Select Case Resp
'ano ----------------------------
Case Is = 6
Dim myOutlook As Object
Dim myMailItem As Object
Set OUTLApp = CreateObject("Outlook.Application")
Set OUTLNewMail = OUTLApp.CreateItem(olMailItem)
' pokud se má odeslat i aktivní soubor jako příloha, tak
' fName = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
With OUTLNewMail
' adresát nebo více oddělení čárkou
.To = mailAdresa
' kopie
'.CC = "a@volny.cz"
' předmět mailu
.Subject = "Reklamace " & Worksheets("Vyjadreni").Cells(6, 10)
.Body = text_zpravy
' .Attachments.Add fName
.Display
End With
Set OUTLNewMail = Nothing
Set OUTLApp = Nothing
Set OUTLAttach = Nothing
Set OUTLMess = Nothing
Set OUTLNSpace = Nothing
'NE -------------------------
Case Is = 7
Dim myOutlok As Object
Dim myMailItm As Object
Set OUTLApp = CreateObject("Outlook.Application")
Set OUTLNewMail = OUTLApp.CreateItem(olMailItem)

' pokud se má odeslat i aktivní soubor jako příloha, tak
' fName = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
With OUTLNewMail
' adresát nebo více oddělení čárkou
.To = mailAdresa
' kopie
'.CC = "a@volny.cz"
' předmět mailu
.Subject = "Reklamace " & Worksheets("Vyjadreni").Cells(6, 10)

.Body = text_zpravy
' .Attachments.Add fName
On Error GoTo errHlaseni
druhyPokus:
.Send
End With
Set OUTLNewMail = Nothing
Set OUTLApp = Nothing
Set OUTLAttach = Nothing
Set OUTLMess = Nothing
Set OUTLNSpace = Nothing
'CANCEL --------------------------
Case Is = 2
MsgBox prompt:="Email byl zrušen.", _
Title:="EMAIL zrušen", _
Buttons:=64
End Select: Exit Sub
errHlaseni:
MsgBox "Neni spuštěn Outlook, spouštím ", vbCritical, "CHYBA"
Shell ("OUTLOOK")
GoTo druhyPokus
End Sub

Zaslat odpověď >

---

Jeza.m(25.7.2014 14:38)#020717

Stačí mrknout o dva řádky níže jak je zadána kopie (CC) a pochopíš:
.To = mailAdresa
' kopie
'.CC = "a@volny.cz"

.To = mailAdresa nahradíš .To = "honzo@gmail.net"

M@citovat

Peterrr(25.7.2014 16:04)#020718

Super ďakujem.citovat

Peterrr(29.7.2014 8:16)#020744

Ahoj,
opat by som potreboval pomoc :
chcel by som aby v tomto vygenerovanom maila bolo jako příloha vygenerované PDF z aktívneho listu v Exceli.
Vedel by mi s tym niekto pomoct ?
Dakujemcitovat

Jeza.m(29.7.2014 13:18)#020747

V podstatě v tom kódu téměř vše podstatné máš, jen to odkomentit.

Nejprve je potřeba vyexportovat pdf např.
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= "C:\POKUS.pdf", Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= False
a pak použiješ řádek:

fName = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name

Zde dosadit cestu k danému pdf
takže třeba fname = "C:\POKUS.pdf"


no a nakonec odkomentit řádek
.Attachments.Add fName

M@citovat

Peterrr(30.7.2014 9:10)#020780

Ahoj, popravde som z toho troška zúfalý, ono podla toho jako si to napísal je to jasné ale nefunguje to.
Ja sem skopírujem kód, ktorý mám a mohol by si prosím tam doplniť to, čo je nutné ? Ide mi o to, aby stále vygenerovalo PDF z aktívneho listu, uložilo ho do zložky pod názvom "PDF_1" a potom vždy nové pdf ukladoalo v poradí "PDF_2, PDF_3 ..."
Kód :

Sub EmailSKLAD()

Dim Resp As Integer
Dim poleADR(9, 1) As String, polozka As Variant
Dim poleZAK(7, 7) As String, mailAdresa As String, polePOPIS(7) As String
Dim text_zpravy As String, P1 As Variant, P2 As Variant
Dim VJ As Object
Set VJ = Worksheets("Vyjadreni")

' ----------------------------------------------------------------------------------
' --- v mailu MUSÍ být nastaveno takové písmo, které má stejnou šířku každého znaku
' --- to je například Courier New, nebo Consolas-----------------------------------
' ----------------------------------------------------------------------------------
' ---jinak bude text mailu rozházený -----------------------------------------------
Resp = MsgBox(prompt:="ANO - zkontrolovat email, NE - bez kontroly, nebo STORNO.", _
Title:="KONTROLA EMAILU PŘED ODESLÁNÍM ?", _
Buttons:=3 + 32)
' -----------------------------------------
' --- načtení potřebných hodnot a adres ---
' -----------------------------------------
With VJ

' ------------------------------------------------------------
mailAdresa = .Cells(20, 20)
' ---------------------------------------------------------
polozka = 0
For pocetPolozek = 37 To 51 Step 2
If .Cells(pocetPolozek, 2) = "" Then Exit For
poleZAK(polozka, 1) = .Cells(pocetPolozek, 2) 'cislo SKP
poleZAK(polozka, 2) = .Cells(pocetPolozek, 4) 'nazev vyrobku
poleZAK(polozka, 3) = .Cells(pocetPolozek, 7) 'počet kusu
poleZAK(polozka, 4) = .Cells(pocetPolozek, 8) 'čísko dan. dokl.
poleZAK(polozka, 5) = .Cells(pocetPolozek, 11) 'způsob vyřízení
poleZAK(polozka, 6) = .Cells(pocetPolozek, 14) 'vyjádření
' --- kontrola počtu reklamací ----------------------
If poleZAK(polozka, 2) = "" And poleZAK(polozka, 3) = "" Then Exit For
polozka = polozka + 1
Next pocetPolozek
polePOPIS(0) = "ČÍSLO VÝROBKU (SKP) "
polePOPIS(1) = "NÁZEV VÝROBKU "
polePOPIS(2) = "POČET KUSŮ "
polePOPIS(3) = "ČÍSLO DAŇ. DOKLADU "
polePOPIS(4) = "ZPŮSOB VYŘÍZENÍ REKLAMACE "
polePOPIS(5) = "VYJÁDŘENÍ "
End With
' --- nastavení stejné délky polí ----------------------------

For P1 = 0 To 7
For P2 = 0 To 7
Do While Len(poleZAK(P1, P2)) < 28
poleZAK(P1, P2) = poleZAK(P1, P2) & " "
Loop
Next P2
Next P1

' -----------------------------------------------
' --- vytvoření vlastního textu mailové zpráy ---
' -----------------------------------------------
' --- CHr(13) = další řádek ------------------

text_zpravy = "Automaticky generovaný email - Informace o nové reklamaci pro R03/R09:" & Chr(13) _
& Chr(13) _


For Z = 0 To polozka - 1
dalsi_text = "---- " & Z + 1 & ". reklamace ------------------------------------------ " & Chr(13) _
& polePOPIS(0) & ": " & poleZAK(Z, 1) & Chr(13) _
& polePOPIS(1) & ": " & poleZAK(Z, 2) & Chr(13) _
& polePOPIS(2) & ": " & poleZAK(Z, 3) & Chr(13) _
& polePOPIS(3) & ": " & poleZAK(Z, 4) & Chr(13) _
& polePOPIS(4) & ": " & poleZAK(Z, 5) & Chr(13) _
& polePOPIS(5) & ": " & poleZAK(Z, 6) & Chr(13) _
& "------------------------------------------------------------ " & Chr(13)
text_zpravy = text_zpravy & dalsi_text
Next Z
' & "Vystavil : "

Select Case Resp
'ano ----------------------------
Case Is = 6
Dim myOutlook As Object
Dim myMailItem As Object
Set OUTLApp = CreateObject("Outlook.Application")
Set OUTLNewMail = OUTLApp.CreateItem(olMailItem)
' pokud se má odeslat i aktivní soubor jako příloha, tak
' fName = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
With OUTLNewMail
' adresát nebo více oddělení čárkou
.To = "petr.vaculik@gmail.com"
' kopie
'.CC = "a@volny.cz"
' předmět mailu
.Subject = "Reklamace " & Worksheets("Vyjadreni").Cells(6, 10)
.Body = text_zpravy
' .Attachments.Add fName
.Display
End With
Set OUTLNewMail = Nothing
Set OUTLApp = Nothing
Set OUTLAttach = Nothing
Set OUTLMess = Nothing
Set OUTLNSpace = Nothing
'NE -------------------------
Case Is = 7
Dim myOutlok As Object
Dim myMailItm As Object
Set OUTLApp = CreateObject("Outlook.Application")
Set OUTLNewMail = OUTLApp.CreateItem(olMailItem)

' pokud se má odeslat i aktivní soubor jako příloha, tak
' fName = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
With OUTLNewMail
' adresát nebo více oddělení čárkou
.To = "petr.vaculik@gmail.com"
' kopie
'.CC = "a@volny.cz"
' předmět mailu
.Subject = "Reklamace " & Worksheets("Vyjadreni").Cells(6, 10)

.Body = text_zpravy
' .Attachments.Add fName
On Error GoTo errHlaseni
druhyPokus:
.Send
End With
Set OUTLNewMail = Nothing
Set OUTLApp = Nothing
Set OUTLAttach = Nothing
Set OUTLMess = Nothing
Set OUTLNSpace = Nothing
'CANCEL --------------------------
Case Is = 2
MsgBox prompt:="Email byl zrušen.", _
Title:="EMAIL zrušen", _
Buttons:=64
End Select: Exit Sub
errHlaseni:
MsgBox "Neni spuštěn Outlook, spouštím ", vbCritical, "CHYBA"
Shell ("OUTLOOK")
GoTo druhyPokus
End Subcitovat

Jeza.m(30.7.2014 12:46)#020787

Sub EmailSKLAD()

Dim Resp As Integer
Dim fName As String
Dim poleADR(9, 1) As String, polozka As Variant
Dim poleZAK(7, 7) As String, mailAdresa As String, polePOPIS(7) As String
Dim text_zpravy As String, P1 As Variant, P2 As Variant
Dim VJ As Object
Set VJ = Worksheets("Vyjadreni")

' ----------------------------------------------------------------------------------
' --- v mailu MUSÍ být nastaveno takové písmo, které má stejnou šířku každého znaku
' --- to je například Courier New, nebo Consolas-----------------------------------
' ----------------------------------------------------------------------------------
' ---jinak bude text mailu rozházený -----------------------------------------------
Resp = MsgBox(prompt:="ANO - zkontrolovat email, NE - bez kontroly, nebo STORNO.", _
Title:="KONTROLA EMAILU PŘED ODESLÁNÍM ?", _
Buttons:=3 + 32)
' -----------------------------------------
' --- načtení potřebných hodnot a adres ---
' -----------------------------------------
With VJ

' ------------------------------------------------------------
mailAdresa = .Cells(20, 20)
' ---------------------------------------------------------
polozka = 0
For pocetPolozek = 37 To 51 Step 2
If .Cells(pocetPolozek, 2) = "" Then Exit For
poleZAK(polozka, 1) = .Cells(pocetPolozek, 2) 'cislo SKP
poleZAK(polozka, 2) = .Cells(pocetPolozek, 4) 'nazev vyrobku
poleZAK(polozka, 3) = .Cells(pocetPolozek, 7) 'počet kusu
poleZAK(polozka, 4) = .Cells(pocetPolozek, 8) 'čísko dan. dokl.
poleZAK(polozka, 5) = .Cells(pocetPolozek, 11) 'způsob vyřízení
poleZAK(polozka, 6) = .Cells(pocetPolozek, 14) 'vyjádření
' --- kontrola počtu reklamací ----------------------
If poleZAK(polozka, 2) = "" And poleZAK(polozka, 3) = "" Then Exit For
polozka = polozka + 1
Next pocetPolozek
polePOPIS(0) = "ČÍSLO VÝROBKU (SKP) "
polePOPIS(1) = "NÁZEV VÝROBKU "
polePOPIS(2) = "POČET KUSŮ "
polePOPIS(3) = "ČÍSLO DAŇ. DOKLADU "
polePOPIS(4) = "ZPŮSOB VYŘÍZENÍ REKLAMACE "
polePOPIS(5) = "VYJÁDŘENÍ "
End With
' --- nastavení stejné délky polí ----------------------------

For P1 = 0 To 7
For P2 = 0 To 7
Do While Len(poleZAK(P1, P2)) < 28
poleZAK(P1, P2) = poleZAK(P1, P2) & " "
Loop
Next P2
Next P1

' -----------------------------------------------
' --- vytvoření vlastního textu mailové zpráy ---
' -----------------------------------------------
' --- CHr(13) = další řádek ------------------

text_zpravy = "Automaticky generovaný email - Informace o nové reklamaci pro R03/R09:" & Chr(13) _
& Chr(13) _

For Z = 0 To polozka - 1
dalsi_text = "---- " & Z + 1 & ". reklamace ------------------------------------------ " & Chr(13) _
& polePOPIS(0) & ": " & poleZAK(Z, 1) & Chr(13) _
& polePOPIS(1) & ": " & poleZAK(Z, 2) & Chr(13) _
& polePOPIS(2) & ": " & poleZAK(Z, 3) & Chr(13) _
& polePOPIS(3) & ": " & poleZAK(Z, 4) & Chr(13) _
& polePOPIS(4) & ": " & poleZAK(Z, 5) & Chr(13) _
& polePOPIS(5) & ": " & poleZAK(Z, 6) & Chr(13) _
& "------------------------------------------------------------ " & Chr(13)
text_zpravy = text_zpravy & dalsi_text
Next Z
' & "Vystavil : "

Select Case Resp
'ano ----------------------------
Case Is = 6
Dim myOutlook As Object
Dim myMailItem As Object
Set OUTLApp = CreateObject("Outlook.Application")
Set OUTLNewMail = OUTLApp.CreateItem(olMailItem)
' pokud se má odeslat i aktivní soubor jako příloha, tak
' fName = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
fName = exportpdf
With OUTLNewMail
' adresát nebo více oddělení čárkou
.To = "petr.vaculik@gmail.com"
' kopie
'.CC = "a@volny.cz"
' předmět mailu
.Subject = "Reklamace " & Worksheets("Vyjadreni").Cells(6, 10)
.Body = text_zpravy
.Attachments.Add fName
.Display
End With
Set OUTLNewMail = Nothing
Set OUTLApp = Nothing
Set OUTLAttach = Nothing
Set OUTLMess = Nothing
Set OUTLNSpace = Nothing
'NE -------------------------
Case Is = 7
Dim myOutlok As Object
Dim myMailItm As Object
Set OUTLApp = CreateObject("Outlook.Application")
Set OUTLNewMail = OUTLApp.CreateItem(olMailItem)
Call exportpdf
' pokud se má odeslat i aktivní soubor jako příloha, tak
fName = exportpdf
With OUTLNewMail
' adresát nebo více oddělení čárkou
.To = "petr.vaculik@gmail.com"
' kopie
'.CC = "a@volny.cz"
' předmět mailu
.Subject = "Reklamace " & Worksheets("Vyjadreni").Cells(6, 10)

.Body = text_zpravy
.Attachments.Add fName
On Error GoTo errHlaseni
druhyPokus:
.Send
End With
Set OUTLNewMail = Nothing
Set OUTLApp = Nothing
Set OUTLAttach = Nothing
Set OUTLMess = Nothing
Set OUTLNSpace = Nothing
'CANCEL --------------------------
Case Is = 2
MsgBox prompt:="Email byl zrušen.", _
Title:="EMAIL zrušen", _
Buttons:=64
End Select: Exit Sub
errHlaseni:
MsgBox "Neni spuštěn Outlook, spouštím ", vbCritical, "CHYBA"
Shell ("OUTLOOK")
GoTo druhyPokus
End Sub

Public Function exportpdf() As String
Dim counter As Single
Dim tmp As String
counter = 1
tmp = ThisWorkbook.Path & "\PDF_" & counter & ".PDF"

Do While Dir(tmp) <> ""
tmp = ThisWorkbook.Path & "\PDF_" & counter & ".PDF"
counter = counter + 1
Loop

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=tmp, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
exportpdf = tmp
End Functioncitovat

Peterrr(30.7.2014 13:44)#020792

Dakujem velmi peknecitovat

Peterrr(31.7.2014 9:36)#020819

Verím, že posledná vec :)

Teraz sa to PDF generuje na plochu, ak chcem definovat presnu cestu k priecinku ? ako na to ?
Ďakujemcitovat

Jeza.m(31.7.2014 11:29)#020827

Public Function exportpdf() As String
Dim counter As Single
Dim tmp As String
counter = 1
tmp = "C:\PDF_" & counter & ".PDF"

Do While Dir(tmp) <> ""
tmp = "C:\PDF_" & counter & ".PDF"
counter = counter + 1
Loop

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=tmp, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
exportpdf = tmp
End Function

M@citovat

Uživatelské menu

Nejste přihlášen(a)

• přihlásit
• registrace

\n

Menu

Formulář Faktura

Helios iNuvio

On-line nástroje