After several attempts I got to this code, I am no expert in VBA so any improvement please advise.
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\14_Q_Basics_img\1.png"
texto = "11111111111"
Case Is = 2
PictureFileName = "C:\Users\" & Environ("USERNAME") & "\AppData\Roaming\Microsoft\AddIns\14_Q_Basics_img\2.png"
texto = "22222222222222"
Case Is = 3
PictureFileName = "C:\Users\" & Environ("USERNAME") & "\AppData\Roaming\Microsoft\AddIns\14_Q_Basics_img\3.png"
texto = "3333333333"
Case Is = 4
PictureFileName = "C:\Users\" & Environ("USERNAME") & "\AppData\Roaming\Microsoft\AddIns\14_Q_Basics_img\4.png"
texto = "4444444444444"
Case Is = 5
PictureFileName = "C:\Users\" & Environ("USERNAME") & "\AppData\Roaming\Microsoft\AddIns\14_Q_Basics_img\5.png"
texto = "555555555555555"
Case Is = 6
PictureFileName = "C:\Users\" & Environ("USERNAME") & "\AppData\Roaming\Microsoft\AddIns\14_Q_Basics_img\6.png"
texto = "66666666666"
Case Is = 7
PictureFileName = "C:\Users\" & Environ("USERNAME") & "\AppData\Roaming\Microsoft\AddIns\14_Q_Basics_img\7.png"
texto = "777777777"
Case Is = 8
PictureFileName = "C:\Users\" & Environ("USERNAME") & "\AppData\Roaming\Microsoft\AddIns\14_Q_Basics_img\8.png"
texto = "888888888"
Case Is = 9
PictureFileName = "C:\Users\" & Environ("USERNAME") & "\AppData\Roaming\Microsoft\AddIns\14_Q_Basics_img\9.png"
texto = "9999999999"
Case Is = 10
PictureFileName = "C:\Users\" & Environ("USERNAME") & "\AppData\Roaming\Microsoft\AddIns\14_Q_Basics_img\10.png"
texto = "1000000000"
Case Is = 11
PictureFileName = "C:\Users\" & Environ("USERNAME") & "\AppData\Roaming\Microsoft\AddIns\14_Q_Basics_img\11.png"
texto = "111111111"
Case Is = 12
PictureFileName = "C:\Users\" & Environ("USERNAME") & "\AppData\Roaming\Microsoft\AddIns\14_Q_Basics_img\12.png"
texto = "12222222222222"
Case Is = 13
PictureFileName = "C:\Users\" & Environ("USERNAME") & "\AppData\Roaming\Microsoft\AddIns\14_Q_Basics_img\13.png"
texto = "1333333333333"
Case Is = 14
PictureFileName = "C:\Users\" & Environ("USERNAME") & "\AppData\Roaming\Microsoft\AddIns\14_Q_Basics_img\14.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 repeats the function N times, thus bringing N images to that cell.
jsantos how is the execution done? selecting and inserting number in any cell?
– h1k3r
In my case I saved the excel file where I have this code as excel add-in (.xlam) and added as add-in - (tab Programmer > add-in) after that from any cell in any file I have access to this function... I just have to call
=PrinciQualidade14(1)
– jsantos1991