Microsoft Office Forums

Go Back   Microsoft Office Forums > >

Reply
 
Thread Tools Display Modes
  #1  
Old 12-09-2021, 11:27 AM
trunchz trunchz is offline VBA photo positioning Windows 10 VBA photo positioning Office 2019
Novice
VBA photo positioning
 
Join Date: Dec 2021
Posts: 1
trunchz is on a distinguished road
Default 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
Attached Images
File Type: jpg wrong.jpg (46.9 KB, 14 views)
Reply With Quote
Reply

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 photo positioning VBA Picture Positioning cole10 PowerPoint 4 09-20-2012 06:55 AM

Other Forums: Access Forums

All times are GMT -7. The time now is 05:18 AM.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2024, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2024 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft