5

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

Repetição das imagens: inserir a descrição da imagem aqui

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

1 Resposta 1

4

Utilize o Application.Caller, que retorna a célula em que a função foi chamada.

Substitua esse trecho:

InsertPictureInRange LNumber, Application.ActiveCell

Por este:

InsertPictureInRange LNumber, Application.Caller

Em parte, segue ajuste do seu código:

Function PrinciQualidade(iNumero As Integer) As String

    If iNumero > 0 And iNumero < 15 Then
        InserirImagem iNumero, Application.Caller
    Else
        Debug.Print "Numero incorreto"
    End If

    PrinciQualidade14 = LNumber
End Function

Sub InserirImagem(iNumero As Integer, rCelulaDestino As Range)
    Dim sCaminhoBase As String, sNomeUsuario As String
    Dim matrizComentario As Variant
    Dim oImagem As Object

    sCaminho = Environ("AppData") & "\Microsoft\AddIns\14_Q_Basics_img\"
    sImagem = sCaminho & iNumero & ".png"
    matrizComentario = Array("111", "222", "333", "444", "555", "666", "777", "888", "999", "10000", "11111", "122222", "1333", "1444")

    If Dir(sImagem) = "" Then Exit Sub

    Set oImagem = ActiveSheet.Shapes.AddPicture(sImagem, False, True, 0, 0, -1, -1)

    With rCelulaDestino
        .HorizontalAlignment = xlCenter
        .ClearComments
        .AddComment matrizComentario(iNumero - 1)
        .Comment.Visible = False
        .ClearContents
    End With

    With oImagem
        .Top = rCelulaDestino.Top
        .Left = rCelulaDestino.Left
        .Width = rCelula.Width
        .Height = rCelulaDestino.Height
        .Placement = 1
    End With

End Sub
5
  • Muito obrigado, ainda não testei mas o código ficou muito mais simples ^^ Commented 12/02/2016 às 21:39
  • Tens um erro nesta linha .Width = rCelula.Width deveria de ser assim -> .Width = rCelulaDestino.Width certo... Commented 15/02/2016 às 11:14
  • O erro continua, mas agora repete-se sempre na célula onde a função foi chamada. Consegues ajudar? Commented 15/02/2016 às 13:24
  • Você pode tirar um print do problema? @jsantos1991 Commented 15/02/2016 às 13:45
  • Fiz update a pergunta verifica se ajuda... Mt obrigado Commented 15/02/2016 às 15:27

Você deve fazer log-in para responder a esta pergunta.

Esta não é a resposta que você está procurando? Pesquise outras perguntas com a tag .