excel 鏈接變圖片

'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