Ahoj,
potřebovala bych poradit s tímto kódem na automatické vytvoření e-mailu v Excelu. Jelikož jsem úplný začátečník, potřebovala bych poradit, jak POD tu tabulku která se mi do mailu automaticky zkopíruje přidám další text. Je to možné?
Moc děkuji
Private Sub CommandButton3_Click()
Dim outlook As Object
Dim newEmail As Object
Dim xInspect As Object
Dim pageEditor As Object
Set outlook = CreateObject("Outlook.Application")
Set newEmail = outlook.CreateItem(0)
With newEmail
.To = Sheet4.Range("H1")
.CC = ""
.BCC = ""
.Subject = Sheet4.Range("D13")
.Body = Sheet4.Range("P23")
.display
Set xInspect = newEmail.GetInspector
Set pageEditor = xInspect.WordEditor
Sheet4.Range("B14:I15").Copy
pageEditor.Application.Selection.Start = Len(.Body)
pageEditor.Application.Selection.End = pageEditor.Application.Selection.Start
pageEditor.Application.Selection.PasteAndFormat (wdFormatPlainText)
.display
Set pageEditor = Nothing
Set xInspect = Nothing
End With
Set newEmail = Nothing
Set outlook = Nothing
End Sub
Úprava kódu
Re: Úprava kódu
Ahoj, napadlo mě toto řešení. Zpráva v těle mailu bude rozdělena na dvě části, které se vloží současně a mezi ně se poté vloží zkopírovaná "tabulka".
Kód: Vybrat vše
Private Sub CommandButton3_Click()
Dim outlook As Object
Dim newEmail As Object
Dim xInspect As Object
Dim pageEditor As Object
Dim TextNadTabulkou As String
Dim TextPodTabulkou As String
Set outlook = CreateObject("Outlook.Application")
Set newEmail = outlook.CreateItem(0)
TextNadTabulkou = Sheet4.Range("P23")
TextPodTabulkou = Sheet4.Range("P24")
With newEmail
.To = Sheet4.Range("H1")
.CC = ""
.BCC = ""
.Subject = Sheet4.Range("D13")
.body = TextNadTabulkou & vbNewLine & TextPodTabulkou
.display
Set xInspect = newEmail.GetInspector
Set pageEditor = xInspect.WordEditor
Sheet4.Range("B14:I15").Copy
With pageEditor.Application.Selection
.Start = Len(TextNadTabulkou)
.End = pageEditor.Application.Selection.Start
.PasteAndFormat (wdFormatPlainText)
End With
Application.CutCopyMode = False
.display
End With
Set pageEditor = Nothing
Set xInspect = Nothing
Set newEmail = Nothing
Set outlook = Nothing
End Sub
-
- Mohlo by vás zajímat
- Odpovědi
- Zobrazení
- Poslední příspěvek
-
- 4
- 4491
-
od junis
Zobrazit poslední příspěvek
22 črc 2024 17:54
-
- 6
- 5343
-
od junis
Zobrazit poslední příspěvek
02 srp 2024 18:02
-
-
Úprava pc pro Kingdome Come Deliverance 2
od barryk10cz » 07 led 2025 17:00 » v Rady s výběrem hw a sestavením PC - 13
- 3826
-
od Hangli
Zobrazit poslední příspěvek
09 led 2025 22:42
-
-
-
Raspberry - M2 disk - uprava a zaloha oddilu Příloha(y)
od L.L » 18 srp 2024 10:32 » v Problémy s hardwarem - 3
- 3782
-
od L.L
Zobrazit poslední příspěvek
19 srp 2024 14:39
-
-
-
bitmapová grafika - úprava fotografií, retuše, filtry.
od zuzana3 » 10 kvě 2025 11:32 » v Design a grafické editory - 2
- 5241
-
od zuzana3
Zobrazit poslední příspěvek
10 kvě 2025 17:31
-
Kdo je online
Uživatelé prohlížející si toto fórum: Žádní registrovaní uživatelé a 3 hosti