存取图像.bas

把图片缩小压缩成jpg格式并保存到sql数据库

Attribute VB_Name = "Module1"
'使用AppendChunk方法将二进制文件数据存入数据库实例
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Const BLOCKSIZE = 4096
Dim Chunk() As Byte
Const ChunkSize As Long = 2384
Dim Chunks As Long
Public 添加修改 As Boolean

Private Sub SaveToDB(ByRef Fld As ADODB.Field, DiskFile As String)
    '定义数据块数组
    
    Dim mstream As ADODB.Stream
    '判断文件是否存在
    If Dir(DiskFile) <> "" Then
        SourceFile = FreeFile
        '读入二进制文件
        Set mstream = New ADODB.Stream
        mstream.Open
        mstream.LoadFromFile (DiskFile)
        '存入数据库
        Fld.Value = mstream.Read
         mstream.Close
    Else
        MsgBox "文件不存在，请重新指定文件！", vbExclamation, "注意"
    End If
End Sub
Private Function GetFileName() As String
    
    CommonDialog1.CancelError = True
On Error GoTo CancelErr
    CommonDialog1.Filter = "所有文件(*.*)|*.*"
    CommonDialog1.ShowOpen
    GetFileName = CommonDialog1.Filename
    Exit Function
CancelErr:
    GetFileName = ""
    
End Function
Private Sub cmdSave2DB_Click()
    Call Save2DB
End Sub
Public Sub Save2DB(添加 As Boolean)
    '建立一个ADO数据连接
    Dim DataConn As New ADODB.Connection
    Dim DataRec As New ADODB.Recordset
    Dim strSQL As String
    Dim Picbyte() As Byte
    Dim FileLen As Long
    Dim Fragment As Long
'若数据库连接出错，则转向ConnectionERR
'On Error GoTo ConnectionERR
    
    '建立一个连接字串
    '这个连接串可能根据数据库配置的不同而不同
   ' DataConn.ConnectionString = "Provider=SQLOLEDB.1;Integrated Security=SSPI;"
   ' DataConn.ConnectionString = DataConn.ConnectionString & "Persist Security Info=False;"
   ' DataConn.ConnectionString = DataConn.ConnectionString & "Initial Catalog=tempdb;"
   ' DataConn.ConnectionString = DataConn.ConnectionString & "Data Source=localhost"
    '建立数据库连接
    
      Erase Picbyte()
      Form1.SaveJPEG Form1.Picture1, Picbyte(), CByte(90)

    
     DataConn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\db_test.mdb;Persist Security Info=False"

    DataConn.Open
    
   
    
    
'若RecordSet建立出错，则转向RecordsetERR
'On Error GoTo RecordSetERR
    
       'If DataRec.EOF Then DataRec.AddNew
    If 添加 Then
       strSQL = "SELECT * FROM 人员表"
        DataRec.Open strSQL, DataConn, adOpenDynamic, adLockOptimistic
       DataRec.AddNew
    Else
        strSQL = "SELECT * FROM 人员表" & " where 姓名='" + Form1.ListView1.SelectedItem.Text + "'"
        DataRec.Open strSQL, DataConn, adOpenDynamic, adLockOptimistic
        If DataRec.EOF Then DataRec.AddNew

    End If
    
'On Error GoTo OtherERR
    
    'DataRec.Fields("姓名").Value = Form1.Text1(0).Text
    
     For i = 0 To Form1.Text1.UBound
         DataRec.Fields(i) = Form1.Text1(i).Text
     Next i
    
    
    
    
    
  '  Call SaveToDB(DataRec.Fields("照片"), Form1.Text1(0).Text)
      
  FileLen = UBound(Picbyte()) + 1
  Chunks = FileLen \ ChunkSize
 Fragment = FileLen Mod ChunkSize
 ReDim Chunk(Fragment - 1)
 CopyMemory Chunk(0), Picbyte(0), Fragment
 DataRec!照片.AppendChunk Chunk()
ReDim Chunk(ChunkSize - 1)
For i = 1 To Chunks
  CopyMemory Chunk(0), Picbyte(Fragment + (i - 1) * ChunkSize), ChunkSize&
   DataRec!照片.AppendChunk Chunk()
Next i

    
    
    
    
    
    
    
    DataRec.Update
      
    DataRec.Close
    DataConn.Close
    Form1.刷新列表2
    
    Exit Sub

End Sub

Private Sub Command1_Click()
    Text2.Text = GetFileName
End Sub


 
Public Sub Del2DB() '删除记录
    '建立一个ADO数据连接
    Dim DataConn As New ADODB.Connection
    Dim DataRec As New ADODB.Recordset
    Dim strSQL As String
    Dim Picbyte() As Byte
    Dim FileLen As Long
    Dim Fragment As Long
    
    
     DataConn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\db_test.mdb;Persist Security Info=False"

    DataConn.Open
    
   
        strSQL = "DELETE * FROM 人员表" & " where 姓名='" + Form1.ListView1.SelectedItem.Text + "'"
        DataRec.Open strSQL, DataConn, adOpenDynamic, adLockOptimistic
      
   ' DataRec.Close
    DataConn.Close
    Form1.刷新列表2
    
    Exit Sub

End Sub