☰

如何从我的计算机将照片添加到 Excel 工作表中的特定单元格？

tag-icon • tag-icon microsoft-excel microsoft-excel-2010 vba visual-studio visual-studio-2012
如何从我的计算机将照片添加到 Excel 工作表中的特定单元格？

这是我使用的代码：

Private Sub Image1_Click()
  Range("C1").Select
  Application.Dialogs(xlDialogInsertPicture).Show
End Sub


Private Sub Image2_Click()
  Range("D1").Select
  Application.Dialogs(xlDialogInsertPicture).Show
End Sub

Private Sub Image3_Click()
  Range("E1").Select
  Application.Dialogs(xlDialogInsertPicture).Show
End Sub

Private Sub Image4_Click()
  Range("F1").Select
 Application.Dialogs(xlDialogInsertPicture).Show
End Sub

Private Sub Image5_Click()
  Range("G1").Select
  Application.Dialogs(xlDialogInsertPicture).Show
End Sub

Private Sub Image6_Click()
  Range("K1").Select
  Application.Dialogs(xlDialogInsertPicture).Show
End Sub

我想要做的正是这样的：

  • 当我单击用户窗体中的图像工具时，如果添加照片，它将如下所示：（1）
  • 当我添加两张照片时，它将自动分为两部分，并且大小将相等，如下所示：（2）
  • 如果我添加三张照片，它将自动分为三部分，并且大小将相等，如下所示：（3）

我想添加照片，当我单击用户窗体中的图像工具时，它们将出现在我想要的 Excel 工作表单元格中（我想要的特定单元格）。我特别想在 1-5 行和 C - L 列之间添加照片，并且它们的大小将自动相等。

我使用这个代码只是为了补充一下，我无法用这个代码实现我所说的功能：

我想做的事 当我使用此代码时，照片在我想要的特定单元格中并不相等，并且不是我想要的特定大小（左边是我单击的用户窗体和图像工具，右边是脚本如何将照片添加到工作表）

我做了什么

我需要自动修复它们的大小。在 Katz 的脚本中，我可以将它们添加到特定单元格，但如果我添加一张照片，它的大小不会填充我想要的单元格，或者如果我添加两张照片，它不会自动填充我想要的单元格。因此，此脚本将照片添加到单元格中，并按我写入脚本的大小进行调整。不会自动将它们修复为相等。（我想像第一张照片那样做，但我可以在这个脚本中处理第二张照片）

Private Sub Image1_Click()
Dim fileName1 As Variant
fileName1 = Application.GetOpenFilename(filefilter:="Tiff Files(*.tif;*.tiff),*.tif;*.tiff,JPEG Files (*.jpg;*.jpeg;*.jfif;*.jpe),*.jpg;*.jpeg;*.jfif;*.jpe,Bitmap Files(*.bmp),*.bmp", FilterIndex:=2, Title:="Choose picture", MultiSelect:=False)
    If fileName1 = False Then
    'if cancel pressed
    Exit Sub
Else
ActiveWorkbook.Sheets("Coursebooking").Select
Range("A4").Select 'choose your start range
Dim picture1 As Object
Set picture1 = ActiveWorkbook.Sheets("Coursebooking").Pictures.Insert(fileName1)
With picture1
    .Top = Range("A4").Top 'set as needed
    .Left = Range("A4").Left 'set as needed
    .Width = 600 'set as needed
    .Height = .Width * 3 / 4 'set as needed
End With
End If
End Sub

答案1

据我对您问题的理解，您遗漏了一个关键部分：范围具有像左、上、右和宽度这样的属性，就像图像一样。这是一个函数，它接受一个Range对象作为参数，提示用户选择图像，然后将图像放入该范围内。关键点：根据您的要求，它被编写为不保持纵横比，因此图片可能会显得被挤压或拉伸。

Option Explicit
Sub testImportPicturesToRange()
    ImportPicturesToRange Range("B3:H10")
End Sub
Function ImportPicturesToRange(rngTarget As Range)

    'Declaration
    Dim picFormats As String, picPaths, picPath, pic
    Dim i As Long, numPics As Long, picWidth As Long

    'Select the pictures to import
    picFormats = "*.gif; *.jpg; *.bmp; *.png; *.tif"
    picPaths = Application.GetOpenFilename("Pictures (" & picFormats & ")," & picFormats, , "Select Picture to Import", , True)

    'Exit if user clicked Cancel
    If TypeName(picPaths) = "Boolean" Then Exit Function

    'Initialize
    i = 0
    numPics = 0
    For Each picPath In picPaths
        If picPath <> False Then numPics = numPics + 1
    Next
    picWidth = rngTarget.Width / numPics

    'Import the pictures
    On Error Resume Next
    For Each picPath In picPaths
        If picPath <> False Then
            Set pic = ActiveSheet.Pictures.Insert(picPath)
            pic.ShapeRange.LockAspectRatio = msoFalse
            pic.Top = rngTarget.Top
            pic.Left = rngTarget.Left + (i * picWidth)
            pic.Height = rngTarget.Height
            pic.Width = picWidth
            i = i + 1
        End If
    Next

    'Cleanup
    Set pic = Nothing
    Set picPath = Nothing
    Set picPaths = Nothing

End Function


更新：从你的问题中我可以看出，思考这就是您想要实现它的方式。

Private Sub Image1_Click()
    ImportPicturesToRange Range("C1")
End Sub

相关内容