推荐订阅源

'Sub getpicture()
'Dim d, i&, sp As Shape, arr
'Set d = CreateObject("scripting.dictionary")
'For Each sp In Sheet1.Shapes
'   If sp.Type = msoPicture Then
'      Set d(sp.TopLeftCell.Offset(, -1).Value) = sp
'   End If
'Next
'arr = Sheets(2).Range([a2], [a65536].End(3))
'For i = 1 To UBound(arr)
'   If d.exists(arr(i, 1)) Then
'      d(arr(i, 1)).Copy
'      Cells(i + 1, 2).Select
'      ActiveSheet.Paste
'   End If
'Next
'ActiveWindow.ScrollRow = 1
'
'End Sub
' windows api
Private Declare Function timeGetTime Lib "winmm.dll" () As Long

' sleep(毫秒)
Sub sleep(T As Long)
    Dim time1 As Long
    time1 = timeGetTime
    Do
        DoEvents
    Loop While timeGetTime - time1 < T
End Sub


Sub getpicture()
Dim d, i&, sp As Shape, arr, xb As Workbook

'设置图片库数组
Set xb = GetObject(ActiveWorkbook.Path & "\图片库.xlsx")
'Set xb = GetObject("C:\图片库.xlsx")
Set d = CreateObject("scripting.dictionary")
For Each sp In xb.Sheets(1).Shapes
   If sp.Type = msoPicture Then
      Set d(sp.TopLeftCell.Offset(, -1).Value) = sp
   End If
Next

'读取首行
Dim y As Double
y = Selection.Column() '列数

arr = ActiveSheet.Range(Cells(1, y - 1), Cells(65536, y - 1).End(3))
For i = 1 To UBound(arr)
   If d.exists(arr(i, 1)) Then
      sleep 100
      d(arr(i, 1)).Copy
      Cells(i, y).Select
      On Error Resume Next
      ActiveSheet.Paste
   End If
Next
ActiveWindow.ScrollRow = 1

End Sub


Sub getpictureurl()



Dim ranTotal As Range, rng As Range, imageRng As Range, x As Double '设定三个Range变量

x = Selection.Column()
'MsgBox x, vbOKOnly, "鼠标选区的地址"


'Set rngTotal = Range(Columns(x), Columns(x)) '选中存放网址的o列
Set rngTotal = Selection
For Each rng In rngTotal     '遍历所有的o列单元格
    If Left(rng.Value, 7) = "http://" Then '如果单元格内容为网址
        Set imageRng = rng.Offset(, 1)  '存放图片的地址
        With ActiveSheet.Pictures.Insert(rng.Value)
            .Top = rng.Top
            .Left = rng.Left + (rng.Width - .Width * rng.Height / .Height) / 2
            .Width = .Width * rng.Height / .Height
            .Height = rng.Height
            rng.Value = ""
        End With
    End If
Next

End Sub


Sub deletepicture()
Dim Tupian As Shape
        For Each Tupian In ActiveSheet.Shapes
            If Tupian.Name Like "Picture *" Then Tupian.Delete
        Next

End Sub

Sub 工具栏()
With Application.CommandBars.Add(, , , True)
With .Controls.Add
     .Caption = "匹配本地图片"
     .TooltipText = "匹配本地图片"
     .OnAction = "getpicture"
     .Style = msoButtonIconAndCaption
    End With
    .Visible = True
    
    With .Controls.Add
     .Caption = "清除图片"
     .TooltipText = "清除图片"
     .OnAction = "deletepicture"
     .Style = msoButtonIconAndCaption
    End With
    .Visible = True
 
    
With .Controls.Add
     .Caption = "匹配网络图片"
     .TooltipText = "匹配网络图片"
     .OnAction = "getpictureurl"
     .Style = msoButtonIconAndCaption
    End With
    .Visible = True
      End With
End Sub


Function GetColumnStr(n&) As String

  Dim i&

  If n > 26 Then

    If n Mod 26 = 0 Then i = n \ 26 - 1 Else i = n \ 26

    GetColumnStr = GetColumnStr(i) & GetColumnStr(n - (i) * 26)

  Else

    GetColumnStr = Chr(n + 64)

  End If
End Function