Option Explicit
Sub CheatingUserpictureRestrictions()
' constants
Const ksFileExtension = ".jpg"
' declarations
Dim cht As Chart
Dim sFile As String, lWidth As Long, lHeight As Long
' start
sFile = ActiveWorkbook.Path & Application.PathSeparator & _
Format(Now(), "yyyymmddhhmmss") & ksFileExtension
' process
' build image file
With [Tabla1[#All]]
lWidth = .Width
lHeight = .Height
.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
Set cht = ActiveSheet.ChartObjects.Add(.Top, .Left, lWidth, lHeight).Chart
End With
With cht
.Paste
.ChartArea.Border.LineStyle = 0
.Export sFile
.Parent.Delete
End With
Application.CutCopyMode = False
' load image file
With [CommentCell]
If Not (.Comment Is Nothing) Then .ClearComments
.AddComment
With .Comment
With .Shape
.Fill.UserPicture sFile
.Width = lWidth
.Height = lHeight
End With
.Visible = True
End With
End With
' destroy image file
Kill sFile
' end
Set cht = Nothing
Beep
End SubOption Explicit
Sub MultiCheatingUserpictureRestrictions()
' constants
Const ksFileExtension = ".jpg"
Const ksWS1 = "Summary Sheet"
Const ksWS2 = "Table Data"
' declarations
Dim cht As Chart, tbl As ListObject, rngC As Range
Dim sFile As String, lWidth As Long, lHeight As Long
Dim sCompany As String
Dim I As Integer, J As Integer, A As String
' start
sFile = ActiveWorkbook.Path & Application.PathSeparator & _
Format(Now(), "yyyymmddhhmmss") & ksFileExtension
' process
For I = 1 To Worksheets(ksWS2).ListObjects.Count
' assing table
Set tbl = Worksheets(ksWS2).ListObjects(I)
sCompany = tbl.Range.Offset(-2, 0).Cells(1, 1).Value
' build image file
With tbl.Range
lWidth = .Width
lHeight = .Height
.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
Set cht = ActiveSheet.ChartObjects.Add(.Top, .Left, lWidth, lHeight).Chart
End With
With cht
.Paste
.ChartArea.Border.LineStyle = 0
.Export sFile
.Parent.Delete
End With
Application.CutCopyMode = False
' identify company
Set tbl = Worksheets(ksWS1).ListObjects(1)
With tbl
For J = 1 To .DataBodyRange.Rows.Count
If .DataBodyRange.Cells(J, .ListColumns("Name").Index).Value = sCompany Then Exit For
Next J
End With
If J <= tbl.DataBodyRange.Rows.Count Then
' assign comment cell
Set rngC = tbl.DataBodyRange.Cells(J, tbl.ListColumns("Backend").Index)
' load image file
With rngC
If Not (.Comment Is Nothing) Then .ClearComments
.AddComment
With .Comment
With .Shape
.Fill.UserPicture sFile
.Width = lWidth
.Height = lHeight
End With
.Visible = False
End With
End With
' destroy image file
Kill sFile
End If
Next I
' end
Set rngC = Nothing
Set tbl = Nothing
Set cht = Nothing
Beep
End Sub