1在单元格批注中插入图片
Sub 批注插图()
Dim arr As Object, FilPath$, rng As Range, Nrow%, address_picture$
Application.Calculation = xlManual
address_picture = InputBox("默认为桌面文件夹图片", "请输入图片路径", "输入路径")
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("默认为桌面文件夹图片", "请输入图片路径", "输入路径")
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点击单元格显示图片
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点击公式打开图片
=HYPERLINK("\\192.168.6.6\pic\"&A2&".jpg",A2)
