Question

我有以下工作代码。 B列具有图像名称，这将拉动所选文件夹中与B列中的名称匹配的图像，并将它们插入到A列中（请注意，前两行用于我的标题）。我注意到如果B2中的标题丢失，则代码错误，然后代码出错。我想解决这个问题，因此如果Range中有一个名字，它只会尝试查找图像（＆＃34; B3：B1002＆＃34;）。

Option Explicit
Private Sub Add_Images_Click()

    Const EXIT_TEXT         As String = ""
    Const NO_PICTURE_FOUND  As String = "No picture found"

    Dim picName             As String
    Dim picFullName         As String
    Dim rowIndex            As Long
    Dim lastRow             As Long
    Dim selectedFolder      As String
    Dim data()              As Variant
    Dim wks                 As Worksheet
    Dim Cell                As Range
    Dim pic                 As Picture

    On Error GoTo ErrorHandler

    selectedFolder = GetFolder
    If Len(selectedFolder) = 0 Then GoTo ExitRoutine

    Application.ScreenUpdating = False

    Set wks = ActiveSheet
    lastRow = wks.Cells(2, "B").End(xlDown).Row
    data = wks.Range(wks.Cells(1, "B"), wks.Cells(lastRow, "B")).Value2

    For rowIndex = 3 To UBound(data, 1)
        If StrComp(data(rowIndex, 1), EXIT_TEXT, vbTextCompare) = 0 Then GoTo ExitRoutine

        picName = data(rowIndex, 1)
        picFullName = selectedFolder & picName

        If Len(Dir(picFullName)) > 0 Then
            Set Cell = wks.Cells(rowIndex, "A")
            Set pic = wks.Pictures.Insert(picFullName)
            With pic
                .ShapeRange.LockAspectRatio = msoFalse
                .Height = Cell.Height
                .Width = Cell.Width
                .Top = Cell.Top
                .Left = Cell.Left
                .Placement = xlMoveAndSize
            End With
        Else
            wks.Cells(rowIndex, "A").Value = NO_PICTURE_FOUND
        End If
    Next rowIndex

ExitRoutine:
    Set wks = Nothing
    Set pic = Nothing
    Application.ScreenUpdating = True
    Exit Sub

ErrorHandler:
    MsgBox Prompt:="Unable to find photo", _
           Title:="An error occured", _
           Buttons:=vbExclamation
    Resume ExitRoutine
End Sub

这是使用户在运行上述子时选择包含图像的文件夹的函数。如果可能的话，我想修改它也可以使用像FTP站点这样的URL。因此，如果图像位于用户PC上的文件夹中，它将如下所示运行，但如果图像位于FTP位置，它仍然可以拉动图像。

Private Function GetFolder() As String
    Dim selectedFolder  As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = Application.DefaultFilePath & "\"
        .Title = "Select the folder containing the Image/PDF files."
        .Show

        If .SelectedItems.Count > 0 Then
            selectedFolder = .SelectedItems(1)
            If Right$(selectedFolder, 1) <> Application.PathSeparator Then _
                selectedFolder = selectedFolder & Application.PathSeparator
        End If
    End With
    GetFolder = selectedFolder
End Function

此Sub旨在删除A列中的所有图像。问题是这样做效果很好。与普通按钮一起使用时很好，但是当我尝试使用CommandButton将我的按钮放在用户表单上时，此Sub将删除CommandButton。它还会删除工作表中的所有注释。我想将此限制为仅删除图像，或者将代码隔离到仅查看范围（＆＃34; A3：A1002＆＃34;）。

Private Sub Remove_Images_Click()
'Remove Images

    Dim wks         As Worksheet
    Dim shp         As Shape
    Dim picArray()  As String
    Dim index       As Integer

    On Error GoTo ErrorHandler

    Columns(1).Replace What:="No Picture Found", Replacement:=vbNullString, LookAt:=xlPart
    Set wks = ActiveSheet
    index = 1
    For Each shp In wks.Shapes
        If shp.Type <> msoFormControl Then
            ReDim Preserve picArray(1 To index)
            picArray(index) = shp.Name
            index = index + 1
        End If
    Next shp

    wks.Shapes.Range(picArray).Delete

ExitRoutine:
    Set wks = Nothing
    Set shp = Nothing
    Erase picArray          
    Exit Sub

ErrorHandler:
    MsgBox Prompt:="Unable to find photo", _
           Title:="An error occured", _
           Buttons:=vbExclamation
    Resume ExitRoutine

End Sub

Answer 1

我看到三个主要问题，可能最好将这些问题分成不同的问题，但我会试一试。

忽略第一个代码块中的第2行。

在此行上将1更改为3：data = wks.Range(wks.Cells(3, "B"), wks.Cells(lastRow, "B")).Value2这会设置从第3行开始的数据范围，并忽略您的两个标题行。
FTP链接

这更适合单独的问题。首先创建一个处理FTP链接的新函数。然后确定单元格中的路径，即它是以http，c：//等开头的......然后调用适当的函数并将图像返回到主程序。

检查形状是否在A列中。

使用TopLeftCell属性查看它是否与A列相交

For Each shp In wks.Shapes
  If Not Intersect(shp.TopLeftCell, Columns(1)) Is Nothing Then  '<-- New Line checks if in col A
    If shp.Type <> msoFormControl Then
      ....

将图像从FTP站点拉到Excel

1 个答案: