Copying and Sending

This copies a cell range and saves a picture of it to a local folder.

Public Sub SaveRangeAndSend() 
   Call SaveRangePic(Range("A1:B20"), "C:\Temp\myFile.png")
   Call SendEmail("C:\Temp\myFile.png", "myFile.png")
End Sub

This code saves the cell range to an image file.

Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long 
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, _
   RefIID As uGUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long

Private Type uGUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Private Type uPicDesc
    Size As Long
    Type As Long
    hPic As Long
    hPal As Long
End Type

Public Sub SaveRangePic(ByVal SourceRange As Range, _
                        ByVal sFilePathName As String)
Dim IID_IDispatch As uGUID
Dim uPicInfo As uPicDesc
Dim IPic As IPicture
Dim hPtr As Long
   On Error GoTo ErrorHandler
   SourceRange.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
   OpenClipboard 0
   hPtr = GetClipboardData(2)
   With IID_IDispatch
       .Data1 = &H7BF80980
       .Data2 = &HBF32
       .Data3 = &H101A
       .Data4(0) = &H8B
       .Data4(1) = &HBB
       .Data4(2) = &H0
       .Data4(3) = &HAA
       .Data4(4) = &H0
       .Data4(5) = &H30
       .Data4(6) = &HC
       .Data4(7) = &HAB
   End With
   With uPicInfo
       .Size = Len(uPicInfo)
       .Type = 1
       .hPic = hPtr
       .hPal = 0
   End With
   OleCreatePictureIndirect uPicInfo, IID_IDispatch, True, IPic
   stdole.SavePicture IPic, sFilePathName
   Exit Sub
    MsgBox (Err.Number & " - " & Err.description)
End Sub

This code creates an Outlook email and embeds an image into the email body.
You need to add a reference to the Microsoft Office 16.0 Object Library.

Public Sub SendEmail(ByVal sFullPath As String, _ 
                     ByVal sFileName As String)
Dim oOutlookApp As Outlook.Application
Dim oMailItem As Outlook.MailItem

    Set oOutlookApp = CreateObject("Outlook.Application")
    Set oMailItem = oOutlookApp.CreateItem(OlItemType.olMailItem)
    With oMailItem
        .Subject = "mytitle"
        .HTMLBody = "add some text<BR><BR><IMG src=""cid:" & sFileName & """>"
        .Recipients.Add ""
        .Attachments.Add sFullPath, Type:=OlAttachmentType.olEmbeddeditem, Position:=0
    End With
   Exit Sub
    MsgBox (Err.Number & " - " & Err.description)
End Sub

© 2024 Better Solutions Limited. All Rights Reserved. © 2024 Better Solutions Limited TopPrevNext