Wrap Square Image when exporting Outlook

aayaanmayank

Board Regular
Joined
Jul 20, 2018
Messages
156
Hi I have a excel which is combination of shapes and text boxes, after selecting shapes and text boxes, it creates an image through Macro. then its store the image in a location. after that this Image goes to outlook application. but few user not getting complete image. after doing WRAP SQUARE the are able to see complete image.
So is it possible to save image as WRAP SQUARE
Code to Create Image
VBA Code:
Sub createcopy()
    Dim sh As Worksheet
    Dim lr As Variant
Application.DisplayAlerts = False
Set sh = ThisWorkbook.Sheets("Template")
lr = sh.Range("A" & Application.Rows.Count).End(xlUp).Row - 1
Worksheets("Template").Range("A1:Q" & lr).CopyPicture xlScreen, xlBitmap
Sheets("Sheet1").Activate
Sheets("Sheet1").Paste
Set myDocument = Worksheets("Sheet1")
myDocument.Shapes(1).PictureFormat.CropLeft = 1
myDocument.Shapes(1).PictureFormat.CropTop = 1
Call Export

CODE TO EXPORT & SAVE IMAGE IN BMP
[CODE=vba]
Sub Export()
     Dim MyChart As String, MyPicture As String
     Dim PicWidth As Long, PicHeight As Long
     Dim shp As Shape
     Dim ws As Worksheet
Set ws = ActiveSheet
For Each shp In ws.Shapes
    If shp.Type = msoPicture Then
        '        MsgBox shp.Name & " is a picture"
    shp.Select
    End If
Next shp
'     Application.ScreenUpdating = False
     On Error GoTo Finish
     MyPicture = Selection.Name
     With Selection
           PicHeight = .ShapeRange.Height
           PicWidth = .ShapeRange.Width
     End With
     Charts.Add
     ActiveChart.Location Where:=xlLocationAsObject, Name:="Sheet1"
     Selection.Border.LineStyle = 0
     MyChart = Selection.Name & " " & Split(ActiveChart.Name, " ")(2)
    strpath = "D:\Users\Public\"
     With ActiveSheet
           With .Shapes(MyChart)
                 .Width = PicWidth
                 .Height = PicHeight              
           End With
           .Shapes(MyPicture).Copy
           With ActiveChart
                 .ChartArea.Select
                 .Paste
           End With
             .ChartObjects(1).Chart.Export FileName:=strpath & "MyPic.bmp", Filtername:="bmp"
            .Shapes(MyChart).Cut
     End With
     Application.ScreenUpdating = True
     send1
     Exit Sub
Finish:
    MsgBox "You must select a picture"
End Sub

[/CODE]
CODE TO CREATE OUTLOOK WITH EMAIL.
VBA Code:
Sub send1()
Dim sh1 As Worksheet
Set sh1 = ThisWorkbook.Sheets("sheet1")
Set sh = ThisWorkbook.Sheets("Template")
Dim OLOOK As Outlook.Application
Set OLOOK = New Outlook.Application
Dim omail As Outlook.MailItem
Set omail = OLOOK.CreateItem(olMailItem)
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Template")
Dim ch As ChartObjects
Sheets("DL").Activate
LR1 = Sheets("DL").Range("A" & Rows.Count).End(xlUp).Row + 1
LR2 = Sheets("DL").Range("A" & Rows.Count).End(xlUp).Row + 1
    Set emailRng = Worksheets("DL").Range("A2:A" & LR1)
    Set emailRng1 = Worksheets("DL").Range("B2:B" & LR2)
    For Each cl In emailRng
        sTo = sTo & ";" & cl.Value
    Next
    For Each cl1 In emailRng1
        sTo1 = sTo1 & ";" & cl1.Value
    Next
     sTo = Mid(sTo, 2)
     sTo1 = Mid(sTo1, 2)
With omail
omail.To = sTo
omail.CC = sTo1
omail.Subject = Sheets("DL").Range("C2").Value
omail.HTMLBody = "<BR> " & " <style=border: none>" & "<table align=""center"">" & "<img src = 'D:\Users\Public\MyPic.bmp'>"
omail.Display
End With
sh1.Pictures.Delete
sh.Activate
End Sub
 

Excel Facts

Which came first: VisiCalc or Lotus 1-2-3?
Dan Bricklin and Bob Frankston debuted VisiCalc in 1979 as a Visible Calculator. Lotus 1-2-3 debuted in the early 1980's, from Mitch Kapor.

Forum statistics

Threads
1,147,518
Messages
5,741,637
Members
423,675
Latest member
Dea21

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top