EXCEL批量添加图片批注后怎么让图片保持原图比例 excel批注中插入图片后会变形，如何设定图片显示原始尺寸，...
\u5728EXCEL\u6279\u6ce8\u4e2d\u63d2\u5165\u56fe\u7247\u540e\uff0c\u5982\u4f55\u624d\u80fd\u9501\u5b9a\u56fe\u7247\u7684\u5927\u5c0f\uff0c\u4e5f\u5c31\u662f\u8bf4\u56fe\u7247\u5927\u5c0f\u4e0d\u4f1a\u968f\u7740\u63d2\u5165\u884c\u6216\u5217\u800c\u6539\u53d8\u3002\u5728\u56fe\u7247\u683c\u5f0f\u5c5e\u6027\u9009\u62e9\u5927\u5c0f\u3001\u4f4d\u7f6e\u5747\u56fa\u5b9a
\u88c5\u4e2a\u6b63\u7248\u7684\u8f6f\u4ef6
修改如下，照片文件夹路径可以通过对话框输入，也可将工作簿放在照片文件夹中，从而不必输入照片文件夹路径。代码通过预插入图片到单元格而获取图片尺寸，并将此用于批注框尺寸的设置。
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
结果图如下：横向图片
纵向图片：
你新建一个模块，插入如下代码：
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
绛旓細淇敼濡備笅锛岀収鐗囨枃浠跺す璺緞鍙互閫氳繃瀵硅瘽妗嗚緭鍏ワ紝涔熷彲灏嗗伐浣滅翱鏀惧湪鐓х墖鏂囦欢澶逛腑锛屼粠鑰屼笉蹇呰緭鍏ョ収鐗囨枃浠跺す璺緞銆備唬鐮侀氳繃棰鎻掑叆鍥剧墖鍒板崟鍏冩牸鑰岃幏鍙栧浘鐗囧昂瀵革紝骞跺皢姝ょ敤浜庢壒娉ㄦ灏哄鐨勮缃係ub 鎻掑叆鎵规敞鍥剧墖()Dim cell As Range, fd, t, w As Byte, h As Byte, Lj As String Lj = InputBox("璇疯緭鍏...
绛旓細1)閫夋嫨[鏉ユ簮鍗曞厓鏍糫[鍙抽敭][鎻掑叆鎵规敞]<浠ヤ笅璇烽敭鍏鑷畾鎵规敞鍐呭]> 2)閫夋嫨[鏉ユ簮鍗曞厓鏍糫[鍙抽敭][澶嶅埗]3)閫夋嫨[鐩爣鍗曞厓鏍(鍙互澶嶉夊鏍)][鍙抽敭][閫夋嫨鎬ч粡璐碷[閫夋嫨鎬ч粡璐碷<浜庡脊鍑虹殑[閫夋嫨鎬ч粡璐碷瑙嗙獥涓夊彇[鎵规敞]>[纭畾]浠ヤ笂涓 EXCEL 2010 鐨勫仛娉 渚濆叾鎿嶄綔锛屽彲浠ヤ竴娆″儚澶氫釜鐩爣璐翠笂鍚屼竴鎵规敞鐨勫唴瀹广
绛旓細閫変腑涓涓寘鍚浘鐗囩殑鎵规敞锛屽彸閿偣鍑诲苟閫夋嫨鈥滅紪杈戞壒娉ㄢ銆傚湪寮瑰嚭鐨勨滅紪杈戞壒娉ㄢ濈獥鍙ｄ腑锛岄変腑鍥剧墖骞跺彸閿偣鍑伙紝閫夋嫨鈥滃ぇ灏忓拰灞炴р濄傚湪寮瑰嚭鐨勨滄牸寮忓寲鍥剧墖鈥濈獥鍙ｄ腑锛屽彲浠ヨ皟鏁村浘鐗囩殑楂樺害鍜屽搴︺傚鏋滆淇濇寔鍥剧墖鐨勬瘮渚嬶紝鍙互鍕鹃夆滀繚鎸佺旱妯瘮鈥濄傝皟鏁村畬姣曞悗锛岀偣鍑烩滅‘瀹氣濇寜閽繚瀛樻洿鏀广傚叧闂滅紪杈戞壒娉ㄢ濈獥鍙ｏ紝骞堕...
绛旓細鎿嶄綔鏂规硶锛氶紶鏍囧崟鍑烩滄枃浠垛濊彍鍗曪紝鍦ㄦ墿灞曟鍐呮壘鍒扳滈夐」鈥滃苟鐐瑰嚮锛屾鏃朵細寮瑰嚭鈥Excel 閫夐」鈥滃璇濇銆傚鍥炬墍绀猴細鍦ㄥ脊鍑虹殑瀵硅瘽妗嗕腑閫夋嫨鈥濋珮绾р滐紝鎺ョ潃鍦ㄥ彸渚х殑鈥濈紪杈戦夐」鈥滀腑寰涓嬫壘鍒扳濇樉绀衡溿傚鍥炬墍绀猴細鎵惧埌鈥濇樉绀衡滃悗锛屼細鍙戠幇鍦ㄥ叾涓嬫柟澶勬湁涓浜涘叧浜庡崟鍏冩牸鎵规敞鐨勭浉鍏冲唴瀹广傝繖鏃舵垜浠篃灏变細鏄庣櫧涓轰粈涔鎻掑叆鐨...
绛旓細1銆侀鍏堟垜浠叏閫夎〃鏍硷紝璋冩暣琛ㄦ牸鐨勫垪瀹借楂樸傜劧鍚庣偣鍑汇愭彃鍏ャ-銆愬浘鐗囥戯紝灏嗗鍏ョ殑鍥剧墖鍏ㄩ儴閫夋嫨鎻掑叆杩涙潵銆傛帴鐫鍦ㄤ笂鏂圭殑鍥剧墖璁剧疆鏍忎腑璁剧疆鍥剧墖鐨勫ぇ灏忓搴︺傜劧鍚庡湪鏈鍚庝竴涓崟鍏冧腑棣栧厛鎻掑叆鍥剧墖銆2銆侀棶棰樹竴锛excel鎵规敞涓濡備綍鎻掑叆鍥剧墖鎵规敞涓姞鍥剧墖锛鎻掑叆鎵规敞-鐐瑰嚮鎵规敞杈规绾匡紝鍙抽敭锛岃缃壒娉ㄦ牸寮--绌胯壊涓庣嚎鏉--濉厖...
绛旓細1 To [a65536].End(3).Row If Range("B" & i) <> "" Then Range("A" & i).AddComment CStr(Range("B" & i).Value) Range("A" & i).Comment.Visible = False End IfNext iEnd Sub 鍙抽敭宸ヤ綔琛ㄦ爣绛撅紝鍙湅浠ｇ爜銆傜矘璐翠笂闈㈢殑浠ｇ爜銆傝繍琛屼唬鐮佸嵆鍙
绛旓細1銆侀変腑瑕佸鍒剁殑鍗曞厓鏍煎尯鍩燂紝鍗曞嚮榧犳爣鍙抽敭锛屽湪寮瑰嚭鐨勪笅鎷夎彍鍗曚腑閫夋嫨銆 澶嶅埗 銆戦夐」銆2銆侀変腑缂栬緫鍗曞厓鏍硷紝鍗曞嚮榧犳爣鍙抽敭锛屽湪寮瑰嚭鐨勪笅鎷夎彍鍗曚腑閫変腑銆 閫夋嫨鎬х矘甯 銆戦夐」銆3銆佸脊鍑恒 閫夋嫨鎬х矘璐 銆戦夐」銆4銆侀夋嫨銆 鎵规敞 銆戦夐」锛屽崟鍑汇 纭畾 銆戞寜閽5銆佽繑鍥炲埌宸ヤ綔琛ㄤ腑锛屾壒娉ㄨ澶嶅埗鎴愬姛銆傚鏋滄槸鍏ㄩ儴锛岄偅...
绛旓細1銆佸崟鍑讳竴涓渶瑕鍔犳壒娉鐨勫崟鍏冩牸锛屽崟鍑涔嬪悗鍗曞嚮鍙抽敭锛屽湪涓嬫媺鐨勯夐」閲屽崟鍑"鎻掑叆鎵规敞鈥滄寜閽2銆佸崟鍑讳箣鍚庝細鍑虹幇濡傚浘鎵绀猴紝杩欐椂鍊欐垜浠湪鎵规敞妗嗛噷闈㈣緭鍏ユ垜浠兂瑕佸娉ㄧ殑淇℃伅銆3銆佸崟鍏冩牸鎵规敞鍐欏ソ涔嬪悗锛屽彸閿崟鍑昏鍗曞厓鏍硷紝鍦ㄤ笅鎷夌殑閫夐」閲屽崟鍑烩濆鍒垛滄寜閽4銆佸亣濡傛垜浠兂鍦―3锛孍3锛孌5锛孍6杩欎簺鍗曞厓鏍奸兘鎻掑叆鐩稿悓...
