用户使用宏在excel中插入图片

Posted 2023-04-19

【中文标题】用户使用宏在excel中插入图片

【英文标题】：User inserting pictures in excel with macro

【发布时间】：2017-06-08 15:29:57

【问题描述】：

我有点卡在这个上，因为我在网上找不到太多东西。基本上，我希望用户能够单击格式化某些单元格的按钮，然后打开一个框，让用户在 Windows 资源管理器中导航，以便在新格式化的单元格中插入一两张图片。

这是我目前所拥有的：

Private Sub AddPic_Click()
    Dim lastCell As Range
    Dim newCell1 As Range
    Dim newCell2 As Range
    Dim newCellMergePic1 As Range
    Dim newCellMergePic2 As Range
    Dim myRange As Range

    Set myRange = Worksheets("Product Packaging").Range("A1:A1000")

    For Each r In myRange
        If r.MergeCells Then
            Set lastCell = r
        End If
    Next r

    Set newCell1 = lastCell.Offset(1, 0)
    Set newCell2 = newCell1.Offset(0, 5)

    Set newCellMergePic1 = Range(newCell1, newCell1.Offset(9, 4))
    Set newCellMergePic2 = Range(newCell2, newCell2.Offset(9, 4))

    newCellMergePic1.Merge
    newCellMergePic2.Merge

    With newCellMergePic1
        .Font.Name = "Calibri"
        .Font.Color = vbBlack
        .VerticalAlignment = xlVAlignCenter
        .HorizontalAlignment = xlHAlignCenter
        .Font.Bold = True
        .Value = "Picture Here"
    End With

    With newCellMergePic2
        .Font.Name = "Calibri"
        .Font.Color = vbBlack
        .VerticalAlignment = xlVAlignCenter
        .HorizontalAlignment = xlHAlignCenter
        .Font.Bold = True
        .Value = "Picture Here"
    End With
End Sub

它有效，但我不知道如何集成允许用户浏览其文件夹以选择他们想要添加的图片的功能。感谢您花时间阅读我的帖子。

【问题讨论】：

我发现了一个类似的请求（资源管理器中的任何文件）：***.com/questions/10304989/…

:谢谢！我会调查的。

【参考方案1】：

您将需要使用一个对话框：

Option Explicit

Public Sub addImage1()
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .ButtonName = "Ok"
        .Title = "Select an image"
        .Filters.Clear
        .Filters.Add "JPG", "*.JPG"
        .Filters.Add "JPEG File Interchange Format", "*.JPEG"
        .Filters.Add "Graphics Interchange Format", "*.GIF"
        .Filters.Add "Portable Network Graphics", "*.PNG"
        .Filters.Add "All Pictures", "*.*"
        If .Show = -1 Then
            Dim img As Object
            Set img = ActiveSheet.Pictures.Insert(.SelectedItems(1))
        Else
            MsgBox ("Cancelled.")
        End If
    End With
End Sub

或

Public Sub addImage2()
    Dim result, imgTypes As String

    imgTypes = imgTypes & "JPG files (*.jp*),*.jp*"
    imgTypes = imgTypes & ", GIF files (*.gif),*.gif"
    imgTypes = imgTypes & ", PNG files (*.png),*.png"
    imgTypes = imgTypes & ", All files (*.*),*.*"

    result = Application.GetOpenFilename(imgTypes, 1, "Select Image", , False)

    If result <> False Then
        ActiveSheet.Pictures.Insert (result)
    End If
End Sub

【讨论】：

感谢您的帮助，保罗。我正在整合您建议的部分内容，但我有一个错误仍然阻止我继续前进：我希望用户选择一个或两个图像。目前，除非选择两张图片，否则代码会崩溃。我该如何解决这个问题并知道用户是否选择了一张或两张图片，然后将它们放在相应的单元格中？这是我现在无法 100% 运行的代码的一部分：

With fd .AllowMultiSelect = True .Title = "请选择图片" .Filters.Add "Images", "*.gif; *.jpg; *.jpeg", 1 If . Show = True Then newCellMergePic1 = .SelectedItems(1) If .SelectedItems(2) Then newCellMergePic2 = .SelectedItems(2) End If End If End With

【参考方案2】：

问题解决了，这是最终结果

Private Sub AddPic_Click()

Dim lastCell As Range

Dim newCell1 As Range
Dim newCell2 As Range

Dim newCellMergePic1 As Range
Dim newCellMergePic2 As Range

Dim myRange As Range

Dim fd As Office.FileDialog

Dim Pic1 As Picture
Dim Pic2 As Picture

Dim Pic1Path As String
Dim Pic2Path As String

Set fd = Application.FileDialog(msoFileDialogFilePicker)

Set myRange = Worksheets("Product Packaging").Range("A1:A1000")

For Each r In myRange
    If r.MergeCells Then
        Set lastCell = r
    End If
Next r

Set newCell1 = lastCell.Offset(1, 0)
Set newCell2 = newCell1.Offset(0, 5)

Set newCellMergePic1 = Range(newCell1, newCell1.Offset(9, 4))
Set newCellMergePic2 = Range(newCell2, newCell2.Offset(9, 4))

newCellMergePic1.Merge
newCellMergePic2.Merge

With newCellMergePic1
    .Font.Name = "Calibri"
    .Font.Color = vbBlack
    .VerticalAlignment = xlVAlignCenter
    .HorizontalAlignment = xlHAlignCenter
    .Font.Bold = True
    .Value = "Picture Here"
End With

With newCellMergePic2
    .Font.Name = "Calibri"
    .Font.Color = vbBlack
    .VerticalAlignment = xlVAlignCenter
    .HorizontalAlignment = xlHAlignCenter
    .Font.Bold = True
    .Value = "Picture Here"
End With

With fd

    .AllowMultiSelect = True
    .Title = "Please select picture(s). Maximum of two pictures per insert."
    .Filters.Add "Images", "*.gif; *.jpg; *.jpeg", 1

    If .Show = True Then

        If .SelectedItems.Count > 2 Then

            MsgBox "Please select no more than 2 pictures at once.", vbExclamation, Conflict

                        Dim delRange1 As Excel.Range
                        Dim delRange2 As Excel.Range

                        Set myRange = Worksheets("Product Packaging").Range("A1:A1000")

                        For Each r In myRange
                            If r.MergeCells Then
                                Set lastCell = r
                            End If
                        Next r

                        If lastCell.Address <> Range("A2").Address Then

                            Set lastCell2 = lastCell.Offset(0, 5)

                            Set delRange1 = lastCell.MergeArea
                            Set delRange2 = lastCell2.MergeArea

                            delRange1.ClearContents
                            delRange2.ClearContents

                            lastCell.UnMerge
                            lastCell2.UnMerge

                            Exit Sub

            End If

        End If


        Pic1Path = .SelectedItems(1)

        Set Pic1 = Pictures.Insert(Pic1Path)

        With Pic1.ShapeRange
            .LockAspectRatio = msoTrue
            .Height = newCellMergePic1.Height - 2
            .Top = newCellMergePic1.Top + 1
            .Left = newCellMergePic1.Left
        End With

        If .SelectedItems.Count = 2 Then
            Pic2Path = .SelectedItems(2)
            Set Pic2 = Pictures.Insert(Pic2Path)

            With Pic2.ShapeRange
                .LockAspectRatio = msoTrue
                .Height = newCellMergePic2.Height - 2
                .Top = newCellMergePic2.Top + 1
                .Left = newCellMergePic2.Left
            End With

        End If

    End If

End With

End Sub

【讨论】：

很高兴您找到了解决方案！