|
|
VB在表格中批量插入图片，后期绑定，支持office 和WPS 表格，感谢版主和的指导，不敢独享，能用到的小伙伴尽情下载。
因为满足之前的工作，就没有再进行优化和修改了。
使用说明，1、打开表格，2、打开存放图片的文件夹。
检测表格中的字段与打开文件夹中的字段进行匹配。字段一致将照片插入对应的行中。
用到了一个美化控件，请先注册WinXPC_Engine.ocx ，压缩文件中有
Option Explicit
Private Declare Function GetTickCount Lib "kernel32" () As Long '时间API
Private getdir As String
Private Const BIF_RETURNONLYFSDIRS = 1
Private Const BIF_DONTGOBELOWDOMAIN = 2
Private Const MAX_PATH = 260
Private Declare Function SHBrowseForFolder Lib "Shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "Shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Type BrowseInfo
hWndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Private Sub Command1_Click()
Dim xlApp As Object
Dim excelFilter As String
Dim excelISAM As String
Dim strPath As String
Dim 图片插入列 As Integer
Dim 字符搜索列 As Integer
excelFilter = ""
excelISAM = ""
strPath = ""
If IsNumeric(Trim(Me.Text1.Text)) = True Then
图片插入列 = Val(Me.Text1.Text)
Else
图片插入列 = 8
End If
If IsNumeric(Trim(Me.Text2.Text)) = True Then
字符搜索列 = Val(Me.Text2.Text)
Else
字符搜索列 = 4
End If
If CreateExcelObject(xlApp, excelISAM, excelFilter) = False Then
MsgBox "本机未安装Excel或者WPS，导出失败！", "温馨提示"
Exit Sub
End If
Dim odgpath As String
CommonDialog1.DialogTitle = "打开需要处理的文件"
CommonDialog1.Flags = CommonDialog1.Flags Or cdlOFNOverwritePrompt
CommonDialog1.filter = "(*.xls)|*.xls|(*.xlsx)|*.xlsx|(*.*)|*.*|"
CommonDialog1.ShowOpen '打开需要处理的表格文件
If CommonDialog1.FileName = "" Then
MsgBox "没有打开需要处理的表格文件"
' Me.Label2.Caption = "没有打开表格文件"
Exit Sub
End If
odgpath = CommonDialog1.FileName '获取表格文件的地址
Dim StartT As Long '获取运算开始时间
Dim SpendT As Long '获取运算结束时间
StartT = GetTickCount
xlApp.Visible = False
Dim wps_doc As Object
Dim xlSheet As Object
Set wps_doc = xlApp.Workbooks.Open(odgpath)
Set xlSheet = wps_doc.sheets(1)
Dim i, n As Long
'==============================================================================================================
'弹出对话框，用于选择文件夹
'==========================
Dim lpIDList As Long
Dim sBuffer As String
Dim szTitle As String
Dim tBrowseInfo As BrowseInfo
szTitle = ""
With tBrowseInfo
.hWndOwner = Me.hWnd
.lpszTitle = lstrcat(szTitle, "")
.ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
End With
lpIDList = SHBrowseForFolder(tBrowseInfo)
If (lpIDList) Then
sBuffer = Space(MAX_PATH)
SHGetPathFromIDList lpIDList, sBuffer
sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
strPath = sBuffer
End If
If strPath = "" Then Exit Sub '如果没有数据 直接退出
GetPath strPath, List1 '将图片数据列表至list1中
'MsgBox "aaa"
'文件夹，及子文件件都列表至list中
'=================================================================================================================
Dim Xl_str() As String '将表格中的数据存放在数组中
ReDim Xl_str(xlSheet.Range("A65536").End(3).Row)
For i = 1 To UBound(Xl_str)
Xl_str(i) = Format(xlSheet.Cells(i, 字符搜索列), "0")
'Debug.Print Xl_str(i)
Next i
' MsgBox "bbb"
Dim imge_str() As String '将图片名字和图片存放地址存放在数组中
Dim imge_path_str() As String
ReDim imge_path_str(Me.List1.ListCount - 1)
ReDim imge_str(Me.List1.ListCount - 1)
For n = 0 To UBound(imge_str)
imge_str(n) = f(Me.List1.list(n)) '存放图片名字
imge_path_str(n) = Me.List1.list(n) '存放图片地址
'Debug.Print "图片名字 " & imge_str(n) & " 图片地址 " & imge_path_str(n)
Next n
' MsgBox "共有" & n & " 张图片"
Dim Xl_imge_str() As String '将插入表格的图片地址保存在内存数组中
ReDim Xl_imge_str(UBound(Xl_str))
For i = 0 To UBound(Xl_str)
n = 0
Do
If Xl_str(i) = imge_str(n) Then
Xl_imge_str(i) = imge_path_str(n)
'Debug.Print " 图片地址 " & Xl_imge_str(i)
Exit Do
End If
n = n + 1
If n >= UBound(imge_str) - 1 Then
Exit Do
End If
Loop
Next i
'MsgBox "共有" & i & " 张图片"
'MsgBox UBound(Xl_imge_str) '输出照片地址
Set xlSheet = wps_doc.sheets(1)
Dim i_jpg As Object
For i = 0 To UBound(Xl_imge_str)
If Xl_imge_str(i) "" Then
xlSheet.Cells(i, 图片插入列).Select '取得插入图片的位置
Set i_jpg = xlSheet.Pictures.Insert(Xl_imge_str(i)) '插入图片
i_jpg.Height = xlSheet.rows(i).RowHeight / 3 * 2.5 '这个数值是图片的高度，要根据要求作修改
i_jpg.Width = xlSheet.rows(i).RowHeight / 3 * 2.5 * 1.5 '这个数值是图片的宽度，要根据要求作修改
' xlSheet.Cells(i, 8) = "图片" '在插入图片的位置写入文字以便后续操作
End If
Next i
SpendT = GetTickCount - StartT
MsgBox ("本次操作耗时:" & Format(SpendT / 1000, "0.00") & "秒")
On Error Resume Next
Dim men As String
men = App.Path & "\1.xlsx"
'xlSheet.Cells(1, 1).Select
xlSheet.SaveAs (men) '保存处理后的表格文件
wps_doc.Close '关闭工作簿
xlApp.Quit '结束EXCEL对象
Set wps_doc = Nothing '释放xlApp对象
End Sub
Private Sub Command2_Click()
End
End Sub
Private Sub Form_Load()
Me.Command1.Caption = "开始"
Me.Command2.Caption = "退出"
WindowsXPC1.InitSubClassing
Me.Text1.Text = "8"
Me.Text2.Text = "4"
Me.Text3.Text = ""
End Sub
'======================
'取字符串函数
'用法 f(字符串) f()
'======================
Private Function f(X As String) As String
Dim s1 As String
Dim s2 As String
Dim s3 As String
Dim num As Integer
Dim i As Integer
num = Len(X)
i = num '得到字符串长度
Do Until Mid(X, i, 1) = "\"
i = i - 1 '从后向前查找倒数第一个"\"
Loop
s2 = Left(X, i - 1)
s3 = Mid(X, i + 1, Len(X) - i + 1) '倒数第一个"\"之前的字符串
s3 = Left(s3, 12)
f = s3
End Function
'Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'If Me.Height 3690 Then Me.Height = 3690
'If Me.Width 6360 Then Me.Width = 6360
'End Sub
Private Sub Form_Resize() ' 限制改变窗体大小
If Me.Height > 3690 Then Me.Height = 3690
If Me.Width > 6840 Then Me.Width = 6840
End Sub
下面是模块
Option Explicit
Private Const BIF_STATUSTEXT = &H4&
Private Const BIF_RETURNONLYFSDIRS = 1
Private Const BIF_DONTGOBELOWDOMAIN = 2
Private Const MAX_PATH = 260
Private Const WM_USER = &H400
Private Const BFFM_INITIALIZED = 1
Private Const BFFM_SELCHANGED = 2
Private Const BFFM_SETSTATUSTEXT = (WM_USER + 100)
Private Const BFFM_SETSelectION = (WM_USER + 102)
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Private Declare Function SHBrowseForFolder Lib "Shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "Shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Type BrowseInfo
hWndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Private m_CurrentDirectory As String 'The current directory
Public Function BrowseForFolder(owner As Form, Title As String, StartDir As String) As String
Dim lpIDList As Long
Dim szTitle As String
Dim sBuffer As String
Dim tBrowseInfo As BrowseInfo
m_CurrentDirectory = StartDir & vbNullChar
szTitle = Title
With tBrowseInfo
.hWndOwner = owner.hWnd
.lpszTitle = lstrcat(szTitle, "")
.ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN + BIF_STATUSTEXT
.lpfnCallback = GetAddressofFunction(AddressOf BrowseCallbackProc) 'get address of function.
End With
lpIDList = SHBrowseForFolder(tBrowseInfo)
If (lpIDList) Then
sBuffer = Space(MAX_PATH)
SHGetPathFromIDList lpIDList, sBuffer
sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
BrowseForFolder = sBuffer
Else
BrowseForFolder = ""
End If
End Function
Private Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lp As Long, ByVal pData As Long) As Long
Dim lpIDList As Long
Dim ret As Long
Dim sBuffer As String
On Error Resume Next
Select Case uMsg
Case BFFM_INITIALIZED
Call SendMessage(hWnd, BFFM_SETSelectION, 1, m_CurrentDirectory)
Case BFFM_SELCHANGED
sBuffer = Space(MAX_PATH)
ret = SHGetPathFromIDList(lp, sBuffer)
If ret = 1 Then
Call SendMessage(hWnd, BFFM_SETSTATUSTEXT, 0, sBuffer)
End If
End Select
BrowseCallbackProc = 0
End Function
Private Function GetAddressofFunction(add As Long) As Long
GetAddressofFunction = add
End Function
'Function ShowFolderSelection(ByVal hWnd As Long, ByVal Prompt As String) As String
''========================================================
'' 打开 Windows 的选择目录对话框
'' hwnd 为窗口句柄(通常设为 Me.hwnd), Prompt 为指示字符串
''========================================================
' Dim iNull As Integer
' Dim lpIDList As Long
' Dim lResult As Long
' Dim sPath As String
' Dim udtBI As BrowseInfo
'
' With udtBI
' .hWndOwner = hWnd
' .lpszTitle = lstrcat(Prompt, "")
' .ulFlags = BIF_RETURNONLYFSDIRS
' End With
'
' lpIDList = SHBrowseForFolder(udtBI)
' If lpIDList Then
' sPath = String$(MAX_PATH, 0)
' lResult = SHGetPathFromIDList(lpIDList, sPath)
' CoTaskMemFree lpIDList
' iNull = InStr(sPath, vbNullChar)
' If iNull Then sPath = Left$(sPath, iNull - 1)
' End If
' ShowFolderSelection = sPath
'End Function
Public Function CreateExcelObject(ByRef xlApp As Object, ByRef ISAM As String, ByRef filter As String) As Boolean
'===============================================================================================
'后期绑定Excel对象 不需要知道系统安装的是哪个版本的Excel
'不需要引用Excel
''' =====================================================================================
'''office97 8.0
'''office2000 9.0
'''officeXP (2002) 10.0
'''office2003 11.0
'''office2007 12.0
'''office2010 14.0
'''根据系统安装的Excel（Excel或者wps）创建Excel对象
''' 一定要先et 然后在ket 最后才是excel
''' 在系统中，office excel 比wps 表格具有优先级或者是注册表里面某项决定的
'''
'''
''' 索引顺序访问方法
''' 文件后缀
''' ===========================================================================
On Error GoTo ErrHandle
Dim funcResult As Boolean
'尝试创建wps对象（et 或者ket）
If GetWPS_V8VerFromActiveX(xlApp, ISAM, filter) = True Then
CreateExcelObject = True
MsgBox "本电脑安装了WPS V8及以下版本"
Exit Function
End If
If GetWPS_V9VerAboveFromActiveX(xlApp, ISAM, filter) = True Then
CreateExcelObject = True
'MsgBox "本电脑安装了WPS V9及以上版本"
Exit Function
End If
'创建wps对象失败说明没有安装wps,此时尝试创建excel对象
'如果创建excel对象失败，说明本地也没有安装excel
If GetExcelFromActiveX(xlApp, ISAM, filter) = True Then
CreateExcelObject = True
MsgBox "本电脑安装了office"
Exit Function
End If
CreateExcelObject = funcResult
ErrHandle:
Select Case Err.Number
Case 0
'DoNothing
Case 429
If xlApp Is Nothing Then
CreateExcelObject = funcResult
End If
'Debug.Print ("获取Excel或者WPS对象失败")
Case Else
MsgBox "错误代码：" & Err.Number & vbCrLf & "错误描述：" & Err.Description, vbCritical, "错误"
End Select
End Function
'==========================================================
'| 模 块 名 | GetExcelFromActiveX
'| 说 明 | 获取所有excel版本对象 如果有
' 版本 开发版本号
'===========================================================
Private Function GetExcelFromActiveX(ByRef xlApp As Object, ByRef ISAM As String, ByRef filter As String) As Boolean
On Error GoTo ErrHandle
Dim xlappVersion As Double
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False
xlappVersion = CDbl(xlApp.Version)
Select Case xlappVersion
Case Is "" Then Path = Path & ""
fName = Dir$(Path & fExp)
i = 0
Do While fName ""
ReDim Preserve FileName(i) As String
FileName(i) = fName
fName = Dir$
i = i + 1
Loop
If i 0 Then
ReDim Preserve FileName(i - 1) As String
GetFileList = True
Else
GetFileList = False
End If
End Function
Sub GetPath(ByVal FilePath As String, ByVal list As ListBox)
'------------------------------------------------------------------
'以竖式遍历先遍历某子目录及内部所有子目录，然后再返回与之同级的目录
'调用方法
'Dim path As String
'path = "C:\161\"
'GetPath path, List1
'------------------------------------------------------------------
FilePath = IIf(Right(FilePath, 1) = "\", FilePath, FilePath & "\") '获取文件路径 '获取当前目录内的文件名
Dim FileName As String
FileName = Dir(FilePath) '初次使用dir函数需指明路径
Do While FileName "" '使用一个循环，遍历当前目录内的文件，并逐一验证其属性
If Right(FileName, 3) = "jpg" Then
'List1.AddItem FilePath & "\" & FileName
list.AddItem FilePath & FileName
End If
FileName = Dir
Loop
FileName = LCase(Dir(FilePath, vbDirectory)) '缺少此句只会遍历一级目录
Dim ChildContent() As String
Dim Count As Integer
Do While FileName "" '获取下一级目录
If FileName "." And FileName ".." Then
If GetAttr(FilePath & FileName) And vbDirectory Then
Count = Count + 1
ReDim Preserve ChildContent(Count)
' ChildContent(Count) = FilePath & "\" & FileName '将下一级目录放入动态数组
ChildContent(Count) = FilePath & FileName '将下一级目录放入动态数组
End If
End If
FileName = Dir
DoEvents
Loop
Dim i As Integer
For i = 1 To Count
GetPath ChildContent(i), list '回调自身,获取下一级目录内文件路径
Next i
End Sub
在表格内批量插入图片源码
本帖以下内容被隐藏保护；需要你回复后，才能看到！ 游客，如果您要查看本帖隐藏内容请 回复 |
|
置顶卡
