aayaanmayank
Board Regular
- Joined
- Jul 20, 2018
- Messages
- 157
Hi Can someone tell what is wrong with my Code. problem is when debug code then i am getting desire border in my Image/Chart but it does not set border when hit through macro button. below is my entire code.
VBA Code:
Sub createcopy()
Dim sh As Worksheet
Dim lr As Variant
'Application.DisplayAlerts = False
Set sh = ThisWorkbook.Sheets("Template")
On Error GoTo Finish:
Worksheets("Template").Activate
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").PasteSpecial
'With Worksheets("Sheet1")
'End With
Call Export
Exit Sub
Finish:
MsgBox "Encountered Error Please Run Again.", vbCritical, "Talent Match"
Sheets("Template").Activate
End Sub
Sub Export()
Dim MyChart As String, MyPicture As String
Dim PicWidth As Long, PicHeight As Long
Dim shp As Shape
Dim ws As Worksheet
Dim cht As Chart
Set ws = ActiveSheet
For Each shp In ws.Shapes
If shp.Type = msoPicture Then
shp.Select
End If
Next shp
On Error GoTo Finish
MyPicture = Selection.Name
With Selection
PicHeight = .ShapeRange.Height
PicWidth = .ShapeRange.Width
End With
Charts.Add
'ActiveChart.HeightPercent = 100
'Legend.includeLayout = True
ActiveChart.Legend.IncludeInLayout = True
ActiveChart.Legend.Position = xlLegendPositionRight
ActiveChart.Location Where:=xlLocationAsObject, Name:="Sheet1"
Selection.Border.LineStyle = xlContinuous
MyChart = Selection.Name & " " & Split(ActiveChart.Name, " ")(2)
strpath = Environ("USERPROFILE") & "\Desktop\"
With ActiveSheet
With .Shapes(MyChart)
.Width = PicWidth
.Height = PicHeight
End With
Dim cht As Chart
Set cht = Sheets("Sheet1").ChartObjects("Chart 1").Chart
' add plot area border
With cht.PlotArea.Border
.LineStyle = xlContinuous
.Weight = xlThick
End With
' add chart area border
With cht.ChartArea.Border
.LineStyle = xlContinuous
.Weight = xlThick
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 "Encountered Error Please Run Again.", vbCritical, "Talent Match"
Sheets("Template").Activate
End Sub
Sub send1()
Dim sh1 As Worksheet
Dim OLOOK As Outlook.Application
Dim omail As Outlook.MailItem
Dim ch As ChartObjects
Dim ws As Worksheet
Set sh1 = ThisWorkbook.Sheets("sheet1")
Set sh = ThisWorkbook.Sheets("Template")
Set OLOOK = New Outlook.Application
Set omail = OLOOK.CreateItem(olMailItem)
On Error GoTo Finish:
Set ws = ThisWorkbook.Sheets("Template")
tmp = Environ("USERPROFILE") & "\Desktop\" & "Mypic.Bmp"
With omail
omail.To = “”
omail.CC = “”
omail.Subject = “”
'omail.HTMLBody = "<BR> " & " <style=border: none>" & _
"<table align=""center"">" & _
"<img src = '" & tmp & "' >"
'omail.Attachments.Add tmp, 1, 0
omail.HTMLBody = "<html><BR><BR><center><img src = '" & tmp & "' ></center></BR></br></html>"
omail.Display
End With
sh1.Pictures.Delete
sh.Activate
Exit Sub
Finish:
MsgBox "Encountered Error Please Run Again.", vbCritical, "Talent Match"
Sheets("Template").Activate
End Sub
