Announcement

Collapse
No announcement yet.

Insert Image - Center & Zoom

Collapse
X
  • Filter
  • Time
  • Show
Clear All
new posts

  • Insert Image - Center & Zoom

    I have a worksheet (Covers) that is going to be the front and back covers for a binder.

    The title/text portion is automatically filled from cells elsewhere in the workbook.

    I have a button to bring up a userform that allows one to select the images (3 .jpg images) you wish to use on the cover pages.

    I have code that successfully brings up the userform, and allows image selection and preview within the userform.

    Now I want to insert these selected images into the worksheet, centered on specified cells and sized (zoom) to a maximum width/height (whichever is reached first).

    Can a blank Picture be inserted with its size specified/fixed, then use code (Image1 = LoadPicture?) to change what is displayed?
    Or do I have to calculate the size, center it on the page, and insert the image each time?

    The code (in part) for the UserForm looks like:
    Code:
    Private Sub SelFcvrImg_Click()
    
    Dim FCpicName As Variant
        ChDir ("S:\Dan\Builder Logos-Photos\")
        FCpicName = Application.GetOpenFilename(Title:="Select an Image!", _
        fileFilter:="Pictures (*.bmp;*.gif;*.tif;*.jpg),*bmp;*gif;*.tif;*.jpg")
        If FCpicName <> False Then InsertImgForm.FCoverImgPrvw.Picture = LoadPicture(FCpicName)
    
    End Sub
    The UserForm has an Image (preview) with PictureSizeMode set to zoom.
    I'm really after the same thing embedded in the sheet...
    Any tips on how to best approach this?
    Last edited by Bryan021; January 25th, 2007, 06:06.
    Bryan
    "Simplicity is the ultimate sophistication." Leonardo da Vinci (1452-1519)

  • #2
    Re: Insert Image - Center &amp; Zoom

    Something linke this maybe.
        With Range("C3:E10")
    ActiveSheet.Shapes.AddPicture "C:\temp\happy.bmp", True, True, .Left, .Top, .Width, .Height
    End With


    Change the filename and range of cells you want the image inserted over.

    Cheers
    Andy

    Comment


    • #3
      Re: Insert Image - Center &amp; Zoom

      Andy, I get an "File not found" error, yet the image shows in the preview nicely...
      Code:
      Private Sub SelFcvrImg_Click()
      'Select Image
      Dim FCpicName As Variant
          ChDir ("S:\Dan\Builder Logos-Photos\")
          FCpicName = Application.GetOpenFilename(Title:="Select an Image!", _
          fileFilter:="Pictures (*.bmp;*.gif;*.tif;*.jpg),*bmp;*gif;*.tif;*.jpg")
          If FCpicName <> False Then InsertImgForm.FCoverImgPrvw.Picture = _
          LoadPicture(FCpicName)
      
      End Sub
      
      Private Sub InsrtAllImgButton_Click()
          'Insert Image
          With Range("A13:I41")
          ActiveSheet.Shapes.AddPicture "FCpicName", _
          True, True, .Left, .Top, .Width, .Height
          End With
          
      InsertImgForm.Hide
      
      End Sub
      As a side, what are the two "True" values for?... visibility, ?
      Last edited by Bryan021; January 25th, 2007, 22:46.
      Bryan
      "Simplicity is the ultimate sophistication." Leonardo da Vinci (1452-1519)

      Comment


      • #4
        Re: Insert Image - Center &amp; Zoom

        The variable FCpicName is empty and does not contain a filename.

        Private Sub SelFcvrImg_Click() 
        Dim FCpicName As Variant
        'Select Image
        ChDir ("S:\Dan\Builder Logos-Photos\")
        FCpicName = Application.GetOpenFilename(Title:="Select an Image!", _
        fileFilter:="Pictures (*.bmp;*.gif;*.tif;*.jpg),*bmp;*gif;*.tif;*.jpg")
        If FCpicName <> False Then InsertImgForm.FCoverImgPrvw.Picture = _
        LoadPicture(FCpicName)

        End Sub

        Private Sub InsrtAllImgButton_Click()
        Dim FCpicName As Variant

        FCpicName = Application.GetOpenFilename(Title:="Select an Image!", _
        fileFilter:="Pictures (*.bmp;*.gif;*.tif;*.jpg),*bmp;*gif;*.tif;*.jpg")
        If FCpicName <> False Then
        'Insert Image
        With Range("A13:I41")
        ActiveSheet.Shapes.AddPicture FCpicName, _
        True, True, .Left, .Top, .Width, .Height
        End With
        end if
        InsertImgForm.Hide

        End Sub


        The 2 TRU arguments are;

        LinkToFile Required MsoTriState. The file to link to.
        SaveWithDocument Required MsoTriState. To save the picture with the document.

        Cheers
        Andy

        Comment


        • #5
          Re: Insert Image - Center &amp; Zoom

          Why would it be empty?
          It works with LoadPicture(FCpicName) in the preceding sub.
          Does LoadPicture empty it?
          Last edited by Bryan021; January 25th, 2007, 23:28.
          Bryan
          "Simplicity is the ultimate sophistication." Leonardo da Vinci (1452-1519)

          Comment


          • #6
            Re: Insert Image - Center &amp; Zoom

            The LoadPicture does not clear it.

            The variable is declared within that routine and therefore only exists in that routine when that routine is executed. Search forum for Scope and Lifetime of Variables.

            Cheers
            Andy

            Comment


            • #7
              Re: Insert Image - Center &amp; Zoom

              A curiosity;
              Whenever I type or paste the following,
              Code:
              True, True, .Left, .Top, .Width, .Height
              "Top" automatically changes to ".top", yet the others do not change capitalization???
              Bryan
              "Simplicity is the ultimate sophistication." Leonardo da Vinci (1452-1519)

              Comment


              • #8
                Re: Insert Image - Center &amp; Zoom

                Originally posted by Andy Pope
                The LoadPicture does not clear it.

                The variable is declared within that routine and therefore only exists in that routine when that routine is executed. Search forum for Scope and Lifetime of Variables.
                OK, I'm getting somewhere now...
                I declared them Public, and changed the routines from Private Sub to Sub...
                The selection and insertion now work, so I only have to get the sizing portion sorted...
                The way it is now, it stretches the image to fit the entire Range, whereas I want it to re-size (zoom) the image fit Range, without changing the aspect ratio.
                Code:
                Public FCpicName As Variant
                
                Sub SelFcvrImg_Click()
                
                'Select Front Cover Image
                
                    ChDir ("S:\Dan\Builder Logos-Photos\")
                    FCpicName = Application.GetOpenFilename(Title:="Select an Image!", _
                    fileFilter:="Pictures (*.bmp;*.gif;*.tif;*.jpg),*bmp;*gif;*.tif;*.jpg")
                    If FCpicName <> False Then InsertImgForm.FCoverImgPrvw.Picture = _
                    LoadPicture(FCpicName)
                
                End Sub
                
                Sub InsrtAllImgButton_Click()
                    
                    'Code to insert pictures in sheet
                    With Range("A13:I41")
                    ActiveSheet.Shapes.AddPicture _
                    (FCpicName, True, True, .Left, .top, .Width, .Height).Name = "FCpic"
                    End With
                    
                InsertImgForm.Hide
                
                End Sub
                Bryan
                "Simplicity is the ultimate sophistication." Leonardo da Vinci (1452-1519)

                Comment


                • #9
                  Re: Insert Image - Center &amp; Zoom

                  OK, I'm still working on the sizing portion of this.

                  Since AddPicture does not seem to allow me to maintain original size or aspect ratio, I figure I should be able to extract the width and height from the image after the GetOpenFilename, and then use those in AddPicture?

                  This code does not work, but will serve to give you the idea of what I'm trying to do.
                  Code:
                      Img1 = Application.GetOpenFilename(Title:="Select an Image!", _
                      fileFilter:="Pictures (*.bmp;*.gif;*.tif;*.jpg),*bmp;*gif;*.tif;*.jpg")
                      
                      ImgW = Img1.Width
                      ImgH = Img1.Height
                      
                      With Range("B2:G17")
                      ActiveSheet.Shapes.AddPicture _
                      (Img1, True, True, .Left, .Top, ImgW, ImgH).Name = "Img1"
                      End With
                  How should this be coded?
                  Bryan
                  "Simplicity is the ultimate sophistication." Leonardo da Vinci (1452-1519)

                  Comment


                  • #10
                    Re: Insert Image - Center &amp; Zoom

                    Sub x()

                    Dim vntImageFile As Variant
                    Dim shpImage As Shape
                    Dim rngOutput As Range

                    vntImageFile = Application.GetOpenFilename(Title:="Select an Image!", _
                    fileFilter:="Pictures (*.bmp;*.gif;*.tif;*.jpg),*bmp;*gif;*.tif;*.jpg")

                    If vntImageFile = False Then Exit Sub

                    Set rngOutput = Range("B2:G17")

                    ActiveSheet.Pictures.Insert vntImageFile
                    Set shpImage = ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
                    With shpImage
                    .Name = "Img1"
                    .LockAspectRatio = msoTrue
                    .Width = rngOutput.Width
                    If .Height > rngOutput.Height Then .Height = rngOutput.Height

                    .Left = rngOutput.Left + ((rngOutput.Width - .Width) / 2)
                    .Top = rngOutput.Top + ((rngOutput.Height - .Height) / 2)
                    End With

                    End Sub

                    Cheers
                    Andy

                    Comment


                    • #11
                      Re: Insert Image - Center &amp; Zoom

                      Thank you Andy.

                      I've adapted that code to suit, and have it working nicely.

                      I'm now onto "Insert & Crop" ;-)
                      Last edited by Bryan021; January 27th, 2007, 04:18.
                      Bryan
                      "Simplicity is the ultimate sophistication." Leonardo da Vinci (1452-1519)

                      Comment


                      • #12
                        Re: Insert Image - Center &amp; Zoom

                        For anyone interested;

                        This is how the code ended up for the user form to select up to three images for a front & back cover layout, and optionally resize the images to fill their given range, then apply a border if required.

                        Code:
                        Public FCpicName As Variant
                        Public BCpicName1 As Variant
                        Public BCpicName2 As Variant
                        
                        Sub ClearImg1_Click()
                        
                        'Clears Image#1 from Preview
                            On Error Resume Next
                            InsertImgForm.BCoverImg1Prvw.Picture = Nothing
                            BCpicName1 = ""
                            ActiveSheet.Shapes("BCpic1").Delete
                        End Sub
                        
                        Sub ClearImg2_Click()
                        
                        'Clears Image#2 from Preview
                            On Error Resume Next
                            InsertImgForm.BCoverImg2Prvw.Picture = Nothing
                            BCpicName2 = ""
                            ActiveSheet.Shapes("BCpic2").Delete
                        End Sub
                        
                        Sub ExitButton_Click()
                        
                        'Exit UserForm
                        InsertImgForm.Hide
                        
                        End Sub
                        
                        
                        Sub SelFcvrImg_Click()
                        
                        'Select Front Cover Image
                            ChDir ("S:\Dan\Builder Logos-Photos\")
                            FCpicName = Application.GetOpenFilename(Title:="Select an Image!", _
                            fileFilter:="Pictures (*.bmp;*.gif;*.tif;*.jpg),*bmp;*gif;*.tif;*.jpg")
                            If FCpicName <> False Then InsertImgForm.FCoverImgPrvw.Picture = _
                            LoadPicture(FCpicName)
                        
                        End Sub
                        
                        Sub SelBcvrImg1_Click()
                        
                        'Select Back Cover Image#1
                            ChDir ("S:\Dan\Builder Logos-Photos\")
                            BCpicName1 = Application.GetOpenFilename(Title:="Select an Image!", _
                            fileFilter:="Pictures (*.bmp;*.gif;*.tif;*.jpg),*bmp;*gif;*.tif;*.jpg")
                            If BCpicName1 <> False Then InsertImgForm.BCoverImg1Prvw.Picture = _
                            LoadPicture(BCpicName1)
                        
                        End Sub
                        
                        Sub SelBcvrImg2_Click()
                        
                        'Select Back Cover Image#2
                            ChDir ("S:\Dan\Builder Logos-Photos\")
                            BCpicName2 = Application.GetOpenFilename(Title:="Select an Image!", _
                            fileFilter:="Pictures (*.bmp;*.gif;*.tif;*.jpg),*bmp;*gif;*.tif;*.jpg")
                            If BCpicName2 <> False Then InsertImgForm.BCoverImg2Prvw.Picture = _
                            LoadPicture(BCpicName2)
                        
                        End Sub
                        
                        Sub InsrtAllImgButton_Click()
                            
                        ''''
                        'Code to insert pictures in sheet
                        ''''
                            On Error Resume Next
                            ActiveSheet.Shapes("FCpic").Delete
                            FCImage
                        
                            If OptionButton1 = True Then
                                ActiveSheet.Shapes("BCpic1").Delete
                                ActiveSheet.Shapes("BCpic2").Delete
                                BCImageC
                            Else
                                If BCpicName1 <> False Then
                                ActiveSheet.Shapes("BCpic1").Delete
                                BCImage1
                                End If
                                If BCpicName2 <> False Then
                                ActiveSheet.Shapes("BCpic2").Delete
                                BCImage2
                                End If
                            End If
                            
                            InsertImgForm.ExitButton = True
                        
                        End Sub
                        
                        Sub FCImage()
                        
                        'Front Cover Picture
                                If FCpicName = False Then Exit Sub
                        
                                    Dim FCImageFile As Variant
                                    Dim shpFCImage As Shape
                                    Dim rngOutputFC As Range
                             
                                FCImageFile = FCpicName
                                  
                                Set rngOutputFC = Range("A13:I41")
                             
                                ActiveSheet.Pictures.Insert FCImageFile
                                Set shpFCImage = ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
                                With shpFCImage
                                    .Name = "FCpic"
                                    .LockAspectRatio = msoTrue
                                    .Width = rngOutputFC.Width - 2
                                    If .Height > rngOutputFC.Height Then .Height = rngOutputFC.Height
                                    .Left = rngOutputFC.Left + ((rngOutputFC.Width - .Width) / 2)
                                    .top = rngOutputFC.top + ((rngOutputFC.Height - .Height) / 2)
                                       
                                    If CheckBoxFCrsz = False Then
                                    .ScaleHeight Factor:=0.98, _
                                    RelativeToOriginalSize:=msoTrue, Scale:=msoScaleFromMiddle
                                    .ScaleWidth Factor:=0.98, _
                                    RelativeToOriginalSize:=msoTrue, Scale:=msoScaleFromMiddle
                                    End If
                                    If CheckBoxFCbdr = True Then
                                    .Line.Weight = 4.5
                                    .Line.DashStyle = msoLineSolid
                                    .Line.Style = msoLineThinThick
                                    .Line.Transparency = 0#
                                    .Line.Visible = msoTrue
                                    .Line.ForeColor.SchemeColor = 19
                                    .Line.BackColor.RGB = RGB(255, 255, 255)
                                    End If
                                End With
                        End Sub
                        
                        Sub BCImageC()
                        
                        'Single Back Cover Picture
                                If BCpicName1 = False Then Exit Sub
                        
                                    Dim BCImageFileC As Variant
                                    Dim shpBCImageC As Shape
                                    Dim rngOutputBCC As Range
                             
                                BCImageFileC = BCpicName1
                                  
                                Set rngOutputBCC = Range("A66:I94")
                             
                                ActiveSheet.Pictures.Insert BCImageFileC
                                Set shpBCImageC = ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
                                With shpBCImageC
                                    .Name = "BCpic1"
                                    .LockAspectRatio = msoTrue
                                    .Width = rngOutputBCC.Width - 2
                                    If .Height > rngOutputBCC.Height Then .Height = rngOutputBCC.Height
                                    .Left = rngOutputBCC.Left + ((rngOutputBCC.Width - .Width) / 2)
                                    .top = rngOutputBCC.top + ((rngOutputBCC.Height - .Height) / 2)
                                                   
                                    If CheckBoxBCrcz1 = False Then
                                    .ScaleHeight Factor:=0.98, _
                                    RelativeToOriginalSize:=msoTrue, Scale:=msoScaleFromMiddle
                                    .ScaleWidth Factor:=0.98, _
                                    RelativeToOriginalSize:=msoTrue, Scale:=msoScaleFromMiddle
                                    End If
                                    If CheckBoxBCbdr1 = True Then
                                    .Line.Weight = 4.5
                                    .Line.DashStyle = msoLineSolid
                                    .Line.Style = msoLineThinThick
                                    .Line.Transparency = 0#
                                    .Line.Visible = msoTrue
                                    .Line.ForeColor.SchemeColor = 19
                                    .Line.BackColor.RGB = RGB(255, 255, 255)
                                    End If
                                End With
                        End Sub
                        
                        Sub BCImage1()
                                
                        'Dual Back Cover Picture#1
                                If BCpicName1 = False Then Exit Sub
                        
                                    Dim BCImageFile1 As Variant
                                    Dim shpBCImage1 As Shape
                                    Dim rngOutputBC1 As Range
                             
                                BCImageFile1 = BCpicName1
                                  
                                Set rngOutputBC1 = Range("A53:I79")
                             
                                ActiveSheet.Pictures.Insert BCImageFile1
                                Set shpBCImage1 = ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
                                With shpBCImage1
                                    .Name = "BCpic1"
                                    .LockAspectRatio = msoTrue
                                    .Width = rngOutputBC1.Width - 2
                                    If .Height > rngOutputBC1.Height Then .Height = rngOutputBC1.Height
                                    .Left = rngOutputBC1.Left + ((rngOutputBC1.Width - .Width) / 2)
                                    .top = rngOutputBC1.top + ((rngOutputBC1.Height - .Height) / 2)
                                                   
                                    If CheckBoxBCrcz1 = False Then
                                    .ScaleHeight Factor:=0.98, _
                                    RelativeToOriginalSize:=msoTrue, Scale:=msoScaleFromMiddle
                                    .ScaleWidth Factor:=0.98, _
                                    RelativeToOriginalSize:=msoTrue, Scale:=msoScaleFromMiddle
                                    End If
                                    If CheckBoxBCbdr1 = True Then
                                    .Line.Weight = 4.5
                                    .Line.DashStyle = msoLineSolid
                                    .Line.Style = msoLineThinThick
                                    .Line.Transparency = 0#
                                    .Line.Visible = msoTrue
                                    .Line.ForeColor.SchemeColor = 19
                                    .Line.BackColor.RGB = RGB(255, 255, 255)
                                    End If
                                End With
                        End Sub
                        
                        Sub BCImage2()
                        
                        'Dual Back Cover Picture#2
                                If BCpicName2 = False Then Exit Sub
                                
                                    Dim BCImageFile2 As Variant
                                    Dim shpBCImage2 As Shape
                                    Dim rngOutputBC2 As Range
                             
                                BCImageFile2 = BCpicName2
                                  
                                Set rngOutputBC2 = Range("A81:I107")
                             
                                ActiveSheet.Pictures.Insert BCImageFile2
                                Set shpBCImage2 = ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
                                With shpBCImage2
                                    .Name = "BCpic2"
                                    .LockAspectRatio = msoTrue
                                    .Width = rngOutputBC2.Width - 2
                                    If .Height > rngOutputBC2.Height Then .Height = rngOutputBC2.Height
                                    .Left = rngOutputBC2.Left + ((rngOutputBC2.Width - .Width) / 2)
                                    .top = rngOutputBC2.top + ((rngOutputBC2.Height - .Height) / 2)
                        
                                    If CheckBoxBCrsz2 = False Then
                                    .ScaleHeight Factor:=0.98, _
                                    RelativeToOriginalSize:=msoTrue, Scale:=msoScaleFromMiddle
                                    .ScaleWidth Factor:=0.98, _
                                    RelativeToOriginalSize:=msoTrue, Scale:=msoScaleFromMiddle
                                    End If
                                    If CheckBoxBCbdr2 = True Then
                                    .Line.Weight = 4.5
                                    .Line.DashStyle = msoLineSolid
                                    .Line.Style = msoLineThinThick
                                    .Line.Transparency = 0#
                                    .Line.Visible = msoTrue
                                    .Line.ForeColor.SchemeColor = 19
                                    .Line.BackColor.RGB = RGB(255, 255, 255)
                                    End If
                                End With
                        End Sub
                        Bryan
                        "Simplicity is the ultimate sophistication." Leonardo da Vinci (1452-1519)

                        Comment

                        Working...
                        X