كيفية لصق نطاق من الخلايا في نص الرسالة كصورة في Excel؟
إذا كنت بحاجة إلى نسخ نطاق من الخلايا ولصقه كصورة في نص الرسالة عند إرسال بريد إلكتروني من Excel، كيف يمكنك التعامل مع هذه المهمة؟
لصق نطاق من الخلايا في نص البريد الإلكتروني كصورة باستخدام كود VBA في Excel
لصق نطاق من الخلايا في نص البريد الإلكتروني كصورة باستخدام كود VBA في Excel
قد لا يكون هناك طريقة أخرى جيدة بالنسبة لك لحل هذه المهمة، يمكن أن يساعدك كود VBA في هذه المقالة. يرجى القيام بما يلي:
1. قم بتفعيل الورقة التي تريد نسخها ولصق الخلايا منها كصورة، واضغط باستمرار على مفاتيح ALT + F11 لفتح نافذة Microsoft Visual Basic for Applications.
2. انقر فوق إدراج > وحدة، والصق الكود التالي في نافذة الوحدة.
كود VBA: لصق نطاق من الخلايا في نص البريد الإلكتروني كصورة:
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. ثم انقر فوق زر موافق، وتظهر نافذة رسالة، تم إدراج نطاق البيانات المحدد في النص كصورة، انظر إلى لقطة الشاشة:
ملاحظة: في نافذة الرسالة، يمكنك أيضًا تغيير محتوى النص وعناوين البريد الإلكتروني في حقول إلى ونسخة حسب حاجتك.
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 لـ Excel، واختبر كفاءة غير مسبوقة. Kutools لـ Excel يوفر أكثر من300 ميزة متقدمة لزيادة الإنتاجية وتوفير وقت الحفظ. انقر هنا للحصول على الميزة الأكثر أهمية بالنسبة لك...
Office Tab يجلب واجهة التبويب إلى Office ويجعل عملك أسهل بكثير
- تفعيل تحرير وقراءة عبر التبويبات في Word، Excel، PowerPoint، Publisher، Access، Visio وProject.
- افتح وأنشئ عدة مستندات في تبويبات جديدة في نفس النافذة، بدلاً من نوافذ مستقلة.
- يزيد إنتاجيتك بنسبة50%، ويقلل مئات النقرات اليومية من الفأرة!
جميع إضافات Kutools. مثبت واحد
حزمة Kutools for Office تجمع بين إضافات Excel وWord وOutlook وPowerPoint إضافة إلى Office Tab Pro، وهي مثالية للفرق التي تعمل عبر تطبيقات Office.





- حزمة الكل في واحد — إضافات Excel وWord وOutlook وPowerPoint + Office Tab Pro
- مثبّت واحد، ترخيص واحد — إعداد في دقائق (جاهز لـ MSI)
- الأداء الأفضل معًا — إنتاجية مُبسطة عبر تطبيقات Office
- تجربة كاملة لمدة30 يومًا — بدون تسجيل، بدون بطاقة ائتمان
- قيمة رائعة — وفر مقارنة بشراء الإضافات بشكل منفرد