Dim cmt As Comment, myrng As Range, rowcount As Long, mychart As Chart
Dim pathname As String, i As Long, datarng As Range, axisrng As Range, captionrange As Range
Private Sub Workbook_Open()
On Error Resume Next
Application.ScreenUpdating = False
i = 2
rowcount = ThisWorkbook.Sheets(1).Range("A2").End(xlDown).Row
pathname = "C:\temp\"
For i = 2 To rowcount
Set myrng = ThisWorkbook.Sheets(1).Range("G" & i)
myrng.Comment.Delete
Set cmt = myrng.AddComment
Set mychart = Charts.Add
Set mychart = mychart.Location(xlLocationAsObject, "Sheet1")
Set datarng = ThisWorkbook.Sheets(1).Range("B" & i & ":F" & i)
Set axisrng = ThisWorkbook.Sheets(1).Range("B1:F1")
Set captionrange = ThisWorkbook.Sheets(1).Range("A" & i)
mychart.SetSourceData Source:=datarng
mychart.SeriesCollection(1).XValues = axisrng
mychart.SetElement msoElementChartTitleAboveChart
mychart.ChartTitle.Caption = captionrange
mychart.HasLegend = False
mychart.Export pathname & "temp" & i & ".jpg", "jpg"
With cmt.Shape
.Fill.UserPicture ("C:\temp\temp" & i & ".jpg")
.ScaleHeight 2, msoFalse
.ScaleWidth 3, msoFalse
End With
ThisWorkbook.Sheets(1).ChartObjects.Delete
Next
Set myrng = Nothing
Set mychart = Nothing
Set datarng = Nothing
Set axisrng = Nothing
Set captionrange = Nothing
End Sub
No comments:
Post a Comment