Dear All,
I am preparing a report for each inspection and I am adding photos about my findings. I have tried to solve this with vba. It works perfectly with landscape photos but it is not working with portrait photos. I have tried to rotate but it not working. Could you please check and help me? Below you can check the photos of problem and codes.
Insert picture function
Code:
Function InsertPicture(ByVal FName As String, ByVal Where As Range, _
Optional ByVal LinkToFile As Boolean = False, _
Optional ByVal SaveWithDocument As Boolean = True, _
Optional ByVal LockAspectRatio As Boolean = True) As Shape
Dim U As Shape
'Inserts the picture file FName as link or permanently into Where
Dim S As Shape, SaveScreenUpdating, SaveCursor
SaveCursor = Application.Cursor
SaveScreenUpdating = Application.ScreenUpdating
Application.Cursor = xlWait
Application.ScreenUpdating = False
With Where
'Insert in original size
Set S = Where.Parent.Shapes.AddPicture( _
FName, LinkToFile, SaveWithDocument, .Left, .Top, -1, -1)
'You f*cked need to find solution for portrait photos
'If S.Rotation = 90 Then S.Rotation = 0
'Keep the proportions?
S.LockAspectRatio = LockAspectRatio
'Scale it to fit the cell
S.Width = .Width
S.IncrementRotation 360
If S.Height > .Height Or Not LockAspectRatio Then S.Height = .Height
'Move it to the middle of the cells
If S.Width < Where.Width Then S.Left = Where.Left + (Where.Width - S.Width) / 2
If S.Height < Where.Height Then S.Top = Where.Top + (Where.Height - S.Height) / 2
End With
Set InsertPicture = S
Application.Cursor = SaveCursor
Application.ScreenUpdating = SaveScreenUpdating
End Function
Code:
Sub Trial_Pic()
Dim FName As String
Dim i As Long, j As Long, k As Long, n As Long, S As Long
Dim Where As Range, This As Range, Yazdir As Range, Alan As Range
Set Alan = Range("M6:M100")
With Application.FileDialog(msoFileDialogFilePicker)
'Allow only pictures don't forget Murti
.Filters.Clear
.Filters.Add "Pictures", "*.bmp;*.jpg;*.jpeg;*.png;*.gif"
'Allow more then one picture to be inserted
.AllowMultiSelect = True
'Done if the user abort the dialog
If Not .Show Then Exit Sub
'Multiple pictures into the areas?
If .SelectedItems.Count > Alan.Count Then
Do
n = Application.InputBox("How many pictures per area?", "Trial_Pic", .SelectedItems.Count \ Alan.Count, Type:=2)
If n = 0 Then Exit Sub
Loop Until n > 0
Else
n = 1
End If
'Perform max. possible pictures
For i = 1 To Alan.Count
Set Where = Alan(i)
S = Where.Rows.Count \ n
For j = 1 To n
'Picture available?
k = k + 1
If k > .SelectedItems.Count Then Exit Sub
'Where to place
Set This = Where.Resize(S).Offset((j - 1) * S)
Set Yazdir = Where.Resize(, S).Offset(, (j - 1) * S + 1)
'Insert into the sheet
InsertPicture .SelectedItems(k), This
'Define print area Murti
ActiveSheet.PageSetup.PrintArea = Range(Cells(1, 1), Yazdir).Address
Next
Next
End With
End Sub
'Don't forget to remove old photos
Sub picxs()
Dim picx As Object
For Each picx In ActiveSheet.Pictures
If Not Application.Intersect(picx.TopLeftCell, Range("M6:M100")) Is Nothing Then
picx.Delete
End If
Next picx
End Sub