< návrat zpět

MS Excel

Téma: Makro EMAIL zmena rss

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
Jeza.m
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
avatar
Super ďakujem.citovat
Peterrr(29.7.2014 8:16)#020744
avatar
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
Jeza.m
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
avatar
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
Jeza.m
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
avatar
Dakujem velmi peknecitovat
Peterrr(31.7.2014 9:36)#020819
avatar
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
Jeza.m
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)
avatar\n

Formulář Faktura

Formulář Faktura IV

Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.

Helios iNuvio

Používáte podnikový systém Helios iNuvio? Potřebujete pomoci se správou nebo vyvinout SQL proceduru? Více informací naleznete na stránce Helios iNuvio.

On-line nástroje