كيفية لصق مجموعة من الخلايا في نص الرسالة كصورة في Excel؟
إذا كنت بحاجة إلى نسخ نطاق من الخلايا ولصقه كصورة في نص الرسالة عند إرسال بريد إلكتروني من Excel. كيف يمكنك التعامل مع هذه المهمة؟
الصق نطاقًا من الخلايا في جسم البريد الإلكتروني كصورة مع رمز VBA في Excel
الصق نطاقًا من الخلايا في جسم البريد الإلكتروني كصورة مع رمز VBA في Excel
قد لا توجد طريقة أخرى جيدة لحل هذه المهمة ، يمكن أن يساعدك رمز VBA في هذه المقالة. يرجى القيام بذلك على النحو التالي:
1. قم بتمكين الورقة التي تريد نسخ الخلايا ولصقها كصورة ، واضغط باستمرار على ALT + F11 مفاتيح لفتح ميكروسوفت فيسوال باسيك للتطبيقات نافذة.
2. انقر إدراج > وحدة، والصق الكود التالي في ملف وحدة نافذة او شباك.
كود فبا: الصق مجموعة من الخلايا في جسم البريد الإلكتروني كصورة:
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
ملاحظات: في الكود أعلاه، يمكنك تغيير محتوى الجسم وعنوان البريد الإلكتروني حسب حاجتك.
3. بعد إدخال الكود اضغط على F5 لتشغيل هذا الرمز، يظهر مربع حوار لتذكيرك بتحديد نطاق البيانات الذي تريد إدراجه في نص البريد الإلكتروني كصورة، انظر لقطة الشاشة:
4. ثم اضغط OK زر، و a الرسالة يتم عرض النافذة، وقد تم إدراج نطاق البيانات المحدد في الجسم كصورة، انظر الصورة:
ملاحظات: في ال الرسالة في النافذة، يمكنك أيضًا تغيير محتوى النص وعناوين البريد الإلكتروني في الحقلين "إلى" و"نسخة" حسب حاجتك.
5. أخيرًا ، انقر فوق أرسل زر لإرسال هذا البريد الإلكتروني.
ملاحظات: إذا كنت بحاجة إلى لصق نطاقات متعددة من أوراق عمل مختلفة، فإن كود VBA أدناه يمكن أن يقدم لك معروفًا:
أولاً، يجب عليك تحديد النطاقات المتعددة التي تريد إدراجها في نص البريد الإلكتروني كصور، ثم قم بتطبيق الكود التالي:
رمز VBA: قم بلصق نطاقات متعددة من الخلايا في نص البريد الإلكتروني كصورة:
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 for Excel، واختبر كفاءة لم يسبق لها مثيل. يقدم Kutools for Excel أكثر من 300 ميزة متقدمة لتعزيز الإنتاجية وتوفير الوقت. انقر هنا للحصول على الميزة التي تحتاجها أكثر...
يجلب Office Tab الواجهة المبوبة إلى Office ، ويجعل عملك أسهل بكثير
- تمكين التحرير والقراءة المبوبة في Word و Excel و PowerPointوالناشر والوصول و Visio والمشروع.
- فتح وإنشاء مستندات متعددة في علامات تبويب جديدة من نفس النافذة ، بدلاً من النوافذ الجديدة.
- يزيد من إنتاجيتك بنسبة 50٪ ، ويقلل مئات النقرات بالماوس كل يوم!