littlepete
Well-known Member
- Joined
- Mar 26, 2015
- Messages
- 503
- Office Version
- 365
- Platform
- Windows
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:
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:
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