vba圖片庫

Sub addbtn()
    Set myMenu = Application.CommandBars("worksheet menu bar")
    Set Button = myMenu.Controls.Add(Type:=msoControlButton)
    Button.Caption = "匹配圖片"            '按鈕上的文字，填寫你需要的
    Button.Style = msoButtonIconAndCaption
    Button.FaceId = FaceId                  '按鈕圖標,數字比如8，系統存在的
    Button.OnAction = "InsertPic"       '按鈕執行的宏名，填寫你自己的宏名
End Sub
Sub InsertPic()
    Dim arr, i&, k&, n&, b As Boolean
    Dim strPicName$, strPicPath$, strFdPath$, shp As Shape
    Dim rngData As Range, rngEach As Range, rngWhere As Range, strWhere As String
    'On Error Resume Next
    '用戶選擇圖片所在的文件夾
    With Application.FileDialog(msoFileDialogFolderPicker)
       If .Show Then strFdPath = .SelectedItems(1) Else: Exit Sub
    End With
    If Right(strFdPath, 1) <> "\" Then strFdPath = strFdPath & "\"
    Set rngData = Application.InputBox("請選擇圖片名稱所在的單元格區域", Type:=8)
    '用戶選擇需要插入圖片的名稱所在單元格範圍
    Set rngData = Intersect(rngData.Parent.UsedRange, rngData)
    'intersect語句避免用戶選擇整列單元格，造成無謂運算的情況
    If rngData Is Nothing Then MsgBox "選擇的單元格範圍不存在數據！": Exit Sub
    strWhere = InputBox("請輸入圖片偏移的位置，例如上1、下1、左1、右1", , "右1")
    '用戶輸入圖片相對單元格的偏移位置。
    If Len(strWhere) = 0 Then Exit Sub
    x = Left(strWhere, 1)
    '偏移的方向
    If InStr("上下左右", x) = 0 Then MsgBox "你未輸入偏移方位。": Exit Sub
    y = Val(Mid(strWhere, 2))
    '偏移的值
    Select Case x
        Case "上"
        Set rngWhere = rngData.Offset(-y, 0)
        Case "下"
        Set rngWhere = rngData.Offset(y, 0)
        Case "左"
        Set rngWhere = rngData.Offset(0, -y)
        Case "右"
        Set rngWhere = rngData.Offset(0, y)
    End Select
    Application.ScreenUpdating = False
    rngData.Parent.Parent.Activate '用戶選定的激活工作簿
    rngData.Parent.Select
    For Each shp In ActiveSheet.Shapes
    '如果舊圖片存放在目標圖片存放範圍則刪除
        If Not Intersect(rngWhere, shp.TopLeftCell) Is Nothing Then shp.Delete
    Next
    x = rngWhere.Row - rngData.Row
    y = rngWhere.Column - rngData.Column
    '偏移的座標
    arr = Array(".jpg", ".jpeg", ".bmp", ".png", ".gif")
    '用數組變量記錄五種文件格式
    For Each rngEach In rngData
    '遍歷選擇區域的每一個單元格
        strPicName = rngEach.Text
        '圖片名稱
        If Len(strPicName) Then
        '如果單元格存在值
            strPicPath = strFdPath & strPicName
            '圖片路徑
            b = False
            '變量標記是否找到相關圖片
            For i = 0 To UBound(arr)
            '由於不確定用戶的圖片格式，因此遍歷圖片格式
                If Len(Dir(strPicPath & arr(i))) Then
                '如果存在相關文件
                    Set shp = ActiveSheet.Shapes.AddPicture( _
                        strPicPath & arr(i), False, True, _
                        rngEach.Offset(x, y).Left + 5, _
                        rngEach.Offset(x, y).Top + 5, _
                        20, 20)
                    shp.Select
                    With Selection
                        .ShapeRange.LockAspectRatio = msoFalse
                        '撤銷鎖定圖片縱橫比
                        .Height = rngEach.Offset(x, y).Height - 10 '圖片高度
                        .Width = rngEach.Offset(x, y).Width - 10 '圖片寬度
                    End With
                    b = True '標記找到結果
                    n = n + 1 '累加找到結果的個數
                    Range("a1").Select: Exit For '找到結果後就可以退出文件格式循環
                End If
            Next
            If b = False Then k = k + 1 '如果沒找到圖片累加個數
        End If
    Next
    Application.ScreenUpdating = True
    Call adiustpic
    MsgBox "共處理成功" & n & "個圖片，另有" & k & "個非空單元格未找到對應的圖片。"
End Sub

Sub adiustpic() '根據並單元格大小調整圖片大小
Dim Pic As Shape
For Each Pic In ActiveSheet.Shapes
    If Pic.TopLeftCell.MergeCells = True Then
    Set cc = Pic.TopLeftCell.MergeArea
    Pic.LockAspectRatio = msoFalse
    Pic.Top = cc.Top + 5
    Pic.Left = cc.Left + 5
    Pic.Height = cc.Height - 10
    Pic.Width = cc.Width - 10
    End If
Next
End Sub