应用场景：

1、在excel中，有很多型号的产品名称，需要鼠标悬浮到某产品型号上自动在excel中显示对应的图片，用来对比筛选

2、公司举行某活动，需要对用户反馈的图片进行人工甄选、审查等等，具体用途可以拓展。

使用方法：

为下面宏命令添加快捷键，可将其导出为加载宏，在excel中调用该加载宏，使用快捷键即可批量快速给目标单元格加上图片批注。

宏命令如下：

'***************************************************
'* 加载宏：excel图片批量添加批注功能
'* 功能描述：对本地文档里图片，自动进行对应至excel中单元格
'* 作 者：simon
'* 作者博客：sunweiwei.com
'* 日 期：2015-6-4
'* 版 本：V1.0.0
'***************************************************
'整行注释的为在读取图片尺寸时不需要的文件头信息
'BMP文件头
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 单元格
Dim w As Long, h As Long
Dim f As String '图片文件完成路径
Dim t As String
Dim Pwidth As Long, Pheight As Long
Dim Psize As String
On Error Resume Next
For Each 单元格 In Selection
单元格.AddComment
单元格.Comment.Shape.Fill.UserPicture ActiveWorkbook.Path & "\pic\" & Replace(单元格.Value, "[图片]", "") & ".jpg"
f = ActiveWorkbook.Path & "\pic\" & Replace(单元格.Value, "[图片]", "") & ".jpg" '图片文件完成路径
Psize = PictureSize(f, w, h) '运行宏，w，h就是对应图片的width height ,返回 width*height
If Len(Psize) > 0 Then
Pwidth = Val(Split(Psize, "*")(0)) '返回 图片 宽
Pheight = Val(Split(Psize, "*")(1)) '返回 图片 高
End If
单元格.Comment.Shape.Height = Pheight / 4
单元格.Comment.Shape.Width = Pwidth / 4
Next 单元格
End Sub

最近帮别人做一个词性词频统计工具，顺便又有一个小需求：需要在word中设置个宏命令，用来根据本地指定txt(如word.txt)中的多个词语，检索word中所有出现的词语，宏命令需要对这些词加粗/颜色/背景色或者替换成其它内容，突出高亮显示该词。打开word后，只需要按一下快捷键即可自动执行操作。

宏命令简介：即在office中可以进行批量辅助操作的工具，可通过自带的vba编写。其优点是可视化操作、不需要另外开发软件来进行一些小型且有逻辑性的批量处理需求，比较小巧方便。(不是每个需求都要搞个软件出来，效率易用很重要)

当然宏命令有缺点，功能没有一般编程语言那么强大，且因为是vb语法，写起来很dt，而且自动补全竟然还和搜狗输入法冲突，只能通过点击菜单来自动补全，对新手来说，完全没有pycharm中的流畅感。。。还好学习成本不高，研究一会儿大致就能鼓捣个功能出来。

VBA其实并不复杂，门槛比较低，刚接触这块可能会比较陌生，推荐下我的快速学习方法，直接在word中录制宏，随便执行几个操作，然后在vba里查看脚本的代码，分析一下语法，需要什么功能谷歌一下不要用百度，找找差不多代码了解下原理基本就OK了。

好了，脚本如下，有此类需求的可以拿去直接修改修改就能用了。

脚本说明：其中ActiveDocument.Path是获取doc所在的当前目录；word.txt为存放待查找的词语文件（格式为一行一个）；fso为创建的对象，nr为读取txt的文本内容，vbCrLf为vb里规定的回车符+换行符，arr为词语的数组形式，UBound是取数组最大下标，玩过按键精灵的可能比较熟悉，通过arr(i)来定位每一个元素，之后执行一个for循环，设定待查找文本.Text = arr(i)，wdReplaceAll全部替换成另外的格式，Selection.Find.Replacement.Font里各参数表示替换后的格式，可以是各种姿势以达到你的需求。

使用方法：直接复制到你的宏命令里，然后在word的自定义功能里，给这个宏添加个快捷键，这样就可以通过快捷键自动执行了。

我这里衍生一下，这个脚本可以衍生成一个文章的“伪原创”工具，比如同义词批量替换，反义词替换等等，只需要设定好要替换的内容。

好了，废话太多了，周末愉快~

Sub 宏1()
'
' 宏1 宏
'
'
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.opentextfile(ActiveDocument.Path + "\word.txt") '打开文件流
nr = f.readall
arr = Split(nr, vbCrLf) '分割数组

 Selection.Find.ClearFormatting
 Selection.Find.Replacement.ClearFormatting
 With Selection.Find.Replacement.Font
 .Bold = True
 .Color = wdColorRed
 End With

Dim i As Long
For i = 0 To UBound(arr)
 With Selection.Find
 .Text = arr(i)
 .Replacement.Text = ""
 .Forward = True
 .Wrap = wdFindContinue
 .Format = True
 .MatchCase = False
 .MatchWholeWord = False
 .MatchByte = True
 .MatchWildcards = False
 .MatchSoundsLike = False
 .MatchAllWordForms = False
 End With

Selection.Find.Execute Replace:=wdReplaceAll
Next

Set fso = Nothing
Set f = Nothing

End Sub