Add corresponding OLE object (image) in table through button on form in MS Access

问题

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.

This is my code:

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

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:

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:

[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?

回答1:

I store my user photos, documents etc as BLOB.

Avoids the overhead of OLE embed or link;

http://www.ammara.com/articles/imagesaccess.html

To load;

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

To delete;

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

To view;

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 Functions;

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

来源：https://stackoverflow.com/questions/27930240/add-corresponding-ole-object-image-in-table-through-button-on-form-in-ms-acces

标签

ms-access

ms-access-2013