publicbas.bas

本代码适合初学数据库者学习借鉴

Attribute VB_Name = "PublicBas"
Option Explicit

Public GlobalCon As ADODB.Connection
Public NowUserID As String
Public NowFilePath As String
Public NowUserPass As String

Public DocFilePath As String

Public BackValue As Variant
Function CheckSqlErr(NowCon As ADODB.Connection) As Boolean
Dim I As Integer
CheckSqlErr = False
If NowCon.Errors.Count > 0 Then
   For I = 0 To NowCon.Errors.Count - 1
        ShowMsgBox LoadResString(101) & Chr(13) & Chr(10) & NowCon.Errors(I).Description _
        & Chr(13) & Chr(10) & LoadResString(101) & NowCon.Errors(I).SQLState, vbExclamation
   Next
   NowCon.Errors.Clear
   CheckSqlErr = True
End If

End Function




Function ReadMemoOrPic(Tcon As ADODB.Connection, TableName As String, KeyFiled As String, KeyType As String, KeyValue As Variant, MemoFiled As String, Tfile As String) As Boolean
'保存文件的内容到表的字段
Dim j As Integer
Dim Chunk() As Byte, Fl As Long, Chunks As Long, I As Integer
Dim Fragment As Long, TempRec As New ADODB.Recordset, TempStr As String
On Error GoTo SaveErr
Const ChunkSize As Integer = 32000
Dim ChunkChar() As String
'重要的说明：因为为了防止Unicode与ANSI字符集相互之间的转换

If Tfile = "" Then
   MsgBox LoadResString(201), vbExclamation
   Exit Function
End If
If InStr(1, Tfile, "\") = 0 Then
   Tfile = DocFilePath & Tfile
End If

If Dir(Tfile) <> "" Then
   Kill Tfile
   Open Tfile For Binary Access Write As #1
   Close #1
End If


Set TempRec = New ADODB.Recordset
If UCase(KeyType) = "CHAR" Then
    TempStr = "SELECT " & MemoFiled & "," & KeyFiled & " FROM " & TableName & " WHERE " & KeyFiled & " = '" & KeyValue & "' "
Else
    TempStr = "SELECT " & MemoFiled & "," & KeyFiled & " FROM " & TableName & " WHERE " & KeyFiled & " = " & KeyValue
End If
TempRec.Open TempStr, Tcon, adOpenKeyset, adLockPessimistic     '锁定记录,防止其他人修改,可能会导致错误
If TempRec.EOF Then
   Close #1
   TempRec.Close
   Set TempRec = Nothing
   ReadMemoOrPic = False
   Exit Function
End If
If IsNull(TempRec.Fields(MemoFiled)) Then
    Open Tfile For Binary Access Write As #2
    Close #2
    Exit Function
End If
Fl = TempRec.Fields(MemoFiled).ActualSize - 1   ' 文件中数据的长度
    
Fragment = Fl Mod ChunkSize
Chunks = Fl \ ChunkSize
ReDim Chunk(Fragment) As Byte
If TempRec.Fields(MemoFiled).Type = adLongVarBinary Then
    Open Tfile For Binary Access Write As #1
    Chunk = TempRec.Fields(MemoFiled).GetChunk(Fragment)
    Put #1, , Chunk()
    ReDim Chunk(ChunkSize)
    
    For I = 1 To Chunks
       Chunk = TempRec.Fields(MemoFiled).GetChunk(ChunkSize)
       Put #1, , Chunk()
    Next
ElseIf TempRec.Fields(MemoFiled).Type = adLongVarChar Then
    Dim OddYn As Boolean, OneByte As Byte
    If Dir(App.Path & "\temp.rtf") <> "" Then Kill App.Path & "\temp.rtf"
    Open App.Path & "\temp.rtf" For Binary Access Write As #1
    Open Tfile For Binary Access Write As #2
    
    Chunk = TempRec.Fields(MemoFiled).GetChunk(Fragment)
    'ChunkChar = Chunk(), vbFromUnicode)
    Put #1, , Chunk()
    ReDim Chunk(ChunkSize)
    
    For I = 1 To Chunks
       Chunk = TempRec.Fields(MemoFiled).GetChunk(ChunkSize)
       Put #1, , Chunk()
    Next
    '开始文件转换
    Close #1
    
    I = 0
    Open App.Path & "\temp.rtf" For Binary Access Read As #1
    Screen.MousePointer = 11
    
    Do Until EOF(1)
        Get #1, , OneByte
        If OddYn = False Then
            Put #2, , OneByte
            OddYn = True
        Else
            OddYn = False
        End If
        I = I + 1
    Loop
    Close #1
    Close #2
    Screen.MousePointer = 0

End If
'结束更新配置

TempRec.Close
Set TempRec = Nothing

Close #1

ReadMemoOrPic = True

Exit Function
SaveErr:
   Close #1
   ShowMsgBox Err.Description, vbExclamation

End Function

Function SaveMemoOrPic(Tcon As ADODB.Connection, TableName As String, KeyFiled As String, KeyType As String, KeyValue As Variant, MemoFiled As String, Tfile As String) As Boolean
'保存文件的内容到表的字段
Dim j As Integer, Fragment As Integer, TempRec As New ADODB.Recordset
Dim Chunk() As Byte, Chunks As Integer, Fl As Long
Dim TempStr As String

On Error GoTo SaveErr
Const ChunkSize As Integer = 32000

If Dir(Tfile) = "" Or Trim$(Tfile) = "" Then
   MsgBox LoadResString(201), vbExclamation
   Exit Function
End If

If InStr(1, Tfile, "\") = 0 Then
   Tfile = DocFilePath & Tfile
End If

Set TempRec = New ADODB.Recordset
If UCase(KeyType) = "CHAR" Then
    TempStr = "SELECT " & MemoFiled & "," & KeyFiled & " FROM " & TableName & " WHERE " & KeyFiled & " = '" & KeyValue & "' "
Else
    TempStr = "SELECT " & MemoFiled & "," & KeyFiled & " FROM " & TableName & " WHERE " & KeyFiled & " = " & KeyValue
End If
TempRec.Open TempStr, Tcon, adOpenKeyset, adLockPessimistic
If TempRec.EOF Then
    TempRec.AddNew
    TempRec.Fields(KeyFiled).Value = KeyValue
End If

Open Tfile For Binary Access Read As #1

Fl = LOF(1)    ' 文件中数据的长度

Chunks = Fl \ ChunkSize
Fragment = Fl Mod ChunkSize
ReDim Chunk(Fragment) As Byte
Get #1, , Chunk()
TempRec.Fields(MemoFiled).AppendChunk Chunk()

ReDim Chunk(ChunkSize)
For j = 1 To Chunks
    Get #1, , Chunk()
    TempRec.Fields(MemoFiled).AppendChunk Chunk()
Next

TempRec.Update
'结束更新配置

TempRec.Close
Set TempRec = Nothing

Close #1

SaveMemoOrPic = True

Exit Function
SaveErr:
   Close #1
   ShowMsgBox Err.Description, vbExclamation

End Function






Public Sub ShowMsgBox(MsgStr As String, Optional ButtonValue As Integer, Optional TitleStr As String)
If ButtonValue = 0 Then ButtonValue = vbExclamation
If TitleStr = "" Then TitleStr = "SE2000"

BackValue = MsgBox(MsgStr, ButtonValue, TitleStr)

End Sub