1在單元格批注中插入圖片
Sub 批注插圖()
? ? Dim arr As Object, FilPath$, rng As Range, Nrow%, address_picture$
? ? Application.Calculation = xlManual
? ? address_picture = InputBox("默認(rèn)為桌面文件夾圖片", "請(qǐng)輸入圖片路徑", "輸入路徑")
? ? With Sheets("圖片")
? ? ? ? .Cells.ClearComments
? ? ? ? Nrow = .[a65536].End(3).Row
? ? ? ? If Nrow = 2 Then Exit Sub
? ? ? ? Set arr = .Range("a2:a" & Nrow)
? ? ? ? For Each rng In arr
? ? ? ? ? ? FilPath = address_picture & rng.Text & ".jpg"
? ? ? ? ? ? If Dir(FilPath) <> "" Then
? ? ? ? ? ? ? ? With rng.AddComment
? ? ? ? ? ? ? ? ? ? .Visible = True
? ? ? ? ? ? ? ? ? ? .Text Text:=""
? ? ? ? ? ? ? ? ? ? .Shape.Select True
? ? ? ? ? ? ? ? ? ? Selection.ShapeRange.Fill.UserPicture FilPath
? ? ? ? ? ? ? ? ? ? .Shape.Width = 150
? ? ? ? ? ? ? ? ? ? .Shape.Height = 150
? ? ? ? ? ? ? ? ? ? .Visible = False
? ? ? ? ? ? ? ? End With
? ? ? ? ? ? End If
? ? ? ? Next
? ? End With
? ? Set arr = Nothing
? ? Application.Calculation = xlAutomatic
End Sub
2 插入鏈接圖片
Sub 插入圖片()
? ? Application.ScreenUpdating = False
? ? With ActiveSheet
? ? ? ? For i = 1 To 21
? ? ? ? ? ? FilePath = "\\Zww\GX\下單圖片\" & .Cells(i, 1).text & ".jpg"
? ? ? ? ? ? If Dir(FilePath) <> "" Then
? ? ? ? ? ? ? ? Set rng = .Cells(i, 2)
? ? ? ? ? ? ? ? Set Insert_Pic = .Pictures.Insert(FilePath)
? ? ? ? ? ? ? ? With Insert_Pic
? ? ? ? ? ? ? ? ? ? .Placement = xlMoveAndSize
? ? ? ? ? ? ? ? ? ? .ShapeRange.LockAspectRatio = msoFalse
? ? ? ? ? ? ? ? ? ? .Top = rng.Top+3
? ? ? ? ? ? ? ? ? ? .Left = rng.Left+3
? ? ? ? ? ? ? ? ? ? .Height = rng.Height-6
? ? ? ? ? ? ? ? ? ? .Width = rng.Width-6
? ? ? ? ? ? ? ? End With
? ? ? ? ? End If
? ? ? ? Next
? ? End With
? ? Application.ScreenUpdating = True
End Sub
2在單元格中插入圖片
Sub 單元格圖片()
? ? Application.ScreenUpdating = False
? ? Dim n%, i%, address_picture$, FilePath$
? ? Dim pictures As Object
? ? n = [a65536].End(3).Row
? ? address_picture = InputBox("默認(rèn)為桌面文件夾圖片", "請(qǐng)輸入圖片路徑", "輸入路徑")
? ? For i = 2 To n
? ? ? ? FilePath = Dir(address_picture & Cells(i, 1) & ".*g")
? ? ? ? If Cells(i, 1) <> "" Then
? ? ? ? ? ? If Len(FilePath) > 0 Then
? ? ? ? ? ? ? ? With ActiveSheet.Cells(i, 2)
? ? ? ? ? ? ? ? ? ? ActiveSheet.Shapes.AddPicture address_picture & FilePath, True, True, .Left, .Top, .Width, .Height
? ? ? ? ? ? ? ? End With
? ? ? ? ? ? End If
? ? ? ? End If
? ? Next i
? ? Application.ScreenUpdating = True
End Sub
3點(diǎn)擊單元格顯示圖片
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
? ? Dim FilePath$
? ? FilePath = "\\192.168.6.6\pic\" & Cells(Target.Row, 1) & ".JPG"
? ? If Target.Column = 1 Then
? ? ? ? If Len(Dir(FilePath)) <> 0 Then
? ? ? ? ? ? With Image1
? ? ? ? ? ? ? ? .Picture = LoadPicture(FilePath)
? ? ? ? ? ? ? ? .Visible = True
? ? ? ? ? ? End With
? ? ? ? End If
? ? End If
4將批注的圖片顯示在單元格中
Sub 提取圖片()
? ? Dim Nrow&, i&, Pic_Width&, Pic_Height&, Com_Width&, Com_Height&, t!
? ? Application.ScreenUpdating = False
? ? Application.DisplayCommentIndicator = xlCommentAndIndicator
? ? On Error Resume Next
? ? With ActiveSheet
? ? ? ? Nrow = .[a65536].End(3).Row
? ? ? ? For i = 2 To Nrow
? ? ? ? ? ? If Not (.Range("a" & i).Comment Is Nothing) Then
? ? ? ? ? ? ? ? With .Range("a" & i).Comment
? ? ? ? ? ? ? ? ? ? Pic_Width = Range("h" & i).Width
? ? ? ? ? ? ? ? ? ? Pic_Height = Range("h" & i).Height
? ? ? ? ? ? ? ? ? ? With .Shape
? ? ? ? ? ? ? ? ? ? ? ? Com_Width = .Width
? ? ? ? ? ? ? ? ? ? ? ? Com_Height = .Height
? ? ? ? ? ? ? ? ? ? ? ? .ScaleWidth Pic_Width / Com_Width, msoFalse, msoScaleFromTopLeft
? ? ? ? ? ? ? ? ? ? ? ? .ScaleHeight Pic_Height / Com_Height, msoFalse, msoScaleFromTopLeft
? ? ? ? ? ? ? ? ? ? ? ? .CopyPicture xlScreen, xlPicture
? ? ? ? ? ? ? ? ? ? End With
? ? ? ? ? ? ? ? End With
? ? ? ? ? ? ? ? t = Timer
? ? ? ? ? ? ? ? While Timer < t + 0.01
? ? ? ? ? ? ? ? ? ? DoEvents
? ? ? ? ? ? ? ? Wend
? ? ? ? ? ? ? ? .Paste .Range("h" & i)
? ? ? ? ? ? ? ? With .Range("a" & i).Comment
? ? ? ? ? ? ? ? ? ? With .Shape
? ? ? ? ? ? ? ? ? ? ? ? .ScaleWidth Com_Width / Pic_Width, msoFalse, msoScaleFromTopLeft
? ? ? ? ? ? ? ? ? ? ? ? .ScaleHeight Com_Height / Pic_Height, msoFalse, msoScaleFromTopLeft
? ? ? ? ? ? ? ? ? ? End With
? ? ? ? ? ? ? ? End With
? ? ? ? ? ? End If
? ? ? ? Next i
? ? End With
? ? Application.ScreenUpdating = True
? ? Application.DisplayCommentIndicator = xlCommentIndicatorOnly
End Sub
5點(diǎn)擊公式打開(kāi)圖片
=HYPERLINK("\\192.168.6.6\pic\"&A2&".jpg",A2)
