vba加载图片

+ View Code?

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123

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