EXCEL批量添加图片批注后怎么让图片保持原图比例

Question

EXCEL批量添加图片批注后怎么让图片保持原图比例
这是我用批量添加图片批注用的宏代码
Sub 批量插入批注图片()
Dim cell As Range, fd, t, w As Byte, h As Byte
Selection.ClearComments
If Selection(1) = "" Then MsgBox "不能选择空白区。", 64, "提示": Exit Sub
On Error Resume Next
w = 2.5
h = 2.5

For Each cell In Selection
With cell.AddComment
.Visible = True
.Text Text:=""
.Shape.Select True
With Selection.ShapeRange
.Fill.UserPicture "F:\2014年棉鞋图片" & "\" & cell.Text & ".jpg"
.ScaleWidth w / 1.39, msoFalse, msoScaleFromTopLeft
.ScaleHeight h / 1.09, msoFalse, msoScaleFromTopLeft
End With
cell.Offset(1, 0).Select
.Visible = False
End With
Next
Exit Sub
End Sub
效果如图 因为是鞋类图片的关系有些图的比例不对

如果用宏代码批量修改批注框大小也不行 因为表格里还有其他不同类型鞋子的图片如果批量改大小其他图片也会变形

我是想让插入图片保持原有的比例 希望各路大神能指点一二是否是代码需要修改还是有其他方法。EXCEL百宝箱用不了因为是办公电脑这类更改系统设定的软件都被禁止安装了。下图是我期望达到的效果

Answer 1

修改如下，照片文件夹路径可以通过对话框输入，也可将工作簿放在照片文件夹中，从而不必输入照片文件夹路径。代码通过预插入图片到单元格而获取图片尺寸，并将此用于批注框尺寸的设置。

Sub æ’入批注图片()

   Dim cell As Range, fd, t, w As Byte, h As Byte, Lj As String

   Lj = InputBox("请输入JPG格式图片文件所在文件夹的路径：", , ThisWorkbook.Path)  '获取路径,默认为当前文件夹路径

   Selection.ClearComments

   If Selection(1) = "" Then MsgBox "不能选择空白区。", 64, "提示": Exit Sub

   On Error Resume Next

   

   For Each cell In Selection

       ActiveSheet.Pictures.Insert(Lj & "\" & cell.Text & ".jpg").Select

       w = Selection.Width

       h = Selection.Height

       Selection.Delete

       

       With cell.AddComment

         .Visible = True

         .Text Text:=""

         .Shape.Select True

         With Selection.ShapeRange

            .LockAspectRatio = msoFalse

            .Height = h * 3        '此处的3是指放大3倍显示，可自行调整

            .Width = w * 3         '此处的3是指放大3倍显示，可自行调整

            .LockAspectRatio = msoTrue

            .Fill.UserPicture Lj & "\" & cell.Text & ".jpg"

         End With

         cell.Offset(1, 0).Select

        .Visible = False

       End With

   Next

   Exit Sub

End Sub

结果图如下：横向图片

纵向图片：

Answer 2

你新建一个模块，插入如下代码：

Private Type BitmapFileHeader
    bfType As Integer    '标识 0,1 两个字节为 42 4D 低位在前，即 19778
    bfReserved2 As Integer
    bfOffBits As Long
    bfReserved1 As Integer
    bfSize As Long
End Type
Private Type BitmapInfoHeader
    biSize As Long
    biWidth As Long    '宽度 18,19,20,21 四个字节，低位在前
    biHeight As Long    '高度 22,23,24,25 四个字节，低位在前
    '  biPlanes As Integer
    '  biBitCount As Integer
    '  biCompression As Long
    '  biSizeImage As Long
    '  biXPelsPerMeter As Long
    '  biYPelsPerMeter As Long
    '  biClrUsed As Long
    '  biClrImportant As Long
End Type
'JPEG（这个好麻烦）
Private Type LSJPEGHeader
    jSOI As Integer    '图像开始标识 0,1 两个字节为 FF D8 低位在前，即 -9985
    jAPP0 As Integer    'APP0块标识 2,3 两个字节为 FF E0
    jAPP0Length(1) As Byte   'APP0块标识后的长度，两个字节，高位在前
    '  jJFIFName As Long         'JFIF标识 49(J) 48(F) 44(I) 52(F)
    '  jJFIFVer1 As Byte         'JFIF版本
    '  jJFIFVer2 As Byte         'JFIF版本
    '  jJFIFVer3 As Byte         'JFIF版本
    '  jJFIFUnit As Byte
    '  jJFIFX As Integer
    '  jJFIFY As Integer
    '  jJFIFsX As Byte
    '  jJFIFsY As Byte
End Type
Private Type LSJPEGChunk
    jcType As Integer    '标识（按顺序）：APPn(0,1~15)为 FF E1~FF EF; DQT为 FF DB(-9217)
    'SOFn(0~3)为 FF C0(-16129),FF C1(-15873),FF C2(-15617),FF C3(-15361)
    'DHT为 FF C4(-15105); 图像数据开始为 FF DA
    jcLength(1) As Byte    '标识后的长度，两个字节，高位在前
    '若标识为SOFn，则读取以下信息；否则按照长度跳过，读下一块
    jBlock As Byte    '数据采样块大小 08 or 0C or 10
    jHeight(1) As Byte    '高度两个字节，高位在前
    jWidth(1) As Byte    '宽度两个字节，高位在前
    '  jColorType As Byte        '颜色类型 03，后跟9字节，然后是DHT
End Type
'PNG文件头
Private Type LSPNGHeader
    pType As Long    '标识 0,1,2,3 四个字节为 89 50(P) 4E(N) 47(G) 低位在前，即 1196314761
    pType2 As Long    '标识 4,5,6,7 四个字节为 0D 0A 1A 0A
    pIHDRLength As Long    'IHDR块标识后的长度，疑似固定 00 0D，高位在前，即 13
    pIHDRName As Long    'IHDR块标识 49(I) 48(H) 44(D) 52(R)
    Pwidth(3) As Byte    '宽度 16,17,18,19 四个字节，高位在前
    Pheight(3) As Byte    '高度 20,21,22,23 四个字节，高位在前
    '  pBitDepth As Byte
    '  pColorType As Byte
    '  pCompress As Byte
    '  pFilter As Byte
    '  pInterlace As Byte
End Type
'GIF文件头（这个好简单）
Private Type LSGIFHeader
    gType1 As Long    '标识 0,1,2,3 四个字节为 47(G) 49(I) 46(F) 38(8) 低位在前，即 944130375
    gType2 As Integer    '版本 4,5 两个字节为 7a单幅静止图像9a若干幅图像形成连续动画
    gWidth As Integer    '宽度 6,7 两个字节，低位在前
    gHeight As Integer    '高度 8,9 两个字节，低位在前
End Type
Public Function PictureSize(ByVal picPath As String, ByRef Width As Long, ByRef Height As Long) As String
    Dim iFile As Integer
    Dim jpg As LSJPEGHeader
    Width = 0: Height = 0             '预输出：0 * 0
    If picPath = "" Then PictureSize = "null": Exit Function          '文件路径为空
    If Dir(picPath) = "" Then PictureSize = "not exist": Exit Function    '文件不存在
    PictureSize = "error"             '预定义：出错
    iFile = FreeFile()
    Open picPath For Binary Access Read As #iFile
    Get #iFile, , jpg
    If jpg.jSOI = -9985 Then
        Dim jpg2 As LSJPEGChunk, pass As Long
        pass = 5 + jpg.jAPP0Length(0) * 256 + jpg.jAPP0Length(1)      '高位在前的计算方法
        PictureSize = "JPEG error"    'JPEG分析出错
        Do
            Get #iFile, pass, jpg2
            If jpg2.jcType = -16129 Or jpg2.jcType = -15873 Or jpg2.jcType = -15617 Or jpg2.jcType = -15361 Then
                Width = jpg2.jWidth(0) * 256 + jpg2.jWidth(1)
                Height = jpg2.jHeight(0) * 256 + jpg2.jHeight(1)
                PictureSize = Width & "*" & Height
                'PictureSize = "JPEG"  'JPEG分析成功
                Stop
                Exit Do
            End If
            pass = pass + jpg2.jcLength(0) * 256 + jpg2.jcLength(1) + 2
        Loop While jpg2.jcType <> -15105    'And pass < LOF(iFile)
    ElseIf jpg.jSOI = 19778 Then
        Dim bmp As BitmapInfoHeader
        Get #iFile, 15, bmp
        Width = bmp.biWidth
        Height = bmp.biHeight
        PictureSize = Width & "*" & Height
        ' PictureSize = "BMP"           'BMP分析成功
    Else
        Dim png As LSPNGHeader
        Get #iFile, 1, png
        If png.pType = 1196314761 Then
            Width = png.Pwidth(0) * 16777216 + png.Pwidth(1) * 65536 + png.Pwidth(2) * 256 + png.Pwidth(3)
            Height = png.Pheight(0) * 16777216 + png.Pheight(1) * 65536 + png.Pheight(2) * 256 + png.Pheight(3)
            PictureSize = Width & "*" & Height
            'PictureSize = "PNG"       'PNG分析成功
        ElseIf png.pType = 944130375 Then
            Dim gif As LSGIFHeader
            Get #iFile, 1, gif
            Width = gif.gWidth
            Height = gif.gHeight
            PictureSize = Width & "*" & Height
            'PictureSize = "GIF"       'GIF分析成功
        Else
            PictureSize = "unknow"    '文件类型未知
        End If
    End If
    Close #iFile
End Function

然后在你的代码上做如下修改：

Sub 批量插入批注图片()
   Dim cell As Range, fd, t, w As long, h As long
   Selection.ClearComments
   If Selection(1) = "" Then MsgBox "不能选择空白区。", 64, "提示": Exit Sub
   On Error Resume Next
   For Each cell In Selection
       With cell.AddComment
         .Visible = True
         .Text Text:=""
         .Shape.Select True
         With Selection.ShapeRange
            psize=PictureSize("F:\2014年棉鞋图片" & "\" & cell.Text & ".jpg", w, h)
            .Fill.UserPicture "F:\2014年棉鞋图片" & "\" & cell.Text & ".jpg"
            .LockAspectRatio = msoTrue
            'psize得到像素值如：400*300这样，所以我统一用像素值除以300，这个300你自己修改成适合你的
            .ScaleWidth Split(Psize, "*")(0) / 300, msoFalse, msoScaleFromTopLeft
            .ScaleHeight Split(Psize, "*")(1) / 300, msoFalse, msoScaleFromTopLeft
         End With
         cell.Offset(1, 0).Select
        .Visible = False
       End With
   Next
   Exit Sub
End Sub

追问

根据您的答案操作 在执行代码后出现了错误

追答

具体的错误信息是什么?