RDO之Blob资料的存取

Dim WithEvents cn   As rdoConnection
Dim en As rdoEnvironment
Private WithEvents rs As rdoResultset
Private qry As rdoQuery

'将dopic2.jpg存入blob栏位之中
Private Sub Command1_Click()
rs.Edit
If AppendBlobFromFile(rs.rdoColumns("blob"), "e:\baby\dopic2.jpg") Then
   rs.rdoColumns(1) = "o"
   rs.rdoColumns(2) = "lll"
   rs.Update
Else
   rs.CancelUpdate
End If
End Sub

'由Blob栏位中取出图片，如果成功则Show在Picture1中
Private Sub Command2_Click()
If GetBlobToFile(rs.rdoColumns("blob"), "e:\ttt.jpg") Then
   Set Picture1.Picture = LoadPicture("e:\ttt.jpg")
End If
End Sub

Private Sub Form_Load()
Dim connstr As String
Dim ans As Integer, errstr As String

Set en = rdoEnvironments(0)
Set cn = New rdoConnection
cn.CursorDriver = rdUseOdbc
connstr = "UID=cww;PWD=jjh5612;Database=cwwpf@eis;" _
        + "Driver={OpenLink Generic 32 Bit Driver};" _
        + "Host=192.168.0.61;" _
        + ";FetchBufferSize=30" _
        + ";NoLoginBox=Yes" _
        + ";Options=" _
        + ";Protocol=TCP/IP" _
        + ";ReadOnly=No" _
        + ";ServerOptions=" _
        + ";ServerType=Informix 7.2"
cn.Connect = connstr

On Error GoTo ConnectErr
cn.EstablishConnection rdDriverNoPrompt, False
Dim sql As String
sql = "select * from testtab"

Set qry = cn.CreateQuery("MyQuery", sql)
On Error GoTo QryErr
Set rs = qry.OpenResultset(rdOpenKeyset, rdConcurValues)
Exit Sub
ConnectErr:
   errstr = GetrdoErrorDescription
   ans = MsgBox(errstr, _
             vbRetryCancel + vbCritical, "连线错误")
   If ans = vbRetry Then
      Err.Clear
      rdoErrors.Clear
      Resume
   Else
      Resume ExitErr
   End If
   Exit Sub
QryErr:
   errstr = GetrdoErrorDescription
   ans = MsgBox(errstr, _
             vbRetryCancel + vbCritical, "查询错误")
   If ans = vbRetry Then
      Err.Clear
      rdoErrors.Clear
      Resume
   Else
      Resume ExitErr
   End If
   Exit Sub
ExitErr:
End Sub
Private Function GetrdoErrorDescription() As String
Dim rdoerr As rdoError, errstr As String
   
For Each rdoerr In rdoErrors
    errstr = errstr + rdoerr.Description + vbCrLf
Next
GetrdoErrorDescription = errstr
End Function

Private Sub Form_Unload(Cancel As Integer)
If Not (rs Is Nothing) Then rs.Close
If Not (cn Is Nothing) Then cn.Close
End Sub

'将某个File传入blob之栏位，当作资料来存
Public Function AppendBlobFromFile(blobColumn As rdoColumn, ByVal FileName) As Boolean
Dim FileNumber As Integer, DataLen As Long
Dim Chunks As Long, ChunkAry() As Byte
Dim ChunkSize As Long, Fragment As Long, i As Long
Dim str5 As String
On Error GoTo errh:
AppendBlobFromFile = False
ChunkSize = 2048

FileNumber = FreeFile
Open FileName For Binary Access Read As FileNumber
DataLen = LOF(FileNumber)    ' 档案中资料的长度
If DataLen = 0 Then Close FileNumber: Exit Function
Chunks = DataLen \ ChunkSize
Fragment = DataLen Mod ChunkSize
ReDim ChunkAry(Fragment - 1)
Get FileNumber, , ChunkAry()
blobColumn.AppendChunk ChunkAry
ReDim ChunkAry(ChunkSize - 1)
For i = 1 To Chunks
    Get FileNumber, , ChunkAry()
    blobColumn.AppendChunk ChunkAry
Next i
Close FileNumber
AppendBlobFromFile = True
Exit Function
errh:
   AppendBlobFromFile = False
   MsgBox Err.Description, vbCritical, "AppendBlobFromFile错误!!"
End Function

'把Blob的栏位内的资料读出来，放到某个File之内 
Public Function GetBlobToFile(blobColumn As rdoColumn, ByVal FileName As String) As Boolean
Dim FileNumber As Integer, DataLen As Long
Dim Chunks As Long, ChunkAry() As Byte
Dim ChunkSize As Long, Fragment As Long, i As Long
On Error GoTo errh:
GetBlobToFile = False
If IsNull(blobColumn) Then Exit Function

ChunkSize = 2048

FileNumber = FreeFile
Open FileName For Binary Access Write As FileNumber
DataLen = blobColumn.ColumnSize     ' 档案中资料的长度
Chunks = DataLen \ ChunkSize
Fragment = DataLen Mod ChunkSize
ReDim ChunkAry(Fragment - 1)
ChunkAry = blobColumn.GetChunk(Fragment)
Put FileNumber, , ChunkAry
ReDim ChunkAry(ChunkSize - 1)
For i = 1 To Chunks
   ChunkAry = blobColumn.GetChunk(ChunkSize)
   Put FileNumber, , ChunkAry
Next
Close FileNumber
GetBlobToFile = True
Exit Function
errh:
   GetBlobToFile = False
   MsgBox Err.Description, vbCritical, "GetBlobToFile错误!!"
End Function

Public Function SetBLOB(ByRef rclnBLOBColumn As rdoColumn, _
                        ByVal vvntBLOB As Variant) As Boolean
    rdoErrors.Clear
    On Error Resume Next
    rclnBLOBColumn.AppendChunk vvntBLOB

    If rdoErrors.Count > 0 Then
        SetBLOB = False
    Else
        SetBLOB = True
    End If

End Function

'将某个File的资料传入Text的资料栏位之中
Public Function AppendMemoFromFile(Memo As rdoColumn, ByVal FileName) As Boolean
Dim filenumber As Integer, ByteAry() As Byte
Dim str5 As String
On Error GoTo errh:
AppendMemoFromFile = False
filenumber = FreeFile
Open FileName For Input As filenumber
Do While Not EOF(filenumber)
    Line Input #filenumber, str5
    str5 = str5 + vbCr
    Memo.AppendChunk Str5
Loop
Close filenumber
AppendMemoFromFile = True
Exit Function
errh:
   AppendMemoFromFile = False
   MsgBox Err.Description, vbCritical, "AppenMemoFromFile错误!!"
End Function

'将Text资料栏位中之Data存到某个档之中
Public Function GetMemoToFile(Memo As rdoColumn, ByVal FileName) As Boolean
Dim filenumber As Integer, DataLen As Long
Dim str5 As String
On Error GoTo errh:
GetMemoToFile = False
If IsNull(Memo) Then Exit Function
filenumber = FreeFile
Open FileName For Output As filenumber
DataLen = Memo.ColumnSize     ' 档案中资料的长度
str5 = Memo.GetChunk(DataLen)
Print #filenumber, str5;
Close filenumber
GetMemoToFile = True
Exit Function
errh:
   GetMemoToFile = False
   MsgBox Err.Description, vbCritical, "GetMemoToFile错误!!"
End Function