vba chosing picture and resize it : checkup says always two times same picture !

[littlepete]

hello again

my vba let 's me choose a name and then show all data from that person, included a picture,
found in a subdirectory (all pics in the same subdir).

but when i check after resizing and making a fit in a range, i always find TWO times the same picture,
one above the other.

i've put a counter to check which "road" the vba goes: it goes from 1 to 7 and then again from 1 to 7 ...
this is just one of a few other problems not solved...

this is the code:

Sub fotokiezen() ' ============================ CONTROL - X
On Error Resume Next
piccount = ActiveSheet.Pictures.Count
MsgBox "aantal fotos: " & piccount
Dim pic As Picture
Dim myrange As String
Dim PicWtoHRatio As Single
Dim CellWtoHRatio As Single
Range("fotokader").Select
myrange = Selection.Address
Dim a$, b$, c$, i As Integer
a$ = Range("invulnaam").Value
MsgBox "1"
For i = 1 To Len(a$)
    b$ = Mid(a$, i, 1)
    If b$ Like "[A-Z,a-z,0-9]" Then
        c$ = c$ & b$
    End If
Next i
MsgBox "2"
dezefoto = c$
' Set pic = ActiveSheet.Pictures.Insert("y:\buurt- en boodschappendienst\peter\organigram fotoalbum\" & dezefoto & ".jpg") ' === fotoreeks seniorama
Set pic = ActiveSheet.Pictures.Insert("d:\onedrive\my stuff\peter\organigramfotos\" & dezefoto & ".jpg") ' =================== fotoreeks thuis
pic.Select
MsgBox "3"
With Range("fotokader").MergeArea
PicWtoHRatio = .Width / .Height
End With
MsgBox "4"
   With Selection.ShapeRange
        .LockAspectRatio = msoTrue
        If .Width > .Height Then
MsgBox "5a"
            MsgBox "brede foto"
            .Width = Range(myrange).Width
            .Width = .Width * 0.9
                If .Height > Range(myrange).Height Then .Height = Range(myrange).Height * 0.6
        Else
MsgBox "5b"
            MsgBox "hoge foto"
            .Height = Range(myrange).Height
            .Height = .Height * 0.9
                If .Width > Range(myrange).Width Then .Width = Range(myrange).Width * 0.8
        End If
MsgBox "6"
'        .Left = .Left + (Range("fotokader").Width - pic.Width) / 2
        .Top = .Top + (Range("fotokader").Height - pic.Height) / 2
   End With
MsgBox "7"
End Sub

 

[Jerry Sullivan]

Hi littlepete, It sounds like there is something causing this Sub to be executed twice. What you have observed should not happen if the sub was only executed once.

Do you have any event code in the worksheet or workbook?

I recommend that you not use this general error handler for your entire procedure.

On Error Resume Next

Doing so hides the effects of errors which makes developing and debugging code more difficult.

 

[littlepete]

hello jerry

there are two event checkers: one to check if two cells (j31 and j56 on the first sheet) are filled in; a second to check if the listbox is filled...
when that listbox is filled, and one option (name) is clicked data of that person is shown on 70 rows (down at the end of the sheet), including a picture,
having the complete name of that person as name (for ex.: dejaegerpeter; sullivanjerry,...)

i will try to see what happens when the event checkers are pauzed...

thanks for your ideas !
pete