[Okta Webinar] Learn how to a build a cloud-first strategyRegister Now

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 340
  • Last Modified:

Resizing two pictures to different sizes

Hello Experts,
I am copying pictures from access to excel via VBA and during the process i am resizing the pictures.  I have a code extract below which resizes all pictures to one common size but i want to size each one individually.  Could someone please recommend what to change in the code.
Thanks.

Dim appExcel As Excel.Application
    Dim wbook As Excel.Workbook
    Dim wsheet As Excel.Worksheet
    Dim myPict As Excel.Picture
    Dim myLogo As Excel.Picture
    Dim pSize As Shape
    Dim ProcessCloseDate As Date
    Dim ReportDate As Date
   
    ProcessCloseDate = Me.SCRDate + 14
    ReportDate = Me.SCRDate + 7
   
    Set appExcel = New Excel.Application
    appExcel.Visible = False
    appExcel.DisplayAlerts = False
    Set wbook = appExcel.Workbooks.Open("f:\Quality Systems\Supplier Concerns\Associated Documents\" & StrFileName2)
    Set wsheet = wbook.Worksheets("SCR Report")
       
    If ("f:\Quality Systems\Supplier Concerns\Photos\") & Dir("f:\Quality Systems\Supplier Concerns\Photos\" & strPhotoname) <> "" Then
     
    With wsheet.Range("e59")
            Set myPict = .Parent.Pictures.Insert("f:\Quality Systems\Supplier Concerns\Photos\" & strPhotoname)
            myPict.Top = .Top
            myPict.Left = .Left
            myPict.Placement = xlMoveAndSize
    End With
   
    End If
   
    If ("f:\Quality Systems\Supplier Concerns\Photos\") & Dir("f:\Quality Systems\Supplier Concerns\Photos\" & strLogo) <> "" Then
     
    With wsheet.Range("aj7")
            Set myLogo = .Parent.Pictures.Insert("f:\Quality Systems\Supplier Concerns\Photos\" & strLogo)
            myLogo.Top = .Top
            myLogo.Left = .Left
            myLogo.Placement = xlMoveAndSize
           
    End With
   
    End If
   
    For Each psize In wsheet.Shapes
            pSize.LockAspectRatio = msoTrue
            pSize.Height = 280
            pSize.Width = 288
    Next pSize
0
SweetingA
Asked:
SweetingA
  • 4
  • 3
1 Solution
 
Saqib Husain, SyedEngineerCommented:
It is the last 5 lines of code which are controlling the size of the picture. How do you want to change the sizes?
0
 
SweetingAAuthor Commented:
I want to change them the same way but i want each of the two piictures a diffrent size not the samesize
0
 
Saqib Husain, SyedEngineerCommented:
Try this macro. You would have to change the numbers where I have inserted the comment

<---Change
<---these numbers

Saqib
Dim appExcel As Excel.Application
    Dim wbook As Excel.Workbook
    Dim wsheet As Excel.Worksheet
    Dim myPict As Excel.Picture
    Dim myLogo As Excel.Picture
    Dim pSize As Shape
    Dim ProcessCloseDate As Date
    Dim ReportDate As Date
   
    ProcessCloseDate = Me.SCRDate + 14
    ReportDate = Me.SCRDate + 7
   
    Set appExcel = New Excel.Application
    appExcel.Visible = False
    appExcel.DisplayAlerts = False
    Set wbook = appExcel.Workbooks.Open("f:\Quality Systems\Supplier Concerns\Associated Documents\" & StrFileName2)
    Set wsheet = wbook.Worksheets("SCR Report")
       
    If ("f:\Quality Systems\Supplier Concerns\Photos\") & Dir("f:\Quality Systems\Supplier Concerns\Photos\" & strPhotoname) <> "" Then
     
    With wsheet.Range("e59")
            Set myPict = .Parent.Pictures.Insert("f:\Quality Systems\Supplier Concerns\Photos\" & strPhotoname)
            myPict.Top = .Top
            myPict.Left = .Left
            myPict.Placement = xlMoveAndSize
            myPict.LockAspectRatio = msoTrue
            myPict.Height = 280 '< ------------Change
            myPict.Width = 288 ' < ------------these numbers
    End With
   
    End If
   
    If ("f:\Quality Systems\Supplier Concerns\Photos\") & Dir("f:\Quality Systems\Supplier Concerns\Photos\" & strLogo) <> "" Then
     
    With wsheet.Range("aj7")
            Set myLogo = .Parent.Pictures.Insert("f:\Quality Systems\Supplier Concerns\Photos\" & strLogo)
            myLogo.Top = .Top
            myLogo.Left = .Left
            myLogo.Placement = xlMoveAndSize
            myLogo.LockAspectRatio = msoTrue
            myLogo.Height = 280 '< ------------Change
            myLogo.Width = 288 ' < ------------these numbers
    End With
   
    End If

Open in new window

0
Restore individual SQL databases with ease

Veeam Explorer for Microsoft SQL Server delivers an easy-to-use, wizard-driven interface for restoring your databases from a backup. No expert SQL background required. Web interface provides a complete view of all available SQL databases to simplify the recovery of lost database

 
SweetingAAuthor Commented:
Very close (needed to add shape range in aspect ratio line) but nevertheless your suggestion lead me to the solution nicely, see below.
Thanks

If ("f:\Quality Systems\Supplier Concerns\Photos\") & Dir("f:\Quality Systems\Supplier Concerns\Photos\" & strPhotoname) <> "" Then
     
    With wsheet.Range("E59")
            Set myPict = .Parent.Pictures.Insert("f:\Quality Systems\Supplier Concerns\Photos\" & strPhotoname)
            myPict.Top = .Top
            myPict.Left = .Left
            myPict.Placement = xlMoveAndSize
            myPict.ShapeRange.LockAspectRatio = msoFalse
            myPict.Height = 280
            myPict.Width = 288
    End With
   
    End If
     
    If ("f:\Quality Systems\Supplier Concerns\Photos\") & Dir("f:\Quality Systems\Supplier Concerns\Photos\" & strLogo) <> "" Then

    With wsheet.Range("aj7")
            Set myLogo = .Parent.Pictures.Insert("f:\Quality Systems\Supplier Concerns\Photos\" & strLogo)
            myLogo.Top = .Top
            myLogo.Left = .Left
            myLogo.Placement = xlMoveAndSize
            myLogo.ShapeRange.LockAspectRatio = msoFalse
            myLogo.Height = 70
            myLogo.Width = 170
    End With

    End If
0
 
SweetingAAuthor Commented:
To get the solution to work i needed to change the lockaspectratio line slightly, see my posting.
0
 
Saqib Husain, SyedEngineerCommented:
The solution I provided was in complete as far as the question and the follow up is concerned.

Your follow up comment says "...change them the same way..." which means that only the size needs to be changed.

You did not, at any stage, ask for a change in the aspect ratio (which would distort the picture) from the original. Had you asked for that I would have given it to you.

So in all fairness this should have been an A grade. Please reopen this question and reassign an A grade.

0
 
Saqib Husain, SyedEngineerCommented:
Modalot,

Points apart, I am glad you said that.

Thanks for the consideration.

Saqib
0

Featured Post

Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

  • 4
  • 3
Tackle projects and never again get stuck behind a technical roadblock.
Join Now