社区 › VBA/VB/ActiveX/API 编程技术 › VB在表格中批量插入图片源码，支持office和WPS表格。

yswoyh 发表于 2022-5-4 11:19:49

VB在表格中批量插入图片源码，支持office和WPS表格。

VB在表格中批量插入图片，后期绑定，支持office 和WPS 表格，感谢mikewolf2k版主和fjfhgdwfn的指导，不敢独享，能用到的小伙伴尽情下载。
因为满足之前的工作，就没有再进行优化和修改了。


使用说明，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
''' <summary>=====================================================================================
'''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 表格具有优先级或者是注册表里面某项决定的
''' </summary>
''' <param name="xlApp"></param>
''' <param name="ISAM">索引顺序访问方法</param>
''' <param name="filter">文件后缀</param>
''' <returns></returns>===========================================================================
    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 <= 11#
            filter = ".xls"
            ISAM = "Excel 8.0"
            GetExcelFromActiveX = True
      Case Else
            filter = ".xlsx"
            ISAM = "Excel 12.0 Xml"
            GetExcelFromActiveX = True
    End Select
    'Debug.Print "获取Excel版本成功"
ErrHandle:
    Select Case Err.Number
      Case 0
            'DoNothing
      Case 429    'ActiveX 部件不能创建对象(电脑没有安装此对象)
            filter = ""
            ISAM = ""
            'Debug.Print "获取Excel版本失败"
      Case Else
            MsgBox "错误代码：" & Err.Number & vbCrLf & "错误描述：" & Err.Description, vbCritical, "错误"
            'Debug.Print "错误代码：" & Err.Number & vbCrLf & "错误描述：" & Err.Description
    End Select
End Function


'==========================================================
'| 模 块 名 | GetWPS_V8VerFromActiveX
'| 说明   | ET.Application对象直接获取当前WPS版本
'       版本            开发版本号
'==========================================================
Private Function GetWPS_V8VerFromActiveX(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("ET.Application")
    xlApp.Visible = False
   
    xlappVersion = CDbl(xlApp.Version)
    Select Case xlappVersion
      Case Is <= 11#
            filter = ".xls"
            ISAM = "Excel 8.0"
            GetWPS_V8VerFromActiveX = True
      Case Else
            filter = ".xlsx"
            ISAM = "Excel 12.0 Xml"
            GetWPS_V8VerFromActiveX = True
    End Select
    'Debug.Print "获取WPSV8及以下版本成功"
ErrHandle:
    Select Case Err.Number
      Case 0
            'DoNothing
      Case 429    'ActiveX 部件不能创建对象(电脑没有安装此对象)
            filter = ""
            ISAM = ""
            'Debug.Print "获取WPSV8及以下版本失败"
      Case Else
            MsgBox "错误代码：" & Err.Number & vbCrLf & "错误描述：" & Err.Description, vbCritical, "错误"
            'Debug.Print "错误代码：" & Err.Number & vbCrLf & "错误描述：" & Err.Description
    End Select
End Function

'==========================================================
'| 模 块 名 | GetWPS_V9VerAboveFromActiveX
'| 说明   | KET.Application对象直接获取当前WPS版本(版本号为9以上的)
'       版本            开发版本号
'==========================================================
Private Function GetWPS_V9VerAboveFromActiveX(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("KET.Application")
    'xlApp.Visible = True
    xlApp.Visible = False
    xlappVersion = CDbl(xlApp.Version)
    Select Case xlappVersion
      Case Is <= 11#
            filter = ".xls"
            ISAM = "Excel 8.0"
            GetWPS_V9VerAboveFromActiveX = True
      Case Else
            filter = ".xlsx"
            ISAM = "Excel 12.0 Xml"
            GetWPS_V9VerAboveFromActiveX = True
    End Select
   
    'Debug.Print "获取WPSV9及以上版本成功"
ErrHandle:
    Select Case Err.Number
      Case 0
            'DoNothing
      Case 429    'ActiveX 部件不能创建对象(电脑没有安装此对象)
            filter = ""
            ISAM = ""
            'Debug.Print "获取WPSV9及以上版本失败"
      Case Else
            MsgBox "错误代码：" & Err.Number & vbCrLf & "错误描述：" & Err.Description, vbCritical, "错误"
            'Debug.Print "错误代码：" & Err.Number & vbCrLf & "错误描述：" & Err.Description
    End Select
End Function

Function GetFileList(ByVal Path As String, ByRef FileName() As String, Optional fExp As String = "*.*") As Boolean
    '===================================== 下面是调用
    'Dim FileName() As String, i As Long
    'GetFileList "c:", FileName, "*.mp3" '可以设置文件类型
    'For i = 0 To UBound(FileName)
    '    Print FileName(i)
    'Next i
    '======================================================
    Dim fName As String, i As Long
    If Right$(Path, 1) <> "" 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

664571221 发表于 2022-5-5 08:46:31

你好大神，可以来一个动图演示吗，不知道是啥意思

landsat99 发表于 2022-5-5 09:33:28

代码规整，文档完备

讲究

yshf 发表于 2022-5-5 09:46:28

谢谢分享！！！

czb203 发表于 2022-5-5 22:16:40

代码规整，文档完备

讲究

查看完整版本: VB在表格中批量插入图片源码，支持office和WPS表格。