Create add-on that associates number with an image

Question

Create add-on that associates number with an image

Navigation

#1 by (2 votes)

4

I need to create an add-in that associates a number with an image.

Example:

=getImageQualidade(1) 'e nessa célula ficava a imagem.

I already know how to create / implement a basic add-in in Excel link

Now my problem is in the code.

How do I return the image in the cell where it is called

How do I search the image for the file

Code used with different tests:

Function getImageQualidade(x As Integer) As Object
    'InsertPictureInRange "C:\FolderName\PictureFileName.gif", _
    '   Range("B5:D10")
    'InsertPictureInRange "C:\Users\FolderName\DOCUME~1\Imagem1.jpg", _
    '   Range("B5:D30")
    Dim LNumber As Integer

    LNumber = x

    Select Case LNumber
   Case Is = 1
      Dim aux As Object
      aux = InsertPictureInRange("C:\Users\FolderName\DOCUME~1.png")
      Set TestInsertPictureInRange = aux
   Case Is = 2
      Set TestInsertPictureInRange = InsertPictureInRange("C:\Users\FolderName\DOCUME~1.png")
   Case Is = 3
      Set TestInsertPictureInRange = InsertPictureInRange("C:\Users\FolderName\DOCUME~1.png")
   Case Else
      MsgBox "numero não existe"

   End Select

End Function

Function InsertPictureInRange(PictureFileName As String) As Object
' inserts a picture and resizes it to fit the TargetCells range
Dim p As Object, t As Double, l As Double, w As Double, h As Double
    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Function
    If Dir(PictureFileName) = "" Then Exit Function
    ' import picture
    Set p = ActiveSheet.Pictures.Insert(PictureFileName)
    With p
        .Top = t
        .Left = l
        .Width = w
        .Height = h
    End With
    InsertPictureInRange = p
    Set p = Nothing
End Function

Code original

Asaresultoftheexampleabove

=getImageQualidade(1)

excel vba

asked by anonymous 09.02.2016 / 14:50

1 answer

Query in two tables at the same time How to add elements in the "x" position of a std :: vector

score 2 · Answer 1

After several attempts I got to this code, I am no VBA expert so any improvements please let me know.

Code:

Function PrinciQualidade14(LNumber As Integer) As String

    If LNumber < 15 And LNumber > 0 Then
    InsertPictureInRange LNumber, Application.ActiveCell
    Else
    Debug.Print "Numero incorreto"
    End If
    PrinciQualidade14 = LNumber
    Exit Function
End Function

Sub InsertPictureInRange(LNumber As Integer, TargetCells As Range)
' inserts a picture and resizes it to fit the TargetCells range
    Dim p As Object
    Dim t As Double, l As Double, w As Double, h As Double
    Dim texto As String, PictureFileName As String
    Dim commentBox As Comment

   Select Case LNumber
   Case Is = 1
        PictureFileName = "C:\Users\" & Environ("USERNAME") & "\AppData\Roaming\Microsoft\AddIns_Q_Basics_img.png"
        texto = "11111111111"
   Case Is = 2
        PictureFileName = "C:\Users\" & Environ("USERNAME") & "\AppData\Roaming\Microsoft\AddIns_Q_Basics_img.png"
        texto = "22222222222222"
   Case Is = 3
        PictureFileName = "C:\Users\" & Environ("USERNAME") & "\AppData\Roaming\Microsoft\AddIns_Q_Basics_img.png"
        texto = "3333333333"
   Case Is = 4
        PictureFileName = "C:\Users\" & Environ("USERNAME") & "\AppData\Roaming\Microsoft\AddIns_Q_Basics_img.png"
        texto = "4444444444444"
   Case Is = 5
        PictureFileName = "C:\Users\" & Environ("USERNAME") & "\AppData\Roaming\Microsoft\AddIns_Q_Basics_img.png"
        texto = "555555555555555"
   Case Is = 6
        PictureFileName = "C:\Users\" & Environ("USERNAME") & "\AppData\Roaming\Microsoft\AddIns_Q_Basics_img.png"
        texto = "66666666666"
   Case Is = 7
        PictureFileName = "C:\Users\" & Environ("USERNAME") & "\AppData\Roaming\Microsoft\AddIns_Q_Basics_img.png"
        texto = "777777777"
   Case Is = 8
        PictureFileName = "C:\Users\" & Environ("USERNAME") & "\AppData\Roaming\Microsoft\AddIns_Q_Basics_img.png"
        texto = "888888888"
   Case Is = 9
        PictureFileName = "C:\Users\" & Environ("USERNAME") & "\AppData\Roaming\Microsoft\AddIns_Q_Basics_img.png"
        texto = "9999999999"
   Case Is = 10
        PictureFileName = "C:\Users\" & Environ("USERNAME") & "\AppData\Roaming\Microsoft\AddIns_Q_Basics_img.png"
        texto = "1000000000"
   Case Is = 11
        PictureFileName = "C:\Users\" & Environ("USERNAME") & "\AppData\Roaming\Microsoft\AddIns_Q_Basics_img.png"
        texto = "111111111"
   Case Is = 12
        PictureFileName = "C:\Users\" & Environ("USERNAME") & "\AppData\Roaming\Microsoft\AddIns_Q_Basics_img.png"
        texto = "12222222222222"
   Case Is = 13
        PictureFileName = "C:\Users\" & Environ("USERNAME") & "\AppData\Roaming\Microsoft\AddIns_Q_Basics_img.png"
        texto = "1333333333333"
   Case Is = 14
        PictureFileName = "C:\Users\" & Environ("USERNAME") & "\AppData\Roaming\Microsoft\AddIns_Q_Basics_img.png"
        texto = "14444444444444"

   Case Else
      Debug.Print "numero errado"

   End Select


    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
    If Dir(PictureFileName) = "" Then Exit Sub
    ' import picture
    '@parmetros
    'PictureFileName - diretoria ficheiro
    'false - copy image
    'true - break link com a imagem
    Set p = ActiveSheet.Shapes.AddPicture(PictureFileName, False, True, 0, 0, -1, -1)


    ' determine positions
    With TargetCells
        .HorizontalAlignment = xlCenter
        t = .Top
        l = .Left
        w = .Offset(0, .Columns.Count).Left - .Left
        h = .Offset(.Rows.Count, 0).Top - .Top
    End With

    'add comment
    Application.ActiveCell.ClearComments

    Set commentBox = Application.ActiveCell.AddComment
    With commentBox
    .Text Text:=texto
    ' Set the visible to True when you always want the image displayed, and
    ' to False when you want it displayed only when you click on the cell.
    .Visible = False
  End With


    ' position picture
    With p

        .Top = t
        .Left = l
        .Width = w
        .Height = h
        .Placement = 1
    End With
    TargetCells.ClearContents
    Set p = Nothing
End Sub

ps: The code has at least 1 small bug, which is sometimes repeated N times, thus bringing N images to that cell.