Выберите изображение из файла с помощью кнопки и вставьте его в текущую ячейку Excel и измените размер ячейки, чтобы соответствовать изображению с помощью vba - PullRequest
Новая
       11

Выберите изображение из файла с помощью кнопки и вставьте его в текущую ячейку Excel и измените размер ячейки, чтобы соответствовать изображению с помощью vba

0 голосов
/ 10 апреля 2020

Привет. Я хочу выбрать изображение из файла с помощью кнопки команды, затем изображение будет вставлено в активную ячейку, а размер ячейки изменится в соответствии с размером изображения.

Любая помощь, пожалуйста Используя Excel VBA в этом коде, я хочу защитить ячейку в коде, вместо этого я хочу вставить в текущую активную ячейку, также, когда я вставляю новое изображение в другую ячейку, предыдущее изображение удаляется, что я не хочу бывает. 

Sub Resize_Cell_from_Picture_Size()
Const maxH = 409.5 ' << max row height = 409.5/by default
Const picName As String = "pic-01" '<< picture name
Dim cel As Range
Set cel = [B2] ' << target cell in active sheet
Dim nH
Dim nW
Dim nPix
Dim x
On Error Resume Next
Dim fPath As String
With Application.FileDialog(msoFileDialogFilePicker)
  If .Show = True Then
      ActiveSheet.Pictures(picName).Delete
  fPath = .SelectedItems(1)
  Set p = ActiveSheet.Shapes.AddPicture(fPath, False, True, cel.Left,  cel.Top, -1, -1)
  With p
  .Name = picName
   nH = .Height
   nW = .Width
 End With
If nH > maxH Then
 MsgBox "wrong, picture's height is > " & maxH
 p.Delete
Exit Sub
Else
cel.RowHeight = nH
nPix = nW / 0.75
x = (nPix - 12) / 7
nW = Round(x + 1, 2)
cel.ColumnWidth = nW
p.Placement = xlMoveAndSize
cel.Select
End If
Else
MsgBox "cancel"
End If
End With
On Error GoTo 0
End Sub

1 Ответ

0 голосов
/ 10 апреля 2020 
 Sub Resize_Cell_from_Picture_Size()
 Const maxH = 409.5 ' << max row height = 409.5/by default
 With Application.FileDialog(msoFileDialogFilePicker)
    .AllowMultiSelect = False
    .ButtonName = "Submit"
    .Title = "Select an image file"
    .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 "Tag Image File Format", "*.TIFF"
    .Filters.Add "All Pictures", "*.*"

    If .Show = -1 Then
        Dim img As Object
        Set img = ActiveSheet.Pictures.Insert(.SelectedItems(1))
        Dim nH
        Dim nW
        Dim nPix
        Dim x

        With Selection
                If img.Height >= maxH Then
                    MsgBox "wrong, picture's height is > " & maxH
                    img.Delete
                    Exit Sub
                Else
                    nH = img.Height
                    nW = img.Width
                    ActiveCell.RowHeight = nH
                    nPix = nW / 0.75
                    x = (nPix - 12) / 7
                    nW = Round(x + 1, 2)
                    ActiveCell.ColumnWidth = nW
                End If
        End With

        Else
        MsgBox ("Cancelled.")
    End If
End With
End Sub
...