App Store
Steam[转] 一键将图片批量导入excel
最近抽空写了一个小工具，一键将图片批量导入excel。这个工具主要是为了方便整理游戏项目中用到的图片，尤其是对于需要对界面图片字进行翻译时，可快速生成需求文档。 目前的项目有几个G的图片资源，数千张图片，人工插入费时费力，就写了这个小工具。下面是VBA代码，只需将其粘贴到excel编辑器内，写入图片目录地址，执行“批量导入”即可完成导入。
第一步：新建工作表
新建“目录”、“文件夹目录（勿删）”共2个空白工作表。
在“目录”表中J1写入准备导入的图片目录。
第二步：粘贴VBA代码
将一下代码粘贴到VBA编辑器内。
a.新建模块1，粘贴以下代码：
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public dizhi, BName As String, mypic, Picwidth, Picheight
Private Function ShowFolderList(folderspec)
'获取folderspec下的子文件夹列表 返回数组
Dim i, fs, f, f1, s, sf, arr
Dim hs, h, h1, hf
ReDim arr(1 To 60000)
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(folderspec)
Set sf = f.SubFolders
For Each f1 In sf
i = i + 1
arr(i) = f1.Name
Next
ReDim Preserve arr(1 To i)
ShowFolderList = arr
End Function
Sub 获取子目录内图片名()
'清空表“文件夹目录（勿删）”里的数据
Sheets("文件夹目录（勿删）").Select
Cells.Select
Selection.ClearContents
'获取图片目录地址
dizhi = Sheets("目录").Cells(1, 10)
Call 导出根目录 '导出根目录=============================
'写入所有子目录下png图片名
For genmlwjj = 1 To 100
If (Sheets("文件夹目录（勿删）").Cells(genmlwjj + 2, 1) = "") Then
Exit For
End If
zimulu = dizhi & "\" & Sheets("文件夹目录（勿删）").Cells(genmlwjj + 2, 1).Value
Sheets("文件夹目录（勿删）").Cells(2, genmlwjj + 1) = "子目录" & zimulu
tupianming = Dir(zimulu & "\*.png")
hang = 3
Do While tupianming > ""
Cells(hang, genmlwjj + 1).Value = tupianming
hang = hang + 1
tupianming = Dir
Loop
Next genmlwjj
End Sub
Private Sub 导出根目录()
Dim arr
arr = ShowFolderList(dizhi)
Debug.Print Join(arr, vbCr) '调试打印
[A3].Resize(UBound(arr)) = Application.Transpose(arr) '输出到A列
Sheets("文件夹目录（勿删）").Cells(2, 1) = "目录" & dizhi '输出A列字段名到表“文件夹目录（勿删）”
End Sub
Sub 新建或重置文件夹目录表()
Dim Wss As Worksheet, BName As String
' 判断表“文件夹目录（勿删）”是否存在
BName = "文件夹目录（勿删）"
On Error Resume Next
Set Wss = ActiveWorkbook.Sheets(BName)
If Wss Is Nothing Then
' MsgBox BName & " 不存在，立刻新建一个"
Worksheets.Add
ActiveSheet.Name = BName
Sheets(BName).Select
Range("A1").Select
Else
' MsgBox BName & "文件夹目录（勿删）表已存在"
End If
End Sub
Sub 相应的表内更新图片清单() '子目录对应表里写入图片名
Call 获取子目录内图片名 '========================================
Call 判断是否需新建表 '========================================
For genmlwjj = 1 To 100
If (Sheets("文件夹目录（勿删）").Cells(genmlwjj + 2, 1) = "") Then
Exit For
End If
lie = genmlwjj + 1
BName = Sheets("文件夹目录（勿删）").Cells(genmlwjj + 2, 1).Value
Sheets("文件夹目录（勿删）").Select
Columns(lie).Select
Selection.Copy
Sheets(BName).Select
Columns(2).Select
ActiveSheet.Paste
Next genmlwjj
End Sub
Sub 判断是否需新建表() '创建子目录工作表
Dim Ws As Worksheet, BName As String
On Error Resume Next
For genmlwjj = 1 To 999
If (Sheets("文件夹目录（勿删）").Cells(genmlwjj + 2, 1) = "") Then
Exit For
End If
BName = Sheets("文件夹目录（勿删）").Cells(genmlwjj + 2, 1).Value
Set Ws = ActiveWorkbook.Sheets(BName)
If Ws Is Nothing Then
' MsgBox BName & " 表不存在，立刻新建一个"
Sheets("文件夹目录（勿删）").Select
Range("A1").Select
Worksheets.Add
ActiveSheet.Name = BName
Else
' MsgBox BName & " 表已存在"
End If
Next genmlwjj
End Sub
' --------------------------------------------------------------------------------------------------------------------------------------------------------
Sub 对所有表更新图片() '导入图片
Call 相应的表内更新图片清单 '============================================
For genmlwjj = 1 To 999
If (Sheets("文件夹目录（勿删）").Cells(genmlwjj + 2, 1) = "") Then
Exit For
End If
BName = Sheets("文件夹目录（勿删）").Cells(genmlwjj + 2, 1).Value
Sheets(BName).Select
' ActiveSheet.Shapes.SelectAll
' Selection.Delete
' Range("A1").Select
Call 对单个表插入图片
Next genmlwjj
End Sub
Sub 对单个表插入图片()
Dim i As Integer
Dim FilPath As String
Dim rng As Range
Dim s As String
Sheets(BName).Cells(2, 3) = "中文"
Sheets(BName).Cells(2, 4) = "翻译"
Sheets(BName).Cells(2, 5) = "图片"
For i = 3 To 100
If Sheets(BName).Cells(i, 2) = "" Then
Exit For
End If
FilPath = dizhi & "\" & BName & "\" & Sheets(BName).Cells(i, 2).Value
If Dir(FilPath) <> "" Then
Set rng = Sheets(BName).Cells(i, 5)
With rng
ML = .Left + 5
MT = .Top + 5
MW = .Width
MH = .Height
mypic = FilPath
Call 获取图片尺寸
Sheets(BName).Select
Rows(i).Select
MaxHeight = 390 '设置图片最大高度为390
If Picheight >= MaxHeight Then '对较大图片进行等比缩放
Picwidth = Picwidth / (Picheight / MaxHeight)
Picheight = MaxHeight
Selection.RowHeight = MaxHeight + 10 '调整行高
Sheets(BName).Cells(i, 1) = "原图太大被我缩小了" '加入备注
Else
Selection.RowHeight = Picheight + 10 '调整行高
End If
MW = Picwidth '返回 图片 宽
MH = Picheight '返回 图片 高
'插入图片
ActiveSheet.Shapes.AddShape(msoShapeRectangle, ML, MT, MW, MH).Select
Selection.ShapeRange.Fill.UserPicture FilPath
End With
Else
s = s & Chr(10) & Sheets(BName).Cells(i, 2).Text
End If
Next
Sheets(BName).Cells(1, 1).Select
If s <> "" Then
MsgBox s & Chr(10) & "没有照片!"
End If
End Sub
'----------------------------------------------------------------------------------------------------------------------------------------------------------------
Sub 目录链接()
'清空=====================================
Sheets("目录").Select
Range("a1:b100").Select
Selection.ClearContents
'写入表名称和链接============================
h = 2 '开始的行
i = 1
For Each sh In Worksheets
Sheets("目录").Cells(i + h - 1, 1).Value = i '输出序号
Sheets("目录").Cells(i + h - 1, 2).Value = sh.Name '输出表名称
Sheets("目录").Cells(i + h - 1, 2).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="'" & sh.Name & "'!A1" '写入链接
If i = 1 Then
Sheets("目录").Cells(i + h - 1, 3).Value = "=HYPERLINK(" & Chr(34) & dizhi & Chr(34) & ")" '输出文件夹地址"
Else
Sheets("目录").Cells(i + h - 1, 3).Value = "=HYPERLINK(" & Chr(34) & dizhi & "\" & sh.Name & Chr(34) & ")" '输出文件夹地址"
End If
i = i + 1
Next sh
End Sub
Sub 文件链接()
dizhi = Sheets("目录").Cells(1, 10)
For i = 3 To 10
' Sheets("目录").Cells(i, 3) = dizhi & "\" & Sheets("目录").Cells(i, 2)
Sheets("目录").Hyperlinks.Add Anchor:=Cells(i, 3), Address:=dizhi, TextToDisplay:=rs.Fields(dizhi & "\" & Sheets("目录").Cells(i, 2)).Value
Next i
End Sub
'-------------------------------------------------------------------------------------------------------------------------------------------------
Sub 更新文档()
Call 对所有表更新图片
Call 目录链接
End Sub
'---------------------------------------------------------------------------------------------------------------------------------------------------
Sub 删除所有表里的图片()
Call 相应的表内更新图片清单 '============================================
For genmlwjj = 1 To 100
If (Sheets("文件夹目录（勿删）").Cells(genmlwjj + 2, 1) = "") Then
Exit For
End If
BName = Sheets("文件夹目录（勿删）").Cells(genmlwjj + 2, 1).Value
Sheets(BName).Select '选表
ActiveSheet.Shapes.SelectAll '选图片对象
Selection.Delete
Range("A1").Select
Next genmlwjj
End Sub
b.新建模块2，粘贴以下代码：
'------------------------------------------------------------------------------------------------------------------------------------------------------------
'***************************************************
'* 模 块 名：mdLSPicSize
'* 功能描述：读取图片尺寸信息(不加载图片，支持PNG)
'* 作 者：
'* 作者博客：
'* 日 期：2012-01-21 21:39
'* 版 本：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 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
f = mypic '图片文件完成路径
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)) '返回 图片 高
Picwidth = Pwidth '赋值到
Picheight = Pheight '赋值到
End If
End Sub
第三步：创建按钮
在“目录”工作表中创建2个按钮，分别指向宏“更新文档”、“删除所有表里的图片” 。
第四步：工具完成
导入后效果：
欢迎有兴趣的朋友共同探讨！
转自 http://user.qzone.qq.com/1437900504/blog/1459218778
第一步：新建工作表
新建“目录”、“文件夹目录（勿删）”共2个空白工作表。
在“目录”表中J1写入准备导入的图片目录。
第二步：粘贴VBA代码
将一下代码粘贴到VBA编辑器内。
a.新建模块1，粘贴以下代码：
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public dizhi, BName As String, mypic, Picwidth, Picheight
Private Function ShowFolderList(folderspec)
'获取folderspec下的子文件夹列表 返回数组
Dim i, fs, f, f1, s, sf, arr
Dim hs, h, h1, hf
ReDim arr(1 To 60000)
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(folderspec)
Set sf = f.SubFolders
For Each f1 In sf
i = i + 1
arr(i) = f1.Name
Next
ReDim Preserve arr(1 To i)
ShowFolderList = arr
End Function
Sub 获取子目录内图片名()
'清空表“文件夹目录（勿删）”里的数据
Sheets("文件夹目录（勿删）").Select
Cells.Select
Selection.ClearContents
'获取图片目录地址
dizhi = Sheets("目录").Cells(1, 10)
Call 导出根目录 '导出根目录=============================
'写入所有子目录下png图片名
For genmlwjj = 1 To 100
If (Sheets("文件夹目录（勿删）").Cells(genmlwjj + 2, 1) = "") Then
Exit For
End If
zimulu = dizhi & "\" & Sheets("文件夹目录（勿删）").Cells(genmlwjj + 2, 1).Value
Sheets("文件夹目录（勿删）").Cells(2, genmlwjj + 1) = "子目录" & zimulu
tupianming = Dir(zimulu & "\*.png")
hang = 3
Do While tupianming > ""
Cells(hang, genmlwjj + 1).Value = tupianming
hang = hang + 1
tupianming = Dir
Loop
Next genmlwjj
End Sub
Private Sub 导出根目录()
Dim arr
arr = ShowFolderList(dizhi)
Debug.Print Join(arr, vbCr) '调试打印
[A3].Resize(UBound(arr)) = Application.Transpose(arr) '输出到A列
Sheets("文件夹目录（勿删）").Cells(2, 1) = "目录" & dizhi '输出A列字段名到表“文件夹目录（勿删）”
End Sub
Sub 新建或重置文件夹目录表()
Dim Wss As Worksheet, BName As String
' 判断表“文件夹目录（勿删）”是否存在
BName = "文件夹目录（勿删）"
On Error Resume Next
Set Wss = ActiveWorkbook.Sheets(BName)
If Wss Is Nothing Then
' MsgBox BName & " 不存在，立刻新建一个"
Worksheets.Add
ActiveSheet.Name = BName
Sheets(BName).Select
Range("A1").Select
Else
' MsgBox BName & "文件夹目录（勿删）表已存在"
End If
End Sub
Sub 相应的表内更新图片清单() '子目录对应表里写入图片名
Call 获取子目录内图片名 '========================================
Call 判断是否需新建表 '========================================
For genmlwjj = 1 To 100
If (Sheets("文件夹目录（勿删）").Cells(genmlwjj + 2, 1) = "") Then
Exit For
End If
lie = genmlwjj + 1
BName = Sheets("文件夹目录（勿删）").Cells(genmlwjj + 2, 1).Value
Sheets("文件夹目录（勿删）").Select
Columns(lie).Select
Selection.Copy
Sheets(BName).Select
Columns(2).Select
ActiveSheet.Paste
Next genmlwjj
End Sub
Sub 判断是否需新建表() '创建子目录工作表
Dim Ws As Worksheet, BName As String
On Error Resume Next
For genmlwjj = 1 To 999
If (Sheets("文件夹目录（勿删）").Cells(genmlwjj + 2, 1) = "") Then
Exit For
End If
BName = Sheets("文件夹目录（勿删）").Cells(genmlwjj + 2, 1).Value
Set Ws = ActiveWorkbook.Sheets(BName)
If Ws Is Nothing Then
' MsgBox BName & " 表不存在，立刻新建一个"
Sheets("文件夹目录（勿删）").Select
Range("A1").Select
Worksheets.Add
ActiveSheet.Name = BName
Else
' MsgBox BName & " 表已存在"
End If
Next genmlwjj
End Sub
' --------------------------------------------------------------------------------------------------------------------------------------------------------
Sub 对所有表更新图片() '导入图片
Call 相应的表内更新图片清单 '============================================
For genmlwjj = 1 To 999
If (Sheets("文件夹目录（勿删）").Cells(genmlwjj + 2, 1) = "") Then
Exit For
End If
BName = Sheets("文件夹目录（勿删）").Cells(genmlwjj + 2, 1).Value
Sheets(BName).Select
' ActiveSheet.Shapes.SelectAll
' Selection.Delete
' Range("A1").Select
Call 对单个表插入图片
Next genmlwjj
End Sub
Sub 对单个表插入图片()
Dim i As Integer
Dim FilPath As String
Dim rng As Range
Dim s As String
Sheets(BName).Cells(2, 3) = "中文"
Sheets(BName).Cells(2, 4) = "翻译"
Sheets(BName).Cells(2, 5) = "图片"
For i = 3 To 100
If Sheets(BName).Cells(i, 2) = "" Then
Exit For
End If
FilPath = dizhi & "\" & BName & "\" & Sheets(BName).Cells(i, 2).Value
If Dir(FilPath) <> "" Then
Set rng = Sheets(BName).Cells(i, 5)
With rng
ML = .Left + 5
MT = .Top + 5
MW = .Width
MH = .Height
mypic = FilPath
Call 获取图片尺寸
Sheets(BName).Select
Rows(i).Select
MaxHeight = 390 '设置图片最大高度为390
If Picheight >= MaxHeight Then '对较大图片进行等比缩放
Picwidth = Picwidth / (Picheight / MaxHeight)
Picheight = MaxHeight
Selection.RowHeight = MaxHeight + 10 '调整行高
Sheets(BName).Cells(i, 1) = "原图太大被我缩小了" '加入备注
Else
Selection.RowHeight = Picheight + 10 '调整行高
End If
MW = Picwidth '返回 图片 宽
MH = Picheight '返回 图片 高
'插入图片
ActiveSheet.Shapes.AddShape(msoShapeRectangle, ML, MT, MW, MH).Select
Selection.ShapeRange.Fill.UserPicture FilPath
End With
Else
s = s & Chr(10) & Sheets(BName).Cells(i, 2).Text
End If
Next
Sheets(BName).Cells(1, 1).Select
If s <> "" Then
MsgBox s & Chr(10) & "没有照片!"
End If
End Sub
'----------------------------------------------------------------------------------------------------------------------------------------------------------------
Sub 目录链接()
'清空=====================================
Sheets("目录").Select
Range("a1:b100").Select
Selection.ClearContents
'写入表名称和链接============================
h = 2 '开始的行
i = 1
For Each sh In Worksheets
Sheets("目录").Cells(i + h - 1, 1).Value = i '输出序号
Sheets("目录").Cells(i + h - 1, 2).Value = sh.Name '输出表名称
Sheets("目录").Cells(i + h - 1, 2).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="'" & sh.Name & "'!A1" '写入链接
If i = 1 Then
Sheets("目录").Cells(i + h - 1, 3).Value = "=HYPERLINK(" & Chr(34) & dizhi & Chr(34) & ")" '输出文件夹地址"
Else
Sheets("目录").Cells(i + h - 1, 3).Value = "=HYPERLINK(" & Chr(34) & dizhi & "\" & sh.Name & Chr(34) & ")" '输出文件夹地址"
End If
i = i + 1
Next sh
End Sub
Sub 文件链接()
dizhi = Sheets("目录").Cells(1, 10)
For i = 3 To 10
' Sheets("目录").Cells(i, 3) = dizhi & "\" & Sheets("目录").Cells(i, 2)
Sheets("目录").Hyperlinks.Add Anchor:=Cells(i, 3), Address:=dizhi, TextToDisplay:=rs.Fields(dizhi & "\" & Sheets("目录").Cells(i, 2)).Value
Next i
End Sub
'-------------------------------------------------------------------------------------------------------------------------------------------------
Sub 更新文档()
Call 对所有表更新图片
Call 目录链接
End Sub
'---------------------------------------------------------------------------------------------------------------------------------------------------
Sub 删除所有表里的图片()
Call 相应的表内更新图片清单 '============================================
For genmlwjj = 1 To 100
If (Sheets("文件夹目录（勿删）").Cells(genmlwjj + 2, 1) = "") Then
Exit For
End If
BName = Sheets("文件夹目录（勿删）").Cells(genmlwjj + 2, 1).Value
Sheets(BName).Select '选表
ActiveSheet.Shapes.SelectAll '选图片对象
Selection.Delete
Range("A1").Select
Next genmlwjj
End Sub
b.新建模块2，粘贴以下代码：
'------------------------------------------------------------------------------------------------------------------------------------------------------------
'***************************************************
'* 模 块 名：mdLSPicSize
'* 功能描述：读取图片尺寸信息(不加载图片，支持PNG)
'* 作 者：
'* 作者博客：
'* 日 期：2012-01-21 21:39
'* 版 本：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 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
f = mypic '图片文件完成路径
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)) '返回 图片 高
Picwidth = Pwidth '赋值到
Picheight = Pheight '赋值到
End If
End Sub
第三步：创建按钮
在“目录”工作表中创建2个按钮，分别指向宏“更新文档”、“删除所有表里的图片” 。
第四步：工具完成
导入后效果：
欢迎有兴趣的朋友共同探讨！
转自 http://user.qzone.qq.com/1437900504/blog/1459218778
评论
登录 后参与讨论
暂无评论，来抢沙发
闽公网安备 35020302034348号