Bug in code, function repeats call when open excel file

Question

Bug in code, function repeats call when open excel file

Navigation

#1 by (4 votes)

4

Following this question: link

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

This code has an error that is, whenever the Excel file starts, the cell that is selected will receive the value and all the functions that are present in the file.

Example: the PrinciQualidade14 function has an integer as input parameter and returns the image corresponding to that number (it returns in the cell where it was called)

Problem: I call the 4x function

CELL B1=PrinciQualidade14(2)
CELL B2=PrinciQualidade14(12)
CELL B3=PrinciQualidade14(6)
CELL B4=PrinciQualidade14(1)

When you open excel again this will happen (without doing anything):

CELL A1=PrinciQualidade14(2); PrinciQualidade14(12); PrinciQualidade14(6); PrinciQualidade14(1)

Any ideas for solving this problem?

Thank you

Update

Repeating images:

StrangethatIcannotreproducetheerror,itjusthappens.UsuallyitisalwaysthatwithinthesamecellImovetheimgtothesideswhenIreopenthefileitwillduplicate(notalways).

AnotherstrangepointthatIdonotknowifitisnormalisthefunctiontobecalledntimes(n=thenumberoftimesthefunctionisusedinthefile).Iinsertedthiscodelooksattheresult:

flag=HASpic(Application.Caller)IfflagThenDebug.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

Result:

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

excel vba

asked by anonymous 12.02.2016 / 17:51

1 answer

Questions about formatting hexadecimal numbers in java for use in MD5 PDF decode base64

score 4 · Accepted Answer

Use Application.Caller , which returns the cell in which the function was called.

Replace this snippet:

InsertPictureInRange LNumber, Application.ActiveCell

For this:

InsertPictureInRange LNumber, Application.Caller

In part, adjust your code:

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_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