|
创建“员工档案”数据库后，可以从中提取相关信息制作Excel员工档案查询表。例如，按照图 16.161所示，设置表格并在相应单元格输入固定信息，其中灰色部分为Image控件，其PictureSizeMode属性设置为1，使照片图片可以自动适应控件大小。在G2单元格输入员工编号，可以快速查询相关员工的档案信息。 图 16.161 员工档案查询表模板 示例代码如下： #001 Type mudtGUID #002 lngData As Long #003 intData1 As Integer #004 intData2 As Integer #005 abytData(7) As Byte #006 End Type #007 Private Declare Function CreateStreamOnHGlobal Lib 'ole32.dll' (ByRef hGlobal As Any, ByVal fDeleteOnResume As Long, ByRef ppstr As Any) As Long #008 Private Declare Function OleLoadPicture Lib 'olepro32.dll' (ByVal lpStream As IUnknown, ByVal lSize As Long, ByVal fRunmode As Long, ByRef riid As mudtGUID, ByRef lplpObj As Any) As Long #009 Private Declare Function CLSIDFromString Lib 'ole32.dll' (ByVal lpsz As Long, ByRef pclsid As mudtGUID) As Long #010 Private Const SIPICTURE As String = '{7BF80980-BF32-101A-8BBB-00AA00300CAB}' #011 Sub ReadRecordPic() #012 Dim abytPic() As Byte #013 Dim strSQL As String #014 Dim cnADO As New ADODB.Connection #015 Dim rsADO As New ADODB.Recordset #016 Dim strPath As String #017 Dim strTable As String #018 strPath = ThisWorkbook.Path & '员工管理.accdb' #019 strTable = '员工档案' #020 On Error GoTo ErrMsg #021 With Sheets('员工档案查询') #022 cnADO.Open 'Provider=Microsoft.ACE.OLEDB.12.0;Data Source=' & strPath #023 strSQL = 'SELECT * FROM ' & strTable & ' WHERE 员工编号=' & Val(.Range('g2')) #024 rsADO.Open strSQL, cnADO, 1, 3 #025 If rsADO.EOF Then #026 MsgBox .Range('G2') & ' 员工编号不存在，请重新输入', , '员工编号错误' #027 Else #028 .Range('b3') = rsADO('姓名') #029 .Range('d3') = rsADO('出生日期') #030 .Range('f3') = rsADO('民族') #031 .Range('b4') = rsADO('性别') #032 .Range('d4') = rsADO('职务') #033 .Range('f4') = rsADO('籍贯') #034 .Range('b5') = rsADO('学历') #035 .Range('d5') = rsADO('部门') #036 .Range('f5') = rsADO('电话') #037 .Range('b6') = rsADO('简历') #038 If IsNull(rsADO('照片')) Then #039 .Image1.Visible = False #040 .Range('g3') = '暂无照片' #041 Else #042 abytPic = rsADO('照片') #043 .Image1.Visible = True #044 .Image1.AutoSize = False #045 .Image1.PictureSizeMode = fmPictureSizeModeStretch #046 Set .Image1.Picture = ByteToPicture(abytPic) #047 .Range('g3') = '' #048 End If #049 End If #050 End With #051 Set rsADO = Nothing #052 Set cnADO = Nothing #053 Exit Sub #054 ErrMsg: #055 MsgBox Err.Description, , '错误报告' #056 End Sub #057 Private Function ByteToPicture(ByRef abytData() As Byte) As IPicture #058 On Error GoTo errorhandler #059 Dim objStrm As IUnknown #060 Dim avntGUID As mudtGUID #061 If Not CreateStreamOnHGlobal(abytData(LBound(abytData)), False, objStrm) Then #062 CLSIDFromString StrPtr(SIPICTURE), avntGUID #063 OleLoadPicture objStrm, UBound(abytData) - LBound(abytData) + 1, False, avntGUID, ByteToPicture #064 End If #065 Set objStrm = Nothing #066 Exit Function #067 errorhandler: #068 Debug.Print 'Could not convert to IPicture!' #069 End Function 代码解析： 第1行到第6行代码声明用户自定义数据类型。 第28行到第37行代码将数据库记录集中的数据填写到工作表相应的单元格中。 第38行到第40行代码判断记录集中的“照片”字段是否为NULL值，如果为NULL，则隐藏Image1控件，并显示暂无照片的信息。 第42行代码读取照片的二进制数组。 第43行到第45行代码设置Image1控件的显示状态，使图片适应控件的大小。 第46行代码使用自定义函数ByteToPicture将二进制数组转换为Picture对象。 第57到第69行代码是ByteToPicture自定义函数，该函数利用API将内存中的二进制数组转换为可以使Image控件接受的Picture对象。 ReadRecordPic过程先通过Recordset对象读取数据库中的信息，并将字段内容输出到工作表相应单元格中，然后使用API编写的自定义函数ByteToPicture读取Recordset对象中包含图片信息的二进制数据，转换为Picture对象并显示在工作表的Image1控件中。 在G2单元格输入员工编号后，运行ReadRecordPic过程，结果如图 16.162所示。 图 16.162 员工档案查询表 由北京大学出版社出版、Excelhome精心打造的《Excel VBA 经典代码应用大全》一书，内容侧重于Excel VBA 的经典用法及其代码讲解，旨在帮助Excel VBA 初学者和具备一定VBA 应用基础希望进阶学习的广大读者。全书精选了大量经典实例，辅以深入浅出的代码讲解剖析，力求让更多希望深入学习Excel VBA 的读者能够有更大的收获。 |
|
|
来自： hercules028 > 《excel》
