通过 MS Access 表单上的按钮在表中添加相应的 OLE 对象(图像) [英] Add corresponding OLE object (image) in table through button on form in MS Access
问题描述
我有一张学生表，其中包含以下字段:Voornaam、Achternaam 和 Foto.Voornaam 和 Achternaam 字段用学生的名字和姓氏填充.字段 Foto (Picture) 为空.因为我不想手动添加学生的每张图片我想用一些代码来做.
I have a table Students with the following fields: Voornaam, Achternaam and Foto. The fields Voornaam and Achternaam are filled in with the students firstname and lastname. The field Foto (Picture) is empty. Because I don't want to manually add every picture of the students I wanted to do it with some code.
我有一个用于放置记录的表单，我有一个按钮可以在空白字段中加载照片.我还有一个文本框，我可以在其中说明他必须在哪里查找照片.
I have a form where I put the records and I have a button to load the photos in the empty fields. I also have a textbox where I could say where he has to look for the photos.
这是我的代码:
子 cmdLoad_Click()
Sub cmdLoad_Click()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim query As String
Dim MyFolder As String
Dim MyPath As String
Dim MyFile As String
'On Error GoTo ErrorHandler
Set db = CurrentDb
query = "Select * FROM tblStudents"
Set rs = db.OpenRecordset(query, dbOpenDynaset)
MyFolder = Me!txtFolder
'Wanneer er geen items zijn. Sluiten
If rs.EOF Then Exit Sub
With rs
Do Until rs.EOF
MyPath = MyFolder & "\" & [Voornaam] & " " & [Achternaam] & ".jpg"
MyFile = Dir(MyPath, vbNormal)
rs.Edit
[Foto].Class = "Paint.Picture"
[Foto].OLETypeAllowed = acOLEEmbedded
[Foto].SourceDoc = MyPath
[Foto].Action = acOLECreateEmbed
rs.Update
rs.MoveNext
Loop
End With
rs.Close
db.Close
Set rs = Nothing
Set db = Nothing
Exit Sub
ErrorHandler: MsgBox "Test Error #: " & Err.Number & vbCrLf &
vbCrLf & Err.Description End Sub
我对表的结果进行迭代.在我编辑每条记录时，我想将图片添加到 foto 字段，但这就是问题所在.
I iterate on the results of the table. At every record I edit it and I want to add the picture to the foto field, but here's the problem.
当我点击按钮加载时，出现以下错误:
When I click the button to load in, I get the following error:
microsoft access 与 ole 通信时发生错误服务器或 Activex 控件.
a error occurred while microsoft access was communicating with the ole server or activex control .
当我调试时，它在这一行出错:
When I debug it's on this line where it goes wrong:
[照片].Action = acOLECreateEmbed
[Foto].Action = acOLECreateEmbed
我试图找到解决方案，但到目前为止我找不到.我希望问题有点清楚.或者有更好的解决方案吗?
I've tried to find a solution, but so far I couldn't find it. I hope the problem is a bit clear. Or is there a better solution?
推荐答案
我将我的用户照片、文档等存储为 BLOB.
I store my user photos, documents etc as BLOB.
避免 OLE 嵌入或链接的开销；
Avoids the overhead of OLE embed or link;
http://www.ammara.com/articles/imagesaccess.html
加载；
Private Sub cmdLoadImageClient_Click()
Dim strFile As String
Dim strname As String
strname = Form_subfrmClientDetailsAAClient.FirstName & Form_subfrmClientDetailsAAClient.Surname
strFile = fGetFile("Image", "*.gif; *.jpg; *.jpeg; *.png")
If Len(strFile) > 0 Then
If InsertBLOB("tblzBLOBClientPics", CStr(TempVars!frmClientOpenID), strname, "ClientPic", strFile) Then Call ShowImageClient
End If
End Sub
删除；
Private Sub cmdDeleteImageClient_Click()
Dim strname As String
Dim i As Integer
strname = Form_subfrmClientDetailsAAClient.FirstName & Form_subfrmClientDetailsAAClient.Surname
i = MsgBox("Do you want to Delete the Image for; " & strname & "?", vbOKCancel, "Beresford Financial.")
Select Case i
Case vbOK
dbLocal.Execute "DELETE FROM tblzBLOBClientPics WHERE ClientID = '" & CStr(TempVars!frmClientOpenID) & "' AND ClientName = '" & strname & "' AND BLOBDesc = 'ClientPic'"
Me.ProfilePicClient.Picture = ""
Case vbCancel
End Select
End Sub
查看；
Public Sub ShowImageClient()
Dim strTemp As String
Dim strname As String
On Error GoTo errHere
Me.ProfilePicClient.Picture = ""
strTemp = CurrentProject.Path & "\Temp.jpg"
strname = Nz(Form_subfrmClientDetailsAAClient.FirstName) & Nz(Form_subfrmClientDetailsAAClient.Surname)
If ExtractBLOB("tblzBLOBClientPics", CStr(TempVars!frmClientOpenID), strname, "ClientPic", strTemp) Then
If Len(Dir(strTemp)) > 0 Then
Me.ProfilePicClient.Picture = strTemp
Kill strTemp
End If
End If
Exit Sub
errHere:
MsgBox "Error " & Err & vbCrLf & Err.Description
End Sub
BLOB 函数；
Option Compare Database
Option Explicit
Function InsertBLOB(tblBLOB As String, ClientID As String, ClientName As String, strDesc As String, strFileName As String) As Boolean
'Inserts BLOB into table tblzBLOBDocuments
On Error GoTo CloseUp
Dim objStream As Object 'ADODB.Stream
Dim objCmd As Object 'ADODB.Command
Dim varFileBinary
'Empty any matching record
CurrentDb.Execute "DELETE FROM " & tblBLOB & " WHERE ClientID = '" & ClientID & "' AND ClientName = '" & ClientName & "' AND BLOBDesc = '" & strDesc & "'"
Set objStream = CreateObject("ADODB.Stream")
objStream.Type = 1 'adTypeBinary
objStream.Open
objStream.LoadFromFile strFileName
varFileBinary = objStream.Read
objStream.Close
Set objStream = Nothing
Set objCmd = CreateObject("ADODB.Command")
With objCmd
.CommandText = "PARAMETERS paramID Text(255), paramTable Text(255), paramDesc Text(255), paramExtn Text(5), paramFile LongBinary;" & _
"INSERT INTO " & tblBLOB & " (ClientID, ClientName, BLOBDesc, FileExtn, BLOB) " & _
"SELECT paramID, paramTable, paramDesc, paramExtn, paramFile"
.CommandType = 1 'adCmdText
.Parameters.Append .CreateParameter("paramID", 200, 1, 255, ClientID)
.Parameters.Append .CreateParameter("paramTable", 200, 1, 255, ClientName)
.Parameters.Append .CreateParameter("paramDesc", 200, 1, 255, strDesc)
.Parameters.Append .CreateParameter("paramExtn", 200, 1, 5, right(strFileName, Len(strFileName) - InStrRev(strFileName, ".")))
.Parameters.Append .CreateParameter("paramFile", 205, 1, 2147483647, varFileBinary)
Set .ActiveConnection = CurrentProject.Connection
.Execute , , 128
End With
InsertBLOB = True
CloseUp:
On Error Resume Next
Set objStream = Nothing
Set objCmd = Nothing
End Function
Function ExtractBLOB(tblBLOB As String, ClientID As String, ClientName As String, strDesc As String, ByRef strFileName As String) As Boolean
'Extracts specified BLOB to file from table tblzBLOBDocuments
Dim strSql As String
Dim rst As Object 'ADODB.Recordset
Dim objStream As Object 'ADODB.Stream
Set rst = CreateObject("ADODB.Recordset")
strSql = "SELECT FileExtn, BLOB FROM " & tblBLOB & " WHERE ClientID = '" & ClientID & "' AND ClientName = '" & ClientName & "' AND BLOBDesc = '" & strDesc & "'"
rst.Open strSql, CurrentProject.Connection, 1, 3
If rst.RecordCount = 0 Then
GoTo CloseUp
End If
Set objStream = CreateObject("ADODB.Stream")
With objStream
.Type = 1 'adTypeBinary
.Open
.Write rst.Fields("BLOB").Value
If Not IsNull(rst!FileExtn) Then
strFileName = Left(strFileName, InStrRev(strFileName, ".")) & rst!FileExtn
End If
.SaveToFile strFileName, 2 'adSaveCreateOverWrite
End With
ExtractBLOB = True
CloseUp:
On Error Resume Next
rst.Close
Set rst = Nothing
Set objStream = Nothing
End Function
文件选择器；
Function fGetFile(strType As String, strExt As String, Optional strPath As String)
With Application.FileDialog(3) ' 3=msoFileDialogFilePicker 4=msoFileDialogFolderPicker
' .Filters.Add "Excel Files", "*.xls, *.xlsx, *.xlsm", 1
.Filters.Add strType, strExt, 1
If strPath <> "" Then
.InitialFileName = strPath ' start in this folder
End If
.AllowMultiSelect = False
.Show
If .SelectedItems.Count > 0 Then
' MsgBox .SelectedItems(1)
fGetFile = .SelectedItems(1)
End If
End With
End Function
tblzBLOBClientPics;
tblzBLOBClientPics;
ClientID Short Text
ClientName Short Text
BLOBDesc Short Text
FileExtn Short Text
BLOB OLE Object
这篇关于通过 MS Access 表单上的按钮在表中添加相应的 OLE 对象(图像)的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
