Excel插入图片

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 cell.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

    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)