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

时间:2017-06-08 15:29:57

标签: image excel-vba picturebox vba excel

我有点卡在这个上,因为我在网上找不到多少东西。基本上,我希望用户能够单击格式化某些单元格的按钮,然后打开一个框,使用户可以浏览Windows资源管理器,以便在新格式化的单元格中插入一张或两张图片。 / p>

这是我到目前为止所做的:

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

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

2 个答案:

答案 0 :(得分:1)

您需要使用一个对话框:

override func tableView(_ tableView: UITableView, cellForRowAt indexPath: IndexPath, object: PFObject?) -> PFTableViewCell? {
let cell = tableView.dequeueReusableCell(withIdentifier: "Cells", for: indexPath as IndexPath) as! MyCell
cell.object = object
let currentLocation = CLLocation()
locManager.distanceFilter = 50
if( CLLocationManager.authorizationStatus() == CLAuthorizationStatus.authorizedWhenInUse ||
    CLLocationManager.authorizationStatus() == CLAuthorizationStatus.authorizedAlways){
    let coordinate₀ = CLLocation(latitude: CLLocationDegrees(-41)!, longitude: CLLocationDegrees(52.3)!)
    let coordinate₁ = CLLocation(latitude: currentLocation.coordinate.longitude, longitude: currentLocation.coordinate.latitude)
    let distanceInMeters = coordinate₀.distance(from: coordinate₁)
    if(distanceInMeters <= 1609)
    {
        cell.Distance.text = "\(Float(round(distanceInMeters * 3.28084)).cleanValue) ft"
    }
    else
    {
        cell.Distance.text = "\(Float(round(distanceInMeters / 1609)).cleanValue) mi"
      }
   }
}

public searchEntities(string query, list<string> columnNames)
{
   await db.entities.SelectDynamic(x => "{" + string.Join(",", columnNames) + "}")
           .where(...)..ToListAsync();
}

答案 1 :(得分:1)

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

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
相关问题