form_blob.frm

vb编程+从基础到实践光盘代码

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form Frm_Blob 
   Caption         =   "Form1"
   ClientHeight    =   5025
   ClientLeft      =   3960
   ClientTop       =   2940
   ClientWidth     =   8085
   LinkTopic       =   "Form1"
   ScaleHeight     =   5025
   ScaleWidth      =   8085
   Begin MSComDlg.CommonDialog CommonDialog1 
      Left            =   600
      Top             =   4320
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.CommandButton Command4 
      Caption         =   "下一副"
      Height          =   375
      Left            =   6360
      TabIndex        =   5
      Top             =   3840
      Width           =   1335
   End
   Begin VB.CommandButton Command3 
      Caption         =   "上一副"
      Height          =   375
      Left            =   4440
      TabIndex        =   4
      Top             =   3840
      Width           =   1335
   End
   Begin VB.CommandButton Command2 
      Caption         =   "保存"
      Height          =   375
      Left            =   2040
      TabIndex        =   3
      Top             =   3840
      Width           =   1335
   End
   Begin VB.CommandButton Command1 
      Caption         =   "浏览"
      Height          =   375
      Left            =   240
      TabIndex        =   2
      Top             =   3840
      Width           =   1335
   End
   Begin VB.PictureBox Picture2 
      Height          =   3495
      Left            =   4440
      ScaleHeight     =   3435
      ScaleWidth      =   3435
      TabIndex        =   1
      Top             =   120
      Width           =   3495
   End
   Begin VB.PictureBox Picture1 
      Height          =   3495
      Left            =   120
      ScaleHeight     =   3435
      ScaleWidth      =   3435
      TabIndex        =   0
      Top             =   120
      Width           =   3495
   End
End
Attribute VB_Name = "Frm_Blob"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim FilePath As String
'使用AppendChunk方法将二进制文件数据存入数据库实例
Dim myConn As Connection
Dim myRec As Recordset
Dim tempPath As String
Const BLOCKSIZE = 4096
Private Function GetFileName() As String
    
    CommonDialog1.CancelError = True
On Error GoTo CancelErr
    CommonDialog1.Filter = "图像文件(*.bmp)|*.bmp"
    CommonDialog1.ShowOpen
    GetFileName = CommonDialog1.FileName
    Exit Function
CancelErr:
    GetFileName = ""
End Function

Private Sub Command1_Click()
    FilePath = GetFileName  '获得图像文件
    Picture1.Picture = LoadPicture(FilePath)
    Command2.Enabled = True
End Sub

Private Sub SaveToDB(ByRef Fld As ADODB.Field, DiskFile As String)
    '定义数据块数组
    Dim byteData() As Byte
    '定义数据块个数
    Dim NumBlocks As Long
    Dim FileLength As Long
    '定义剩余字节长度
    Dim LeftOver As Long
    Dim SourceFile As Long
    Dim i As Long
    '判断文件是否存在
    If Dir(DiskFile) <> "" Then
        SourceFile = FreeFile
        '打开二进制文件
        Open DiskFile For Binary Access Read As SourceFile
        FileLength = LOF(SourceFile)
        '判断文件是否空
        If FileLength = 0 Then
            Close SourceFile
            MsgBox DiskFile & "文件无内容，请重新指定文件！", vbExclamation, "注意"
        Else
            '得到数据块的个数
            NumBlocks = FileLength \ BLOCKSIZE
            '得到剩余字节数
            LeftOver = FileLength Mod BLOCKSIZE
            Fld.Value = Null
            ReDim byteData(BLOCKSIZE)
            For i = 1 To NumBlocks
                Get SourceFile, , byteData()
                '用Appendchunk方法将byteData()数据写入FLD
                Fld.AppendChunk byteData()
                DoEvents
            Next i
            '将剩余数据写入FLD
            ReDim byteData(LeftOver)
            Get SourceFile, , byteData()
            Fld.AppendChunk byteData()
            Close SourceFile
        End If
    Else
        MsgBox "文件不存在，请重新指定文件！", vbExclamation, "注意"
    End If
End Sub

Private Sub Command2_Click()
    Command2.Enabled = False
    Call Save2DB
End Sub

Private Sub Command3_Click()
myRec.MovePrevious
If Not myRec.BOF Then
    Call Save2File
    Picture2.Picture = LoadPicture(tempPath)
Else
    myRec.MoveNext
End If
End Sub

Private Sub Command4_Click()
myRec.MoveNext
If Not myRec.EOF Then
    Call Save2File
    Picture2.Picture = LoadPicture(tempPath)
Else
    myRec.MovePrevious
End If
End Sub

Private Sub Form_Load()
Dim ConnStr As String
Dim mySQL As String
Dim i As Integer
    
    tempPath = App.Path & "\temp.tmp"
    
    Set myConn = New ADODB.Connection
    
    ConnStr = "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;"
    ConnStr = ConnStr + "Data Source=" & App.Path & "\blob.mdb"
    
    
'若数据库连接出错，则转向ConnectionERR
On Error GoTo ConnectionERR
    myConn.ConnectionString = ConnStr
    
    myConn.Open  '打开Connection连接
    
'若RecordSet建立出错，则转向RecordsetERR
On Error GoTo RecordSetERR
    
    '创建RecordSet对象
    Set myRec = New ADODB.Recordset
    
    mySQL = "select * from pic"
    
    myRec.Open mySQL, myConn, 1, 3
    
    If Not myRec.BOF Then
        myRec.MoveFirst
    End If
    
    Call Save2File
    
    Picture2.Picture = LoadPicture(tempPath)
    
    Exit Sub
    
ConnectionERR:
    '错误处理程序
    MsgBox "数据库连接错误，" & Err.Description, vbCritical, "出错"
    Exit Sub
    
RecordSetERR:
    MsgBox "RecordSet生成错误，" & Err.Description, vbCritical, "出错"
    myRec.Close
    Exit Sub
    
    
End Sub
Private Sub Save2DB()

    
   myRec.AddNew
    
On Error GoTo OtherERR
    
    'myRec.Fields("PicContent").Value = Text1.Text
    Call SaveToDB(myRec.Fields("PicContent"), FilePath)
    myRec.Update
    Exit Sub


    
OtherERR:
    MsgBox "其他错误，" & Err.Description, vbCritical, "出错"
    
    myRec.Close
    myConn.Close
End Sub


Private Sub SaveToFile(ByRef Fld As ADODB.Field, DiskFile As String)
    '定义数据块数组
    Dim byteData() As Byte
    '定义数据块个数
    Dim NumBlocks As Long
    Dim FieldLength As Long
    '定义剩余字节长度
    Dim LeftOver As Long
    Dim DesFile As Long
    Dim i As Long
    '取得字段中数据实际长度
    FieldLength = Fld.ActualSize
    DesFile = FreeFile
    '打开二进制文件
    Open DiskFile For Binary Access Write As DesFile
    
    '得到数据块的个数
    NumBlocks = FieldLength \ BLOCKSIZE
    '得到剩余字节数
    LeftOver = FieldLength Mod BLOCKSIZE
    ReDim byteData(BLOCKSIZE)
    For i = 1 To NumBlocks
        '用GetChunck方法将FLD中二进制数据读出
        byteData() = Fld.GetChunk(BLOCKSIZE)
        Put DesFile, , byteData()
        DoEvents
    Next i
    '将剩余数据写入FLD
    ReDim byteData(LeftOver)
    byteData() = Fld.GetChunk(LeftOver)
    Put DesFile, , byteData()
    Close DesFile
    
End Sub

Private Sub Save2File()

    If myRec.EOF Then Exit Sub
    
On Error GoTo OtherERR
    
    Call SaveToFile(myRec.Fields("PicContent"), tempPath)
    Exit Sub

    
OtherERR:
    MsgBox "其他错误，" & Err.Description, vbCritical, "出错"
    
    myRec.Close
    myConn.Close
End Sub