Auto Pictures in Comments

DougDR

DougDR

Board Regular
Joined
Jun 6, 2011
Messages
121
I have a sheet that is a stock system I use for an Ecommerce business. What I wanted was to be able to automatically have a picture of the product placed into the comment of the description cell.

For this I gave the following info : “I have a stock number in ColumnE ... a description in ColumnK and a picture name (name.jpg) in ColumnBH and in cell CD11 a formular “=CD10&"\"&E11&"\"&BH11” which gives me a value of “E:\My Documents\Bid or Buy\New SearchDesign Stock\SD-CC-0001\SD151e.jpg” The SD-**-#### is the folder where the picture lies.

Thanks to SuperFerret who gave me the following code the placement of the pictures work great

The only problem was, a small one but important, the size of the comments. She suggested that I record a macro resizing a comment to see the code, this I did.

The problem now is where in her code does the resizing code go??????

The first code places the picture the second is the recorded macro.


Code: 
Option Explicit
Sub Add_Comments()
    Dim myPict As Object
    Dim curWks As Worksheet
    Dim myRng As Range
    Dim myCell As Range

    Set curWks = Sheets("  ListingControl") ' Change to suit

    With curWks  
      Set myRng = .Range("CD11", .Cells(.Rows.Count, "CD").End(xlUp))
    End With

    curWks.Columns("  K").ClearComments

    For Each myCell In myRng.Cells  
      If Trim(myCell.Value) = "" Then
        'do nothing
      ElseIf Dir(CStr(myCell.Value)) = "" Then
        'picture not there!
      MsgBox myCell.Value & " Doesn't exist!"
      Else
With myCell.Offset(0, -71) '71 columns to the left of BH (K)         
            .AddComment("").Shape.Fill.UserPicture (myCell.Value)
        End With
      End If
    Next myCell
End Sub

Secound


Code: 
Sub Macro4() ' ' Macro4 Macro ' Macro recorded 2011/06/15 by DOUG DAVEY '  '     Range("F10").AddComment     Range("F10").Comment.Visible = False     Range("F10").Comment.Text Text:=""     With Selection.Font         .Name = "Tahoma"         .FontStyle = "Bold"         .Size = 8         .Strikethrough = False         .Superscript = False         .Subscript = False         .OutlineFont = False         .Shadow = False         .Underline = xlUnderlineStyleNone         .ColorIndex = xlAutomatic     End With     Selection.ShapeRange.Fill.Transparency = 0#     Selection.ShapeRange.Line.Weight = 0.75     Selection.ShapeRange.Line.DashStyle = msoLineSolid     Selection.ShapeRange.Line.Style = msoLineSingle     Selection.ShapeRange.Line.Transparency = 0#     Selection.ShapeRange.Line.Visible = msoTrue     Selection.ShapeRange.Line.ForeColor.RGB = RGB(0, 0, 0)     Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)     Selection.ShapeRange.Fill.Visible = msoTrue     Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 255, 255)     Selection.ShapeRange.Fill.BackColor.SchemeColor = 80     Selection.ShapeRange.Fill.UserPicture "E:\My Documents\My Pictures\Globe.jpg"     Selection.ShapeRange.LockAspectRatio = msoTrue     Selection.ShapeRange.Height = 141.75     Selection.ShapeRange.Width = 141.75     Selection.ShapeRange.ScaleHeight 1.39, msoFalse, msoScaleFromTopLeft     Selection.ShapeRange.ScaleHeight 1.11, msoFalse, msoScaleFromTopLeft End Sub
 
Last edited:

Excel Facts

Copy PDF to Excel
Select data in PDF. Paste to Microsoft Word. Copy from Word and paste to Excel.
Sort by date Sort by votes
Sorry the secound code

<!--[if gte mso 9]><xml> <w:WordDocument> <w:View>Normal</w:View> <w:Zoom>0</w:Zoom> <w:PunctuationKerning/> <w:ValidateAgainstSchemas/> <w:SaveIfXMLInvalid>false</w:SaveIfXMLInvalid> <w:IgnoreMixedContent>false</w:IgnoreMixedContent> <w:AlwaysShowPlaceholderText>false</w:AlwaysShowPlaceholderText> <w:Compatibility> <w:BreakWrappedTables/> <w:SnapToGridInCell/> <w:WrapTextWithPunct/> <w:UseAsianBreakRules/> <w:DontGrowAutofit/> </w:Compatibility> <w:BrowserLevel>MicrosoftInternetExplorer4</w:BrowserLevel> </w:WordDocument> </xml><![endif]--><!--[if gte mso 9]><xml> <w:LatentStyles DefLockedState="false" LatentStyleCount="156"> </w:LatentStyles> </xml><![endif]--><!--[if gte mso 10]> <style> /* Style Definitions */ table.MsoNormalTable {mso-style-name:"Table Normal"; mso-tstyle-rowband-size:0; mso-tstyle-colband-size:0; mso-style-noshow:yes; mso-style-parent:""; mso-padding-alt:0mm 5.4pt 0mm 5.4pt; mso-para-margin:0mm; mso-para-margin-bottom:.0001pt; mso-pagination:widow-orphan; font-size:10.0pt; font-family:"Times New Roman"; mso-ansi-language:#0400; mso-fareast-language:#0400; mso-bidi-language:#0400;} </style> <![endif]-->
Code: 
Sub Macro4()
  '
  ' Macro4 Macro
  ' Macro recorded 2011/06/15 by DOUG DAVEY
  '
   
  '
      Range("F10").AddComment
      Range("F10").Comment.Visible = False
      Range("F10").Comment.Text Text:=""
      With Selection.Font
          .Name = "Tahoma"
          .FontStyle = "Bold"
          .Size = 8
          .Strikethrough = False
          .Superscript = False
          .Subscript = False
          .OutlineFont = False
          .Shadow = False
          .Underline = xlUnderlineStyleNone
          .ColorIndex = xlAutomatic
      End With
      Selection.ShapeRange.Fill.Transparency = 0#
      Selection.ShapeRange.Line.Weight = 0.75
      Selection.ShapeRange.Line.DashStyle = msoLineSolid
      Selection.ShapeRange.Line.Style = msoLineSingle
      Selection.ShapeRange.Line.Transparency = 0#
      Selection.ShapeRange.Line.Visible = msoTrue
      Selection.ShapeRange.Line.ForeColor.RGB = RGB(0, 0, 0)
      Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
      Selection.ShapeRange.Fill.Visible = msoTrue
      Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 255, 255)
      Selection.ShapeRange.Fill.BackColor.SchemeColor = 80
      Selection.ShapeRange.Fill.UserPicture "E:\My Documents\My Pictures\Globe.jpg"
      Selection.ShapeRange.LockAspectRatio = msoTrue
      Selection.ShapeRange.Height = 141.75
      Selection.ShapeRange.Width = 141.75
      Selection.ShapeRange.ScaleHeight 1.39, msoFalse, msoScaleFromTopLeft
      Selection.ShapeRange.ScaleHeight 1.11, msoFalse, msoScaleFromTopLeft
  End Sub
 
Upvote 0
Maybe:

Rich (BB code): 
Sub Add_Comments()
    Dim myPict As Object
    Dim curWks As Worksheet
    Dim myRng As Range
    Dim myCell As Range

    Set curWks = Sheets("  ListingControl") ' Change to suit

    With curWks  
      Set myRng = .Range("CD11", .Cells(.Rows.Count, "CD").End(xlUp))
    End With

    curWks.Columns("  K").ClearComments

    For Each myCell In myRng.Cells  
      If Trim(myCell.Value) = "" Then
        'do nothing
      ElseIf Dir(CStr(myCell.Value)) = "" Then
        'picture not there!
      MsgBox myCell.Value & " Doesn't exist!"
      Else
            With myCell.Offset(0, -71) '71 columns to the left of BH (K)         
                .AddComment("").Shape.Fill.UserPicture (myCell.Value)
                .Comment.Shape.Height = 141.75
                .Comment.Shape.Width = 141.75
            End With
      End If
    Next myCell
End Sub
 
Upvote 0
Hi Andrew Poulsom

Thank you so much it works great .... boy you guys are fantastic help ... thanks again.

the code now looks like this

Code: 
Sub AddPictureComments()
'
' AddPictureComments Macro
' Macro recorded 2011/06/14 by DOUG DAVEY

   Dim myPict As Object
    Dim curWks As Worksheet
    Dim myRng As Range
    Dim myCell As Range
 
    Set curWks = Sheets("ListingControl") ' Change to suit
 
    With curWks
      Set myRng = .Range("CD11", .Cells(.Rows.Count, "CD").End(xlUp))
    End With
 
    curWks.Columns("K").ClearComments
    '.Comment.Shape.ScaleWidth 5.87, msoFalse, msoScaleFromTopLeft
    '.Comment.Shape.ScaleHeight 2.26, msoFalse, msoScaleFromTopLeft
 
 
    For Each myCell In myRng.Cells
      If Trim(myCell.Value) = "" Then
        'do nothing
      ElseIf Dir(CStr(myCell.Value)) = "" Then
        'picture not there!
      MsgBox myCell.Value & " Doesn't exist!"
      Else
        With myCell.Offset(0, -71) '71 columns to the left of BH (K)
            .AddComment("").Shape.Fill.UserPicture (myCell.Value)
           [COLOR=Lime] '.Comment.Shape.Height = 180[/COLOR]
            [COLOR=Red].Comment.Shape.Width = 220
            .Comment.Shape.ScaleHeight 4, msoFalse, msoScaleFromTopLeft
            .Comment.Shape.LockAspectRatio = msoTrue[/COLOR]
            [COLOR=Lime]'.Comment.Shape.ScaleHeight 4, msoFalse, msoScaleFromTopLeft[/COLOR]
        End With
      End If
 
Upvote 0
<!--[if gte mso 9]><xml> <w:WordDocument> <w:View>Normal</w:View> <w:Zoom>0</w:Zoom> <w:PunctuationKerning/> <w:ValidateAgainstSchemas/> <w:SaveIfXMLInvalid>false</w:SaveIfXMLInvalid> <w:IgnoreMixedContent>false</w:IgnoreMixedContent> <w:AlwaysShowPlaceholderText>false</w:AlwaysShowPlaceholderText> <w:Compatibility> <w:BreakWrappedTables/> <w:SnapToGridInCell/> <w:WrapTextWithPunct/> <w:UseAsianBreakRules/> <w:DontGrowAutofit/> </w:Compatibility> <w:BrowserLevel>MicrosoftInternetExplorer4</w:BrowserLevel> </w:WordDocument> </xml><![endif]--><!--[if gte mso 9]><xml> <w:LatentStyles DefLockedState="false" LatentStyleCount="156"> </w:LatentStyles> </xml><![endif]--><!--[if gte mso 10]> <style> /* Style Definitions */ table.MsoNormalTable {mso-style-name:"Table Normal"; mso-tstyle-rowband-size:0; mso-tstyle-colband-size:0; mso-style-noshow:yes; mso-style-parent:""; mso-padding-alt:0mm 5.4pt 0mm 5.4pt; mso-para-margin:0mm; mso-para-margin-bottom:.0001pt; mso-pagination:widow-orphan; font-size:10.0pt; font-family:"Times New Roman"; mso-ansi-language:#0400; mso-fareast-language:#0400; mso-bidi-language:#0400;} </style> <![endif]--> Hi Andrew

Thanks again .. I can not tell how much you have helped.

It seems that I got some idea about how VBA work ……. Not anywhere yet but I am starting to learn … thank you.

I tried a macro to move the comment to a new position. CODE BELOW the blue text. What happens is when I run the macro everything works well and as I pass the cursor over each cell the comment jumps up just right of the cell. With the added blue code the comments don’t change position but if I go in to edit a single comment it is in the new position as set in the code.
What am I doing wrong??
Code: 
Sub AddPictureComments()
'
' AddPictureComments Macro
' Macro recorded 2011/06/14 by DOUG DAVEY

   Dim myPict As Object
    Dim curWks As Worksheet
    Dim myRng As Range
    Dim myCell As Range
 
    Set curWks = Sheets("ListingControl") ' Change to suit
 
    With curWks
      Set myRng = .Range("CD11", .Cells(.Rows.Count, "CD").End(xlUp))
    End With
 
    curWks.Columns("K").ClearComments
    '.Comment.Shape.ScaleWidth 5.87, msoFalse, msoScaleFromTopLeft
    '.Comment.Shape.ScaleHeight 2.26, msoFalse, msoScaleFromTopLeft
 
 
    For Each myCell In myRng.Cells
      If Trim(myCell.Value) = "" Then
        'do nothing
      ElseIf Dir(CStr(myCell.Value)) = "" Then
        'picture not there!
      MsgBox myCell.Value & " Doesn't exist!"
      Else
        With myCell.Offset(0, -71) '71 columns to the left of BH (K)
            .AddComment("").Shape.Fill.UserPicture (myCell.Value)
            
[COLOR=Blue]            .Comment.Shape.IncrementLeft -320.25
            .Comment.Shape.IncrementTop -93.75[/COLOR]
            
            '.Comment.Shape.Height = 180
            .Comment.Shape.Width = 280
            .Comment.Shape.ScaleHeight 4, msoFalse, msoScaleFromTopLeft
            .Comment.Shape.LockAspectRatio = msoTrue
            '.Comment.Shape.ScaleHeight 4, msoFalse, msoScaleFromTopLeft

        End With
      End If
    Next myCell

End Sub
 
Upvote 0
DougDR,

The code that I wrote works but it uses a loop which kind of takes all the fun out of it as having a continious loop running in the background is not a good solution. Maybe, running the loop from an outside process like an on the fly created VBS or from a dll would eliminate the looping problems.

Anyway,try the following for the moment and see how it goes :


1- Add a Standard module to your Project and place in it the code below :

Code: 
Option Explicit
 
Private Type POINTAPI
    x As Long
    y As Long
End Type
 
 Private Type Offset
     Left As Single
    Top As Single
 End Type

 
Private Declare Function GetCursorPos Lib "user32" _
(lpPoint As POINTAPI) As Long

Private uOffset As Offset
Private AbsOffset As Boolean
Private bLooping As Boolean


'================
'Public routines.
'================

Public Sub Reposition_Comments _
(Left As Single, Top As Single, Optional AbsoluteOffset As Boolean)

    If Not bLooping Then
        bLooping = True
        uOffset.Left = Left
        uOffset.Top = Top
        AbsOffset = AbsoluteOffset
        Call StartLoop
    End If

End Sub

Public Sub Reset()

    bLooping = False
    
End Sub



'================
'Private routines.
'================

Private Sub StartLoop()

    OffsetComments OffsetPos:=uOffset, AbsoluteOffset:=AbsOffset

End Sub

 
Private Sub OffsetComments _
(OffsetPos As Offset, Optional AbsoluteOffset As Boolean)
 
    Dim tPt  As POINTAPI
    Dim oObj As Object
    Static oPrevObj As Object
    Static sngLeft As Single
    Static sngTop As Single
    
    
    On Error Resume Next
    
    
    Do
        GetCursorPos tPt
        Set oObj = _
        Application.ActiveWindow.RangeFromPoint(tPt.x, tPt.y)
        
        If Not oObj.Parent.Parent Is ThisWorkbook Then GoTo NextLoop
        
        If HasComment(oObj) Then
            With oObj.Comment
                If oPrevObj.Address <> oObj.Address Then
                    .Visible = True
                    If AbsoluteOffset Then
                        sngLeft = .Shape.Left
                        sngTop = .Shape.Top
                        .Shape.Left = OffsetPos.Left
                        .Shape.Top = OffsetPos.Top
                    Else
                        .Shape.IncrementLeft OffsetPos.Left
                        .Shape.IncrementTop OffsetPos.Top
                    End If
                End If
            End With
        End If
        
        If HasComment(oPrevObj) Then
            With oPrevObj.Comment
                If oObj.Address <> oPrevObj.Address Then
                    .Visible = False
                    If AbsoluteOffset Then
                        .Shape.Left = sngLeft
                        .Shape.Top = sngTop
                    Else
                        .Shape.IncrementLeft -OffsetPos.Left
                        .Shape.IncrementTop -OffsetPos.Top
                    End If
                End If
            End With
        End If
        
NextLoop:
        Set oPrevObj = oObj
        DoEvents
    Loop Until Not bLooping
 
End Sub


Private Function HasComment(Target As Range) As Boolean
 
    On Error Resume Next
    HasComment = ObjPtr(Target.Comment)
    
End Function


2- Place this in the ThisWorkbook module :

Code: 
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Call Reset
End Sub


3- Then you would amend your existing code as follows : ( Changed in red)

Code: 
Sub AddPictureComments()
'
' AddPictureComments Macro
' Macro recorded 2011/06/14 by DOUG DAVEY

   Dim myPict As Object
    Dim curWks As Worksheet
    Dim myRng As Range
    Dim myCell As Range
 
    Set curWks = Sheets("ListingControl") ' Change to suit
 
    With curWks
      Set myRng = .Range("CD11", .Cells(.Rows.Count, "CD").End(xlUp))
    End With
 
    curWks.Columns("K").ClearComments
    '.Comment.Shape.ScaleWidth 5.87, msoFalse, msoScaleFromTopLeft
    '.Comment.Shape.ScaleHeight 2.26, msoFalse, msoScaleFromTopLeft
 
 
    For Each myCell In myRng.Cells
      If Trim(myCell.Value) = "" Then
        'do nothing
      ElseIf Dir(CStr(myCell.Value)) = "" Then
        'picture not there!
      MsgBox myCell.Value & " Doesn't exist!"
      Else
        With myCell.Offset(0, -71) '71 columns to the left of BH (K)
            .AddComment("").Shape.Fill.UserPicture (myCell.Value)
            
[B][COLOR=Red]'            .Comment.Shape.IncrementLeft -320.25
'            .Comment.Shape.IncrementTop -93.75[/COLOR][/B]
            
            '.Comment.Shape.Height = 180
            .Comment.Shape.Width = 280
            .Comment.Shape.ScaleHeight 4, msoFalse, msoScaleFromTopLeft
            .Comment.Shape.LockAspectRatio = msoTrue
            '.Comment.Shape.ScaleHeight 4, msoFalse, msoScaleFromTopLeft

        End With
      End If
    Next myCell

    [B][COLOR=Red]Call Reposition_Comments _
    (Left:=-320.25, _
    Top:=-93.75, _
    AbsoluteOffset:=False)[/COLOR][/B]


End Sub
Just for the record, here is a generic Workbook demo that shows how we can add this functionality .
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

melodramatic
  • Question Question
Vba - insert photo with varying sizes
Replies
1
Views
558
Micron
M
O
  • Solved
Determine picture height in VBA
2
Replies
11
Views
3K
jolivanes
jolivanes
I
  • Question Question
How do you update all existing Notes Previously known as comments and put something in the text field using VBA Code
Replies
1
Views
1K
sijpie
sijpie
J
  • Question Question
link pictures from Sharepoint to Excel macro
2 3 4
Replies
35
Views
9K
jc83ph
J
I
  • Question Question
Resize of comments box / shape etc
2
Replies
17
Views
998
ipbr21054
I

Forum statistics

Threads
1,224,527
Messages
6,179,357
Members
452,907
Latest member
Roland Deschain

Share this page

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
Back
Top