Question

我有一个VBA代码，可以根据A列中的单元格值在Excel文件中提取图像和插入。但是在我的P驱动器中，从它拉出图像的位置，我的图像以＆＃39;结尾。 -TH＆＃39;我想排除他们。即我在P驱动器中有图像，命名为＆＃34; CITY-B＆＃34;另一个是＆＃34; CITY-B-TH＆＃34;。当我输入＆＃39; CITY＆＃39;（这就是我需要在excel中输入名称的方式）时，我希望它插入没有＆＃34; TH＆＃34;的那个。我怎么能这样做？

Private Sub Worksheet_Change(ByVal Target As Range)
     If (Split(Target.Address, "$")(1) <> "A") Then Exit Sub
    Call Inser_Image(Target)
End Sub

Private Sub Inser_Image(Ac_Cells As Range)
    Dim myRng As Range
    Dim Mycell As Range
    Dim St As String
    Dim myPath As String
    Dim My_Pic As Shape
    Dim My_File As String
    Dim Ac_cell As Range


    myPath = Sheet1.Cells(1, 5).Value

    If Len(myPath) > 3 Then
        If Right(myPath, 1) <> "\" Then
            myPath = myPath + "\"
        End If
    End If

    For Each Ac_cell In Ac_Cells

        For Each My_Pic In Sheet1.Shapes
            If My_Pic.Left = Ac_cell.Offset(0, 1).Left And My_Pic.Top = Ac_cell.Offset(0, 1).Top Then
                My_Pic.Delete
                Exit For
            End If
        Next


        St = Trim(Ac_cell.Value)

        If Len(St) > 4 Then
            If LCase(Left(St, 4)) = "http" Then
                Call Insert_Picture(St, Ac_cell.Offset(0, 1))
                GoTo Nextse1
            End If
        End If
            myPath = "P:\"
            If Right(myPath, 1) <> "\" Then myPath = myPath + "\"

                If Not (Dir(myPath + St)) = "" Then
                    My_File = St
                Else
                    My_File = Find_File(myPath, St)
                End If


                If My_File > " " Then
                    Call Insert_Picture(myPath + My_File, Ac_cell.Offset(0, 1))

                End If

    Application.ScreenUpdating = True
Nextse1:
    Next
End Sub



Sub Insert_Picture(thePath As String, theRange As Range)

    On Error GoTo Err3
    Dim myPict As Shape

     Sheet1.Shapes.AddPicture thePath, True, True, theRange.Left, theRange.Top, theRange.Width, theRange.Height

     Set myPict = Sheet1.Shapes(Sheet1.Shapes.Count)
    With myPict
            .LockAspectRatio = msoFalse
            .Placement = xlMoveAndSize
    End With

    Set myPict = Nothing
    Exit Sub
Err3:
    MsgBox Err.Description
End Sub



Function Find_File(thePath As String, F_N As String) As String

    file = Dir(thePath)
    Do Until file = ""
        If Len(file) < Len(F_N) Then GoTo EXT_N1
        If LCase(Left(file, Len(F_N))) = LCase(F_N) Then
            Find_File = file
            Exit Function
        End If
EXT_N1:
      file = Dir()
    Loop
    Find_File = ""
End Function

Answer 1

将EndsWith函数放入代码中。（如果它在路上有所帮助，我包括了一个开头），并像这样使用它：

            If My_File > " " Then
                If EndsWith(My_File,"-TH") Then
                else
                    Call Insert_Picture(myPath + My_File, Ac_cell.Offset(0, 1))
                End If
            End If

 Public Function EndsWith(str As String, ending As String) As Boolean
 Dim endingLen As Integer
 endingLen = Len(ending)
 EndsWith = (Right(Trim(UCase(str)), endingLen) = UCase(ending))
End Function

Public Function StartsWith(str As String, start As String) As Boolean
 Dim startLen As Integer
 startLen = Len(start)
 StartsWith = (Left(Trim(UCase(str)), startLen) = UCase(start))
End Function

Answer 2

使用InStr在文件名中搜索您的模式“-TH”

Dim pos As Integer

pos = InStr("find the comma, in the string", ",")

排除具有特定名称的图像

2 个答案: