社区首页 >专栏 >使用VBA复制、插入、移动、删除和控制图片3

使用VBA复制、插入、移动、删除和控制图片3

fanjy

发布于 2023-08-29 13:10:16

1.3K00

代码可运行

文章被收录于专栏：完美Excel完美Excel

运行总次数：0

代码可运行

标签：VBA

第一篇：使用VBA复制、插入、移动、删除和控制图片1

第二篇：使用VBA复制、插入、移动、删除和控制图片2

情形11：设置图片位置在单元格中间

图片是基于该图片的顶部和左侧进行定位的。下面的代码将使其显示在特定单元格的中间。

Sub CenterImage()
  Dim myImage As Shape
  Dim rngLocation As Range
  
  Set myImage = ActiveSheet.Shapes("Picture 6")
  Set rngLocation = ActiveSheet.Range("B2")
 
  myImage.Top = rngLocation.Top + (rngLocation.Height / 2) - (myImage.Height / 2)
  myImage.Left = rngLocation.Left + (rngLocation.Width / 2) - (myImage.Width / 2)
End Sub

情形12：水平或垂直翻转图片

水平翻转图片：

Sub FlipImageHorizontal()
  Dim myImage As Shape
  Set myImage = ActiveSheet.Shapes("Picture 6")
  myImage.Flip msoFlipHorizontal
End Sub

垂直翻转图片：

Sub FlipImageVertical()
  Dim myImage As Shape
  Set myImage = ActiveSheet.Shapes("Picture 6")
  myImage.Flip msoFlipVertical
End Sub

情形13：重新调整图片大小

下面的代码锁定纵横比；因此，调整宽度或高度的大小将保持图像的比例。

Sub ResizeImageLockAspectRatio()
  Dim myImage As Shape
  Dim imageWidth As Double
 
  Set myImage = ActiveSheet.Shapes("Picture 6")
  imageWidth = 100
 
  myImage.LockAspectRatio = msoTrue
  myImage.Width = imageWidth
End Sub

将纵横比设置为msoFalse时，高度和宽度将互不依赖。

Sub ResizeImageHeightOrWidth()
  Dim myImage As Shape
  Dim imageWidth As Double
  Dim imageHeight As Double
 
  Set myImage = ActiveSheet.Shapes("Picture 6")
  imageWidth = 100
  imageHeight = 50
 
  myImage.LockAspectRatio = msoFalse
  myImage.Width = imageWidth
  myImage.Height = imageHeight
End Sub

以下代码定位图像并将其拉伸到完全覆盖指定区域。

Sub StretchImageToCoverCells()
  Dim myImage As Shape
  Dim ws As Worksheet
  Dim rng As Range
 
  Set ws = ActiveSheet
  Set myImage = ws.Shapes("Picture 6")
  Set rng = ws.Range("C2:F9")
 
  myImage.LockAspectRatio = msoFalse
 
  myImage.Left = rng.Left
  myImage.Top = rng.Top
  myImage.Width = rng.Width
  myImage.Height = rng.Height
End Sub

情形14：裁剪图片

下面的代码根据与顶部、左侧、底部或右侧的距离裁剪图片。

Sub CropImage()
  Dim myImage As Shape
  Set myImage = ActiveSheet.Shapes("Picture 6")
 
  With myImage.PictureFormat
    .CropLeft = 50
    .CropTop = 50
    .CropRight = 50
    .CropBottom = 50
  End With
End Sub

情形15：改变顺序

图片可以在对象堆栈中向前或向后移动（称为Z-顺序）。

Sub ChangeZOrderRelative()
  Dim myImage As Shape
  Set myImage = ActiveSheet.Shapes("Picture 6")
  myImage.ZOrder msoBringForward
End Sub

Z-顺序位置不能直接设置。首先，将图片发送到后台，然后通过循环向前移动图片。继续循环，直到图片达到正确的Z顺序位置。

Sub ChangeZOrderAbsolute()
  Dim myImage As Shape
  Dim imageWidth As Double
  Dim imageZPosition As Integer
 
  Set myImage = ActiveSheet.Shapes("Picture 6")
  imageZPosition = 3
 
  myImage.ZOrder msoSendToBack
 
  Do While myImage.ZOrderPosition < imagezpositon
    myImage.ZOrder msoBringForward
  Loop
End Sub

情形16：设置背景图片

背景图是显示在工作表单元格后面的图片。

Sub SetImageBackground()
  Dim ws As Worksheet
  Dim strImagePath As String
 
  Set ws = ActiveSheet
  strImagePath = "C:\test\images\image01.jpg"
 
  ws.SetBackgroundPicture Filename:=strImagePath
 
  '删除背景图片
  'ws.SetBackgroundPicture
  Filename:=""
End Sub

情形17：从Excel中保存图片

如果在Excel工作簿中有一张图片，没有直接的方法将其作为图片保存到本地盘。一种常见的解决方法是将图片设置为图表区域的背景，然后将图表导出为图像。

Sub SavePictureFromExcel()
  Dim myPic As Shape
  Dim tempObj As ChartObject
  Dim strPath As String
 
  Set myPic = ActiveSheet.Shapes("Picture 2")
  Set tempObj = ActiveSheet.ChartObjects.Add(0, 0, myPic.Width, myPic.Height)
  strPath = "C:\test\images\myPic.jpg"
 
  myPic.Copy
 
  With tempObj.Chart
    .ChartArea.Select
    .Paste
    .Export strPath
  End With
 
  tempObj.Delete
End Sub