Πώς να επικολλήσετε μια σειρά κελιών στο σώμα μηνυμάτων ως εικόνα στο Excel;
Εάν πρέπει να αντιγράψετε μια περιοχή κελιών και να την επικολλήσετε ως εικόνα στο σώμα μηνυμάτων όταν στέλνετε ένα μήνυμα ηλεκτρονικού ταχυδρομείου από το Excel. Πώς θα μπορούσατε να αντιμετωπίσετε αυτήν την εργασία;
Επικολλήστε μια σειρά κελιών στο σώμα του ηλεκτρονικού ταχυδρομείου ως εικόνα με τον κώδικα VBA στο Excel
Μπορεί να μην υπάρχει άλλη καλή μέθοδος για την επίλυση αυτής της εργασίας, ένας κώδικας VBA σε αυτό το άρθρο μπορεί να σας βοηθήσει. Κάντε το ως εξής:
1. Ενεργοποιήστε το φύλλο που θέλετε να αντιγράψετε και επικολλήστε τα κελιά ως εικόνα, κρατήστε πατημένο το ALT + F11 για να ανοίξετε το Microsoft Visual Basic για εφαρμογές παράθυρο.
2. Κλίκ Κύριο θέμα > Μονάδα μέτρησηςκαι επικολλήστε τον ακόλουθο κώδικα στο Μονάδα μέτρησης Παράθυρο.
Κωδικός VBA: επικολλήστε μια σειρά κελιών στο σώμα του email ως εικόνα:
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: Στον παραπάνω κωδικό, μπορείτε να αλλάξετε το περιεχόμενο του σώματος και τη διεύθυνση email ανάλογα με τις ανάγκες σας.
3. Αφού εισαγάγετε τον κωδικό, πατήστε F5 κλειδί για την εκτέλεση αυτού του κώδικα, εμφανίζεται ένα παράθυρο διαλόγου για να σας υπενθυμίσει ότι επιλέγετε το εύρος δεδομένων που θέλετε να εισαγάγετε στο σώμα του email ως εικόνα, δείτε στιγμιότυπο οθόνης:
4. Στη συνέχεια κάντε κλικ στο κουμπί OK και, α Μήνυμα εμφανίζεται το παράθυρο, το επιλεγμένο εύρος δεδομένων έχει εισαχθεί στο σώμα ως εικόνα, δείτε στιγμιότυπο οθόνης:
Note: Στο Μήνυμα Μπορείτε επίσης να αλλάξετε το περιεχόμενο του σώματος και τις διευθύνσεις email στα πεδία Προς και Κοιν. όπως χρειάζεστε.
5. Επιτέλους, κάντε κλικ στο κουμπί Αποστολή κουμπί για να στείλετε αυτό το email.
Note: Εάν χρειάζεται να επικολλήσετε πολλές περιοχές από διαφορετικά φύλλα εργασίας, ο παρακάτω κώδικας VBA μπορεί να σας κάνει τη χάρη:
Αρχικά, θα πρέπει να επιλέξετε τα πολλαπλά εύρη που θέλετε να εισαγάγετε στο σώμα του email ως εικόνες και, στη συνέχεια, να εφαρμόσετε τον ακόλουθο κώδικα:
Κώδικας VBA: επικολλήστε πολλαπλές περιοχές κελιών στο σώμα του email ως εικόνα:
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
Τα καλύτερα εργαλεία παραγωγικότητας γραφείου
Αυξήστε τις δεξιότητές σας στο Excel με τα Kutools για Excel και απολαύστε την αποτελεσματικότητα όπως ποτέ πριν. Το Kutools για Excel προσφέρει πάνω από 300 προηγμένες δυνατότητες για την ενίσχυση της παραγωγικότητας και την εξοικονόμηση χρόνου. Κάντε κλικ εδώ για να αποκτήσετε τη δυνατότητα που χρειάζεστε περισσότερο...
Το Office Tab φέρνει τη διεπαφή με καρτέλες στο Office και κάνει την εργασία σας πολύ πιο εύκολη
- Ενεργοποίηση επεξεργασίας και ανάγνωσης καρτελών σε Word, Excel, PowerPoint, Publisher, Access, Visio και Project.
- Ανοίξτε και δημιουργήστε πολλά έγγραφα σε νέες καρτέλες του ίδιου παραθύρου και όχι σε νέα παράθυρα.
- Αυξάνει την παραγωγικότητά σας κατά 50% και μειώνει εκατοντάδες κλικ του ποντικιού για εσάς κάθε μέρα!
