Hoe plak ik een reeks cellen in de berichttekst als afbeelding in Excel?
Als u een reeks cellen moet kopi毛ren en deze als afbeelding in de berichttekst moet plakken wanneer u een e-mail verzendt vanuit Excel. Hoe zou u deze taak kunnen aanpakken?
Plak een reeks cellen in de hoofdtekst van de e-mail als afbeelding met VBA-code in Excel
Plak een reeks cellen in de hoofdtekst van de e-mail als afbeelding met VBA-code in Excel
Misschien is er geen andere goede methode om deze taak op te lossen, een VBA-code in dit artikel kan je helpen. Doe als volgt:
1. Schakel het blad in dat u wilt kopi毛ren en plak de cellen als afbeelding, houd de ALT + F11 toetsen om de te openen Microsoft Visual Basic voor toepassingen venster.
2. Klikken Invoegen > Moduleen plak de volgende code in het Module Venster.
VBA-code: plak een reeks cellen in de hoofdtekst van de e-mail als afbeelding:
Sub sendMail()
Dim TempFilePath As String
Dim xOutApp As Object
Dim xOutMail As Object
Dim xHTMLBody As String
Dim xRg As Range
On Error Resume Next
Set xRg = Application.InputBox("Please select the data range:", "KuTools for Excel", Selection.Address, , , , , 8)
If xRg Is Nothing Then Exit Sub
With Application
.Calculation = xlManual
.ScreenUpdating = False
.EnableEvents = False
End With
Set xOutApp = CreateObject("outlook.application")
Set xOutMail = xOutApp.CreateItem(olMailItem)
Call createJpg(ActiveSheet.Name, xRg.Address, "DashboardFile")
TempFilePath = Environ$("temp") & "\"
xHTMLBody = "<span LANG=EN>" _
& "<p class=style2><span LANG=EN><font FACE=Calibri SIZE=3>" _
& "Hello, this is the data range that you want:<br> " _
& "<br>" _
& "<img src='//cdn.extendoffice.com/cid:DashboardFile.jpg'>" _
& "<br>Best Regards!</font></span>"
With xOutMail
.Subject = ""
.HTMLBody = xHTMLBody
.Attachments.Add TempFilePath & "DashboardFile.jpg", olByValue
.To = " "
.Cc = " "
.Display
End With
End Sub
Sub createJpg(SheetName As String, xRgAddrss As String, nameFile As String)
Dim xRgPic As Range
Dim xShape As Shape
ThisWorkbook.Activate
Worksheets(SheetName).Activate
Set xRgPic = ThisWorkbook.Worksheets(SheetName).Range(xRgAddrss)
xRgPic.CopyPicture
With ThisWorkbook.Worksheets(SheetName).ChartObjects.Add(xRgPic.Left, xRgPic.Top, xRgPic.Width, xRgPic.Height)
.Activate
For Each xShape In ActiveSheet.Shapes
xShape.Line.Visible = msoFalse
Next
.Chart.Paste
.Chart.Export Environ$("temp") & "\" & nameFile & ".jpg", "JPG"
End With
Worksheets(SheetName).ChartObjects(Worksheets(SheetName).ChartObjects.Count).Delete
Set xRgPic = Nothing
End Sub
Note: In de bovenstaande code kunt u de hoofdtekst en het e-mailadres naar wens wijzigen.
3. Nadat u de code hebt ingevoerd, drukt u op F5 Om deze code uit te voeren, verschijnt er een dialoogvenster om u eraan te herinneren het gegevensbereik te selecteren dat u als afbeelding in de hoofdtekst van de e-mail wilt invoegen, zie screenshot:
4. Dan klikken OK knop, en een Bericht venster wordt weergegeven, het geselecteerde gegevensbereik is als afbeelding in de body ingevoegd, zie screenshot:
Note: In de Bericht venster kunt u indien nodig ook de hoofdinhoud en e-mailadressen in de velden Aan en Cc wijzigen.
5. Klik ten slotte op Verzenden knop om deze e-mail te verzenden.
Note: Als u meerdere bereiken uit verschillende werkbladen moet plakken, kan de onderstaande VBA-code u een plezier doen:
Eerst moet u de meerdere bereiken selecteren die u als afbeeldingen in de hoofdtekst van de e-mail wilt invoegen en vervolgens de volgende code toepassen:
VBA-code: plak meerdere celbereiken in de hoofdtekst van de e-mail als afbeelding:
Sub sendMail()
Dim TempFilePath As String
Dim xOutApp As Object
Dim xOutMail As Object
Dim xHTMLBody As String
Dim xRg As Range
Dim xSheet As Worksheet
Dim xAcSheet As Worksheet
Dim xFileName As String
Dim xSrc As String
On Error Resume Next
TempFilePath = Environ$("temp") & "\RangePic\"
If Len(VBA.Dir(TempFilePath, vbDirectory)) = False Then
VBA.MkDir TempFilePath
End If
Set xAcSheet = Application.ActiveSheet
For Each xSheet In Application.Worksheets
xSheet.Activate
Set xRg = xSheet.Application.Selection
If xRg.Cells.Count > 1 Then
Call createJpg(xSheet.Name, xRg.Address, "DashboardFile" & VBA.Trim(VBA.Str(xSheet.Index)))
End If
Next
xAcSheet.Activate
With Application
.Calculation = xlManual
.ScreenUpdating = False
.EnableEvents = False
End With
Set xOutApp = CreateObject("outlook.application")
Set xOutMail = xOutApp.CreateItem(olMailItem)
xSrc = ""
xFileName = Dir(TempFilePath & "*.*")
Do While xFileName <> ""
xSrc = xSrc + VBA.vbCrLf + "<img src='cid:" + xFileName + "'><br>"
xFileName = Dir
If xFileName = "" Then Exit Do
Loop
xHTMLBody = "<span LANG=EN>" _
& "<p class=style2><span LANG=EN><font FACE=Calibri SIZE=3>" _
& "Hello, this is the data range that you want:<br> " _
& "<br>" _
& xSrc _
& "<br>Best Regards!</font></span>"
With xOutMail
.Subject = ""
.HTMLBody = xHTMLBody
xFileName = Dir(TempFilePath & "*.*")
Do While xFileName <> ""
.Attachments.Add TempFilePath & xFileName, olByValue
xFileName = Dir
If xFileName = "" Then Exit Do
Loop
.To = " "
.Cc = " "
.Display
End With
If VBA.Dir(TempFilePath & "*.*") <> "" Then
VBA.Kill TempFilePath & "*.*"
End If
End Sub
Sub createJpg(SheetName As String, xRgAddrss As String, nameFile As String)
Dim xRgPic As Range
ThisWorkbook.Activate
Worksheets(SheetName).Activate
Set xRgPic = ThisWorkbook.Worksheets(SheetName).Range(xRgAddrss)
xRgPic.CopyPicture
With ThisWorkbook.Worksheets(SheetName).ChartObjects.Add(xRgPic.Left, xRgPic.Top, xRgPic.Width, xRgPic.Height)
.Activate
.Chart.Paste
.Chart.Export Environ$("temp") & "\RangePic\" & nameFile & ".jpg", "JPG"
End With
Worksheets(SheetName).ChartObjects(Worksheets(SheetName).ChartObjects.Count).Delete
Set xRgPic = Nothing
End Sub
Beste Office-productiviteitstools
Geef uw Excel-vaardigheden een boost met Kutools voor Excel en ervaar effici毛ntie als nooit tevoren. Kutools voor Excel biedt meer dan 300 geavanceerde functies om de productiviteit te verhogen en tijd te besparen. Klik hier om de functie te krijgen die u het meest nodig heeft...
Office-tabblad Brengt een interface met tabbladen naar Office en maakt uw werk veel gemakkelijker
- Schakel bewerken en lezen met tabbladen in Word, Excel, PowerPoint in, Publisher, Access, Visio en Project.
- Open en maak meerdere documenten in nieuwe tabbladen van hetzelfde venster in plaats van in nieuwe vensters.
- Verhoogt uw productiviteit met 50% en vermindert honderden muisklikken voor u elke dag!
