图片在Excel中插入问题 [英] Picture Insert Issue in Excel

问题描述

您好，

我正在寻求帮助。我有一个Maco，用于将图片插入选定的单元格。  我遇到的问题是图片并不总是把图片放在盒子里面，它是偏离中心的。例如，当我选择O9时，它不适合该单元格中的图片
。 

I'm looking for some help. I have a Maco that I use to insert a picture into a selected cell.  The issue I'm having is the picture doesn't always put the picture inside the box, it's off centered. For example when I select O9 it doesn't fit the picture within that cell. 

任何帮助将不胜感激

Sub Button5_Click()


    Dim myR As Range
    Dim shpPic As Shape
    Dim strName As String
    Dim strPicLoc As String
    Dim myScale As Double
    
    strPicLoc = Application.GetOpenFilename(FileFilter:="shpPic Files (*.jpg;*.bmp), *.jpg;*.bmp", Title:="Browse to select a picture")
    Set myR = Application.InputBox("Click in the cell to hold the picture", Type:=8)
    strName = "shpPic"
    myR.EntireRow.RowHeight = 225
    myR.EntireColumn.ColumnWidth = 60
    
    'Insert the picture
    On Error Resume Next
    ActiveSheet.Shapes(strName & myR.Address).Delete
    On Error GoTo 0
    Set shpPic = ActiveSheet.Shapes.AddPicture(Filename:=strPicLoc, _
    linktofile:=msoFalse, savewithdocument:=msoCTrue, Left:=myR.Left, Top:=myR.Top, Width:=-1, Height:=-1)
    shpPic.Name = strName & myR.Address
   
    'New line to fix rotation of the picture
    If shpPic.Rotation <> 0 Then shpPic.IncrementRotation -shpPic.Rotation
    
    'Optional code to scale the picture to the width/height of the cell and center
    myScale = Application.Min(myR.Width / shpPic.Width, _
                              myR.Height / shpPic.Height)
    If myR.Width / shpPic.Width > myR.Height / shpPic.Height Then
        shpPic.ScaleWidth myScale, msoFalse, msoScaleFromTopLeft
    Else
        shpPic.ScaleHeight myScale, msoFalse, msoScaleFromTopLeft
    End If
    'Optional code to center picture horizonatally and vertically
    If myR.Width > shpPic.Width Then shpPic.IncrementLeft (myR.Width - shpPic.Width) / 2
    If myR.Height > shpPic.Height Then shpPic.IncrementTop (myR.Height - shpPic.Height) / 2
End Sub

推荐答案

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
  '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)
    'Keep the proportions?
    s.LockAspectRatio = LockAspectRatio
    'Scale it to fit the cell
    s.Width = .Width
    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

这篇关于图片在Excel中插入问题的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！