Excel'de görüntü olarak bir dizi hücreyi ileti gövdesine nasıl yapıştırabilirim?
Excel'den bir e-posta gönderirken bir dizi hücreyi kopyalayıp ileti gövdesine bir görüntü olarak yapıştırmanız gerekiyorsa. Bu görevle nasıl başa çıkabilirsiniz?
Excel'de VBA kodu ile bir dizi hücreyi e-posta gövdesine resim olarak yapıştırın
Excel'de VBA kodu ile bir dizi hücreyi e-posta gövdesine resim olarak yapıştırın
Bu işi çözmeniz için başka iyi bir yöntem olmayabilir, bu makaledeki bir VBA kodu size yardımcı olabilir. Lütfen şunu yapın:
1. Hücreleri resim olarak kopyalayıp yapıştırmak istediğiniz sayfayı etkinleştirin, ALT + F11 tuşlarını açmak için Uygulamalar için Microsoft Visual Basic pencere.
2. tıklayın Ekle > modülve aşağıdaki kodu modül Pencere.
VBA kodu: bir dizi hücreyi e-posta gövdesine görüntü olarak yapıştırın:
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
not: Yukarıdaki kodda, ihtiyaçlarınıza göre gövde içeriğini ve e-posta adresini değiştirebilirsiniz.
3. Kodu girdikten sonra F5 Bu kodu çalıştırmak için tuşuna basın, e-posta gövdesine resim olarak eklemek istediğiniz veri aralığını seçmenizi hatırlatmak için bir iletişim kutusu açılır, ekran görüntüsüne bakın:
4. Sonra tıklayın OK düğmesini ve bir Mesaj penceresi görüntülenir, seçilen veri aralığı görüntü olarak gövdeye eklenmiştir, ekran görüntüsüne bakın:
not: İçinde Mesaj penceresinde, ihtiyaç duyduğunuzda Kime ve Bilgi alanlarındaki gövde içeriğini ve E-posta adreslerini de değiştirebilirsiniz.
5. Sonunda, tıklayın Gönder Bu e-postayı göndermek için düğmesine basın.
not: Farklı çalışma sayfalarından birden fazla aralık yapıştırmanız gerekirse, aşağıdaki VBA kodu size bir iyilik yapabilir:
Öncelikle, e-posta gövdesine resim olarak eklemek istediğiniz birden çok aralığı seçmeli ve ardından aşağıdaki kodu uygulamalısınız:
VBA kodu: birden çok hücre aralığını e-posta gövdesine resim olarak yapıştırın:
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
En İyi Ofis Üretkenlik Araçları
Kutools for Excel ile Excel Becerilerinizi Güçlendirin ve Daha Önce Hiç Olmadığı Gibi Verimliliği Deneyimleyin. Kutools for Excel, Üretkenliği Artırmak ve Zamandan Tasarruf Etmek için 300'den Fazla Gelişmiş Özellik Sunar. En Çok İhtiyacınız Olan Özelliği Almak İçin Buraya Tıklayın...
Office Tab, Office'e Sekmeli Arayüz Getirir ve İşinizi Çok Daha Kolay Hale Getirir
- Word, Excel, PowerPoint'te sekmeli düzenlemeyi ve okumayı etkinleştirin, Publisher, Access, Visio ve Project.
- Yeni pencereler yerine aynı pencerenin yeni sekmelerinde birden çok belge açın ve oluşturun.
- Üretkenliğinizi% 50 artırır ve her gün sizin için yüzlerce fare tıklamasını azaltır!
