add image as comment VBA

Question

I found this code to insert images into excel 2013 but the images are large than the cells they\'re going into. I think the best option it to load the images as comments.

Answer 1

Paste the below code in ThisWorkbook and then close it and open it. Whenever you paste the screenshot in Cell it will automatically resize

Option Explicit

#If VBA7 Then
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
Private Declare PtrSafe Function GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" (ByVal wFormat As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long
#Else
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" (ByVal wFormat As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long
#End If

Private WithEvents CmndBras As CommandBars


Private Sub Workbook_Open()
Set CmndBras = Application.CommandBars
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal sh As Object, ByVal Target As Range)
Set CmndBras = Application.CommandBars
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Set CmndBras = Nothing
End Sub


Private Sub CmndBras_OnUpdate()
Dim oShp As Shape

On Error Resume Next
If TypeName(Selection) <> "Range" Then
    If ScreenShotInClipBoard Then
        Set oShp = Selection.Parent.Shapes(Selection.Name)
        With oShp
        If .AlternativeText <> "Tagged" Then
            If .Type = msoPicture Then
                If Err.Number = 0 Then
                    .AlternativeText = "Tagged"
                    .Visible = False
                    .LockAspectRatio = msoFalse
                    .Top = ActiveWindow.RangeSelection.Top
                    .Left = ActiveWindow.RangeSelection.Left
                    .Width = ActiveWindow.RangeSelection.Width
                    .Height = ActiveWindow.RangeSelection.Height
                    ActiveWindow.RangeSelection.Activate
                    .Visible = True
                End If
            End If
        End If
        End With
    End If
End If
End Sub


Private Function ScreenShotInClipBoard() As Boolean
Dim sClipboardFormatName As String, sBuffer As String
Dim CF_Format As Long, i As Long
Dim bDtataInClipBoard As Boolean

If OpenClipboard(0) Then
    CF_Format = EnumClipboardFormats(0&)
    Do While CF_Format <> 0
        sClipboardFormatName = String(255, vbNullChar)
        i = GetClipboardFormatName(CF_Format, sClipboardFormatName, 255)
        sBuffer = sBuffer & Left(sClipboardFormatName, i)
       bDtataInClipBoard = True
         CF_Format = EnumClipboardFormats(CF_Format)
    Loop
    CloseClipboard
 End If
 ScreenShotInClipBoard = bDtataInClipBoard And Len(sBuffer) = 0
End Function