#1
|
|||
|
|||
VBA photo positioning
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 |
Thread Tools | |
Display Modes | |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Positioning shapes in Containers | Noxius91 | Visio | 1 | 08-16-2019 07:43 PM |
Document Positioning Default | indago | Word | 11 | 07-25-2018 05:10 PM |
Right positioning, left alignment. Is it possible? | Mutak94 | Word | 3 | 09-12-2014 09:33 AM |
VBA for pictures positioning in powerpoint | iebogu | PowerPoint | 1 | 01-17-2014 05:47 AM |
VBA Picture Positioning | cole10 | PowerPoint | 4 | 09-20-2012 06:55 AM |