如何把图片存到ACCESS数据库中~~~~~~~~急用呀！

Question

'将图片写到数据库
Public Sub SubPicToDb(strDB As String, strField As String, sqlCon As String, strFileName As String)
Dim adoStream As New ADODB.Stream
Dim strCon As String
On Error GoTo ErrToDB
Set pRst = New ADODB.Recordset
strCon = "select " & strField & " from " & strDB & " where " & sqlCon
pRst.Open strCon, pConn, adOpenKeyset, adLockOptimisticadoStream.Type = adTypeBinary
adoStream.Open
adoStream.LoadFromFile strFileName
pRst(strField).AppendChunk adoStream.Read
pRst.UpdatepRst.Close
adoStream.Close
Set adoStream = Nothing
Set pRst = Nothing
Exit Sub
ErrToDB:
MsgBox Err.Description, vbOKOnly + vbExclamation, "提示"
End Sub'从数据库中提取二进制数据
Public Sub SubDbToPic(strDB As String, strField As String, sqlCon As String, objPic As Object)
Dim adoStream As New ADODB.StreamDim strCon As String
Dim strFileName As String
Dim TempFileName As String
On Error GoTo ErrRTF
Set pRst = New ADODB.Recordset
TempFileName = App.Path & "\TempFile.tmp"
strCon = "select " & strField & " from " & strDB & " where " & sqlCon
adoStream.Type = adTypeBinary
adoStream.Open
pRst.Open strCon, pConn, adOpenDynamic, adLockPessimistic
'If pRst.RecordCount > 0 Then
adoStream.Write pRst(strField).GetChunk(pRst(strField).ActualSize)
adoStream.SaveToFile TempFileName, IIf(Len(Trim(Dir(TempFileName, vbNormal + vbHidden))) > 0, adSaveCreateOverWrite, adSaveCreateNotExist)
objPic.Picture = LoadPicture(TempFileName)Kill TempFileName
'End If
pRst.Close
adoStream.Close
Set adoStream = Nothing
Set pRst = Nothing
Exit Sub
ErrRTF:
     If pRst.State = adStateOpen Then pRst.Close
     If adoStream.State = adStateOpen Then adoStream.Close
     Set pRst = Nothing
     Set adoStream = Nothing
End Sub

Answer 1

试一试这个过程：
Public Sub Input_file(ByVal RS As Recordset, ByVal fieldname As String, ByVal Yourfilename As String)
'注：Yourfilename ，你要要存入数据库的文件名
    Dim f As Integer
    Dim b() As Byte
    Dim conSize As Long
    Dim lngOffset As Long
    Dim lngLogoSize As Long
    Dim varLogo As Variant
    Dim varChunk As Variant
    Dim l As Long
    If Dir(Yourfilename) = "" Or Yourfilename = "" Then
          RS.Fields(fieldname) = Null
       Exit Sub
    Else
      f = FreeFile
      Open Yourfilename For Binary As #f
      lngLogoSize = LOF(f)        ' long of file
      lngOffset = 0              ' Reset offset.
      conSize = 1000000     '1MB
      If lngLogoSize < conSize Then
          b = InputB(lngLogoSize, #f)
          RS.Fields(fieldname).AppendChunk b
      Else
          l = lngLogoSize
          Do While l > conSize
             b = InputB(conSize, #f)
             RS.Fields(fieldname).AppendChunk b
             l = l - conSize
          Loop
          b = InputB(l, #f)
          RS.Fields(fieldname).AppendChunk b
      End If
      Close #f
    End If
End Sub

Answer 2

在模块：
Sub SavePictureToAdodc(rs As ADODB.Recordset, ByVal FileName As String)
    Dim Length As Long, f As Integer
    Length = FileLen(FileName)
    
    ReDim bArray(Length + 12) As Byte, bArray2(Length) As Byte
    bArray(0) = &H6C: bArray(1) = &H74
    RtlMoveMemory bArray(4), Length, 4
    
    f = FreeFile
    Open FileName For Binary As #f
    Get #f, , bArray2
    Close #1
    
    RtlMoveMemory bArray(8), bArray2(0), Length
    
    rs("相片").AppendChunk bArray
End Sub
调用：
Private Sub Label2_Click()
On Error Resume NextWith CommonDialog1
     .CancelError = True
     .ShowOpen
     
If Err.Number <> cdlCancel Then   Image2.Picture = LoadPicture(.FileName)
SavePictureToAdodc Adodc1.Recordset, .FileNameEnd If
End WithEnd Sub