我怎樣用vb存取 圖片到sql中?

Question

AppendChunk 和 GetChunk 方法范例
该范例使用 AppendChunk 和 GetChunk 方法用其他记录中的数据填写图像字段。Public Sub AppendChunkX()   Dim cnn1 As ADODB.Connection
   Dim rstPubInfo As ADODB.Recordset
   Dim strCnn As String
   Dim strPubID As String
   Dim strPRInfo As String
   Dim lngOffset As Long
   Dim lngLogoSize As Long
   Dim varLogo As Variant
   Dim varChunk As Variant
   
   Const conChunkSize = 100   ' 打开连接
   Set cnn1 = New ADODB.Connection
      strCnn = "Provider=sqloledb;" & _
      "Data Source=srv;Initial Catalog=pubs;User Id=sa;Password=; "
   cnn1.Open strCnn
   
   ' 打开 pub_info 表。
   Set rstPubInfo = New ADODB.Recordset
   rstPubInfo.CursorType = adOpenKeyset
   rstPubInfo.LockType = adLockOptimistic
   rstPubInfo.Open "pub_info", cnn1, , , adCmdTable
   
   ' 提示复制徽标。
   strMsg = "Available logos are : " & vbCr & vbCr
   Do While Not rstPubInfo.EOF
      strMsg = strMsg & rstPubInfo!pub_id & vbCr & _
         Left(rstPubInfo!pr_info, InStr(rstPubInfo!pr_info, ",") - 1) & _
         vbCr & vbCr
      rstPubInfo.MoveNext
   Loop
   strMsg = strMsg & "Enter the ID of a logo to copy:"
   strPubID = InputBox(strMsg)
   
   ' 将徽标复制到大块中的变量。
   rstPubInfo.Filter = "pub_id = '" & strPubID & "'"
   lngLogoSize = rstPubInfo!logo.ActualSize
   Do While lngOffset < lngLogoSize
      varChunk = rstPubInfo!logo.GetChunk(conChunkSize)
      varLogo = varLogo & varChunk
      lngOffset = lngOffset + conChunkSize
   Loop
   
   ' 从用户得到数据。
   strPubID = Trim(InputBox("Enter a new pub ID:"))
   strPRInfo = Trim(InputBox("Enter descriptive text:"))
   
   ' 添加新记录，将徽标复制到大块中。
   rstPubInfo.AddNew
   rstPubInfo!pub_id = strPubID
   rstPubInfo!pr_info = strPRInfo   lngOffset = 0 ' 重置位移。
   Do While lngOffset < lngLogoSize
      varChunk = LeftB(RightB(varLogo, lngLogoSize - lngOffset), _
         conChunkSize)
      rstPubInfo!logo.AppendChunk varChunk
      lngOffset = lngOffset + conChunkSize
   Loop
   rstPubInfo.Update
   
    ' 显示新添加的数据。
   MsgBox "New record: " & rstPubInfo!pub_id & vbCr & _
      "Description: " & rstPubInfo!pr_info & vbCr & _
      "Logo size: " & rstPubInfo!logo.ActualSize   ' 删除新记录，因为这只是演示。
   rstPubInfo.Requery
   cnn1.Execute "DELETE FROM pub_info " & _
      "WHERE pub_id = '" & strPubID & "'"   rstPubInfo.Close
   cnn1.Close   End Sub

Answer 1

'主要用AppendChunk  和  GetChunk  ,吴蚊子的
'存文件到数据库
Const BLOCKSIZE = 4096 '每次读写块的大小Public rsBinary As New ADODB.Recordset
Public Function AddFile(ByVal FileID As Long)
    'Return boolean to decide whether refresh files list
    Dim strBin As String * 3000
    Dim btyGet() As Byte
    Dim lngBlockIndex As Long
    Dim lngBlocks As Long
    Dim lngLastBlock As Long
    Dim lngPosition As Long
    Dim lngFileLenth As Long
    Dim lngIndex As Long
    With frmBinary.CommonDialog1
        '.InitDir = App.Path
        .Filter = "All image files&brvbar;*.bmp;*.ico;*.jpg;*.gif&brvbar;Bitmap files&brvbar;*.bmp&brvbar;Icon files&brvbar;*.ico&brvbar;All files&brvbar;*.*"
        .filename = ""
        On Error GoTo ErrorHandle
        .ShowOpen
        On Error GoTo 0
        If .filename <> "" Then
            Open .filename For Binary As #1
            lngFileLenth = LOF(1)
            
            lngPosition = 0
            
            'Get block count for loop
            lngBlocks = lngFileLenth / BLOCKSIZE
            
            'Get lngth of last block for the last read
            lngLastBlock = lngFileLenth Mod BLOCKSIZE
            TypeCode = Right(.filename, 3)
            rsBinary.AddNew
            rsBinary.Fields("typecode") = TypeCode
            
            For lngBlockIndex = 1 To lngBlocks
                ReDim btyGet(BLOCKSIZE)
                Get #1, , btyGet()
                rsBinary.Fields("content").AppendChunk btyGet()
                lngPosition = lngPosition + BLOCKSIZE
            Next            If lngLastBlock > 0 Then
                ReDim btyGet(lngLastBlock)
                Get #1, , btyGet()
                rsBinary.Fields("content").AppendChunk btyGet()
            End If
            rsBinary.Fields("id") = FileID
            rsBinary.Update
            rsBinary.UpdateBatch
            Close #1
            
            AddFile = True
            MsgBox "Save finished", vbInformation
        Else
            AddFile = False
        End If
    End With
    Exit Function
ErrorHandle:
    AddFile = False
End Function'从数据库取文件出来
Public Sub SaveFile(ByVal FileID As Long)
    Dim lngBlockCount As Long
    Dim lngLastBlock As Long
    Dim lngI As Long
    Dim btyBlock() As Byte
    Dim lngResult As Long
    If rsBinary.EOF And rsBinary.BOF Then Exit Sub
    rsBinary.Requery
    rsBinary.MoveFirst
    rsBinary.Find " id=" & FileID
    
    If Not rsBinary.EOF Then
        With frmBinary.CommonDialog1
            .filename = "TempSave" & "." & rsBinary.Fields("typecode")
            '.InitDir = App.Path
            
            'If user cancel save the goto handle
            On Error GoTo ErrorHandle
            .ShowSave
            If .filename <> "" Then
                lngBlockCount = rsBinary.Fields("content").ActualSize \ BLOCKSIZE
                lngLastBlock = rsBinary.Fields("content").ActualSize Mod BLOCKSIZE
                
                If Dir(.filename) <> "" Then
                    If MsgBox("File " & .filename & " is exist,overwrite?", vbYesNo + vbQuestion) = vbYes Then
                        Kill .filename
                    Else
                        Exit Sub
                    End If
                Else
                End If
                    
                Open .filename For Binary As #1
                
                ReDim btyBinary(BLOCKSIZE)
                
                For lngI = 1 To lngBlockCount
                    btyBlock() = rsBinary.Fields("content").GetChunk(BLOCKSIZE)
                    Put #1, , btyBlock
                Next
                
                If lngLastBlock <> 0 Then
                    ReDim btyBlock(lngLastBlock)
                    btyBlock() = rsBinary.Fields("content").GetChunk(lngLastBlock)
                    Put #1, , btyBlock
                End If
                
                Close #1
                MsgBox .filename & " is saved", vbInformation
            Else
            End If
        End With
    End If
    
    Exit Sub
ErrorHandle:
    
End Sub