vba加载图片

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 deletepicture()
Dim Tupian As Shape
        For Each Tupian In ActiveSheet.Shapes
            If Tupian.Name Like "Picture *" Then Tupian.Delete
        Next

End Sub


Sub getNetPic()

    Dim d, i&, sp As Shape, arr, xb As Workbook
    
    Dim rg As Range, shp As Shape, url

    '读取首行
    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)
       
        Cells(i, y).Select
        Set rg = Cells(i, y)
        
         url = arr(i, 1)
       If InStr(1, url, "http") = 0 Then
            url = "http:" & arr(i, 1)
        End If
        
       If InStr(url, "jpg") > 0 Then
           ActiveSheet.Shapes.AddShape(msoShapeRectangle, rg.Left, rg.Top, rg.Width, rg.Height).Select
        
          
        
           Selection.ShapeRange.Fill.UserPicture url
        End If
        
        

    
        On Error Resume Next
        
    Next
    
    ActiveWindow.ScrollRow = 1
    
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 = "getNetPic"
     .Style = msoButtonIconAndCaption
    End With
    .Visible = True
    End With
   
End Sub