|
創(chuàng)建“員工檔案”數(shù)據(jù)庫后，可以從中提取相關(guān)信息制作Excel員工檔案查詢表。例如，按照圖 16.161所示，設(shè)置表格并在相應(yīng)單元格輸入固定信息，其中灰色部分為Image控件，其PictureSizeMode屬性設(shè)置為1，使照片圖片可以自動適應(yīng)控件大小。在G2單元格輸入員工編號，可以快速查詢相關(guān)員工的檔案信息。 圖 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('職務(wù)') #033 .Range('f4') = rsADO('籍貫') #034 .Range('b5') = rsADO('學(xué)歷') #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行代碼聲明用戶自定義數(shù)據(jù)類型。 第28行到第37行代碼將數(shù)據(jù)庫記錄集中的數(shù)據(jù)填寫到工作表相應(yīng)的單元格中。 第38行到第40行代碼判斷記錄集中的“照片”字段是否為NULL值，如果為NULL，則隱藏Image1控件，并顯示暫無照片的信息。 第42行代碼讀取照片的二進制數(shù)組。 第43行到第45行代碼設(shè)置Image1控件的顯示狀態(tài)，使圖片適應(yīng)控件的大小。 第46行代碼使用自定義函數(shù)ByteToPicture將二進制數(shù)組轉(zhuǎn)換為Picture對象。 第57到第69行代碼是ByteToPicture自定義函數(shù)，該函數(shù)利用API將內(nèi)存中的二進制數(shù)組轉(zhuǎn)換為可以使Image控件接受的Picture對象。 ReadRecordPic過程先通過Recordset對象讀取數(shù)據(jù)庫中的信息，并將字段內(nèi)容輸出到工作表相應(yīng)單元格中，然后使用API編寫的自定義函數(shù)ByteToPicture讀取Recordset對象中包含圖片信息的二進制數(shù)據(jù)，轉(zhuǎn)換為Picture對象并顯示在工作表的Image1控件中。 在G2單元格輸入員工編號后，運行ReadRecordPic過程，結(jié)果如圖 16.162所示。 圖 16.162 員工檔案查詢表 由北京大學(xué)出版社出版、Excelhome精心打造的《Excel VBA 經(jīng)典代碼應(yīng)用大全》一書，內(nèi)容側(cè)重于Excel VBA 的經(jīng)典用法及其代碼講解，旨在幫助Excel VBA 初學(xué)者和具備一定VBA 應(yīng)用基礎(chǔ)希望進階學(xué)習(xí)的廣大讀者。全書精選了大量經(jīng)典實例，輔以深入淺出的代碼講解剖析，力求讓更多希望深入學(xué)習(xí)Excel VBA 的讀者能夠有更大的收獲。 |
|
|
