Question

我有一张桌子学生有以下领域：Voornaam，Achternaam和Foto。 Voornaam和Achternaam字段填写了学生的名字和姓氏。现场Foto（图片）是空的。因为我不想用一些代码手动添加我想要的学生的每张照片。

我有一个表格，我放置了记录，我有一个按钮，可以在空白的字段中加载照片。我还有一个文本框，我可以说他必须在哪里寻找照片。

这是我的代码：

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＆＃34;测试错误＃：＆＃34; ＆安培; Err.Number＆amp; vbCrLf＆amp; vbCrLf＆amp; Err.Description End Sub

我迭代表的结果。在每个记录我编辑它，我想将图片添加到foto字段，但问题就在这里。

当我点击按钮加载时，我收到以下错误：

微软访问与ole通信时发生错误服务器或activex控件。

当我在这行出错时调试它：

[Foto] .Action = acOLECreateEmbed

我试图找到解决方案，但到目前为止，我无法找到它。我希望问题有点清楚。或者有更好的解决方案吗？

Answer 1

我将用户照片，文档等存储为BLOB。

避免OLE嵌入或链接的开销;

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

Filepicker;

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;

ClientID   Short Text
ClientName Short Text
BLOBDesc   Short Text
FileExtn   Short Text
BLOB       OLE Object

通过MS Access中的窗体上的按钮在表中添加相应的OLE对象（图像）

1 个答案: