No seguimento desta pergunta: https://pt.stackoverflow.com/a/112899/13237
Código:
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
Este código possui um erro que é, sempre que início o ficheiro Excel, a célula que estiver selecionada vai receber o valor e todas as funções que tiverem presentes no ficheiro.
Exemplo:
a função PrinciQualidade14
tem como parâmetro de entrada um inteiro e devolve a imagem correspondente a esse numero(devolve na célula onde foi chamado)
Problema: Eu chamo a função 4x
CELL B1=PrinciQualidade14(2)
CELL B2=PrinciQualidade14(12)
CELL B3=PrinciQualidade14(6)
CELL B4=PrinciQualidade14(1)
Quando voltar a abrir o excel vai acontecer isto(sem fazer nada):
CELL A1=PrinciQualidade14(2); PrinciQualidade14(12); PrinciQualidade14(6); PrinciQualidade14(1)
Alguma ideia para solucionar este problema?
Obrigado
Update
Estranho que eu não consigo reproduzir o erro, simplesmente acontece. Normalmente é sempre que dentro da mesma celula mexo um pouco a img para os lados quando voltar a abrir o ficheiro vai duplicar(nem sempre acontece).
Outro ponto estranho que não sei se é normal é a função ser chamada n vezes(n = a nº de vezes que a função é usada no ficheiro). Inseri este código olha o resultado:
flag = HASpic(Application.Caller)
If flag Then
Debug.Print "Já tem picture"
PrinciQualidade14 = iNumero
Exit Function
Else
Debug.Print "pumba picture"
If iNumero > 0 And iNumero < 15 Then
InserirImagem iNumero, Application.Caller
Else
Debug.Print "Numero incorreto"
End If
End If
Resultado:
Já tem picture
Já tem picture
Já tem picture
Já tem picture
Já tem picture
Já tem picture
Já tem picture
Já tem picture
Já tem picture
picture
Valor: $F$5
Já tem picture
Já tem picture
picture
Valor: $F$2