RDO之Blob资料的存取

来源:cww

Blob资料的存取原本和 DAO for Access没有什麽太大的差异，都是使用AppendChunk
与GetChunk的方法来做，基本上，这Blob资料存取的原则是将待存入数据库的资料以
AppendChunk的方式存入，而另使用GetChunk由数据库中把资料读出来。
以下的范例中主要是 AppendBlobFromFile  GetBlobToFile 这两个自订函式，当然了，
这两个Function的方式都是透过File来做；当然了，也可以不透过File来做，例如
SetBlob这个自订函式，它就没有透过File，而是传入一个Byte Array，而这个Byte Array
如何产生，就得看实际的情况啦。
在这里我又很不满的提出一个问题，如果後端是SQL Server那麽，不管Cursor的建立是在
Client端或Server端(rdUseOdbc/rdUseServer)那一切都没有问题，但如果是OpenLink
的Informix ODBC Driver的话，只能透过rdUseODBC来做，要不然，也不会有任何错误讯
息，只是没有存进去罢了，这真是恼人，我想这应是一个Bug。

Informix另外有一个Text 的Blob栏位型态，存的是一般的文字(大量文字)，它的作法在
AppendMemoFromFile/GetMemoToFile之中，唯一要注意的可能是Unix中换行只有ASCII &H0D
而PC则是&H0D + &H0A，所以这边要多加转换。另外，这TEXT栏位的AppendChunk/GetChunk
传入与传回值都是字串，而不是ByteArray，这也要注意。

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

以下在.Bas中
'将某个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