VB中对数据库的操作

'
'数据库操作(SmDbCtrl)
'
Option Explicit

Public DbStyle As String
Dim CT As SmDataDiap
'

'========================================================================
'创建一个SQLSERVER定形连接(连接到SQL)
'函数名:CreateShape
'参数: P_Cnn ADODB连接,ServerName 服务器名,DBname 数据库名,UserID 登录用户名,UPw 登录密码,Timerout 连接超时
'返回值:TRUE 连接成功.FALSE 连接失败.
'例: CreateShape P_Cnn,"CJH","cjherp001","sa","123",15
'========================================================================

Public Function CreateShape(ByRef P_Cnn As ADODB.Connection, _
ServerName As String, _
DbName As String, _
UserID As String, _
UPw As String, _
Optional Timerout As Long = 15) As Boolean

Dim ReturnVal As Boolean
Dim ConnStr As String

Err.Clear
On Error Resume Next

ConnStr = "Provider=MSDataShape;Data Provider=SQLOLEDB.1;Password=" & UPw & ";Persist Security Info=True;User ID=" & UserID & _
";Initial Catalog=" & DbName & ";Data Source=" & ServerName
P_Cnn.ConnectionString = ConnStr
P_Cnn.ConnectionTimeout = Timerout
P_https://www.wendangku.net/doc/925451052.html,mandTimeout = Timerout
P_Cnn.Open
DoEvents

If Err.Number = 0 Then
DbStyle = "SQL"
ReturnVal = True
Else
Err.Clear
DbStyle = ""
ReturnVal = False
End If
CreateShape = ReturnVal
Err.Clear
End Function

'========================================================================
'创建一个连接(连接到SQL)
'函数名:CreateSqlConn
'参数: P_Cnn ADODB连接,ServerName 服务器名,DBname 数据库名,UserID 登录用户名,UPw 登录密码,Timerout 连接超时
'返回值:TRUE 连接成功.FALSE 连接失败.
'例: CreateSqlConn p_cnn,"CJH","cjherp001","sa","123",15
'========================================================================
Public Function CreateSqlConn(ByRef P_Cnn As ADODB.Connection, _
ServerName As String, _
DbName As String, _
UserID As String, _
UPw As String, _
Optional Timerout As Long = 15) As Boolean
Dim ReturnVal As Boolean

Err.Clear
On Error Resume Next

If P_Cnn.State = adStateOpen And Not IsEmpty(adStateOpen) Then
P_Cnn.Close
End If

P_Cnn.Provider = "MSDASQL.1"
P_Cnn.ConnectionString = "Driver={SQL Server};Server=" & ServerName & ";DataBase=" & DbName & ";Uid=" & UserID & ";Pwd=" & UPw & ";APP=" & App.Path & ";WSID=" & UserID & ";Connect Timeout=" & Timer

out & ";"

P_Cnn.ConnectionTimeout = Timerout
P_https://www.wendangku.net/doc/925451052.html,mandTimeout = Timerout
P_Cnn.Open
DoEvents
If Err.Number = 0 Then
DbStyle = "SQL"
ReturnVal = True
Else
Err.Clear
DbStyle = ""
ReturnVal = False
End If
CreateSqlConn = ReturnVal
Err.Clear

End Function
'

'========================================================================
'创建一个连接(连接到ACCESS)
'函数名:CreateMdbConn
'参数: MdbCnn ADODB连接,MdbPath ACCESS数据库路径,Provider JET引擎版本,UserID 登录用户名,UserWord 登录密码
'返回值:TRUE 连接成功.FALSE 连接失败.
'例: CreateMdbConn p_cnn,"C:\DEMO.MDB","sa","123"
'========================================================================

Public Function CreateMdbConn(ByRef MdbCnn As ADODB.Connection, _
MdbPath As String, _
Optional Provider = "Microsoft.Jet.OLEDB.4.0;", _
Optional UserID As String = "admin", _
Optional UserWord As String = "") As Boolean
Dim ConStr As String

Err.Clear
On Error Resume Next

If MdbCnn.State = adStateOpen And Not IsEmpty(adStateOpen) Then
MdbCnn.Close
End If
'/------------------------------------------------------------------
ConStr = "Provider=" & Provider & _
"Data Source=" & MdbPath & ";" & _
"Jet OLEDB:Database Password=" & UserWord & ";" & _
"User ID=" & UserID & ";"

MdbCnn.ConnectionString = ConStr
MdbCnn.Open
DoEvents

If Err.Number = 0 Then
DbStyle = "MDB"
CreateMdbConn = True
Else
Err.Clear
DbStyle = ""
CreateMdbConn = False
End If
Err.Clear
End Function

'=====================================================================
'创建一个连接(连接到其它数据库类型)
'函数名:CreateOtherConn
'参数: OtherCnn ADODB连接,FilePath 数据库路径,UserName 登录用户名,PassWord 登录密码,DbType SmDbType枚举数据库类型
'返回值:TRUE 连接成功.FALSE 连接失败.
'例:
'CreateOtherConn Cnn, "E:\CjhLx\dbf", , , FoxPro
'StrSql = "select * from [employee.dbf]"
'Set Rs = RsOpen(Cnn, StrSql)
'Set DataGrid1.DataSource = Rs
'=====================================================================

Public Function CreateOtherConn(ByRef OtherCnn As ADODB.Connection, _
FilePath As String, _
Optional UserName As String = "admin", _
Optional PassWord As String = "", _
Optional DbType As SmDbType = Access) As Boolean
Dim ConnStr As String
Dim DriveName(5) As String
Dim tDbType(5) As String
Dim UserPwd(5) As String

Err.Clear

'/驱动程序
DriveName(1) = "{Microsoft Access Driver (*.mdb)}"
DriveName(2) = "{Microsoft Excel Driver (*.xls)}"
DriveName(3) = "{Microsoft Text Driver (*.txt; *.csv)}"
DriveName(4) = "{Microsoft Visual FoxPro Driver};SourceType=DBF"
DriveName(5) = "{Microsoft dBase Driver (*.dbf)}"
'/类型
tDbType(1) = "MDB"
tDbType(2) = "XLS"
tDbType(3) = "TXT"
tDbType(4) = "FDB"
tDbType(5) = "DDB"
'/用户名和密码.
UserPwd(1) = "Uid=" & UserName & ";Pwd=" & PassWord & ";"
UserPwd(2) = "Uid=" & UserName & ";Pwd=" & PassWord & ";"
UserPwd(3) = ""
UserPwd(4) = "Uid=" & UserName & ";Pwd=" & PassWord & ";"
UserPwd(5) = "Uid=" & UserName & ";Pwd=" & PassWord & ";"

On Error Resume Next

If OtherCnn.State = adStateOpen And Not IsEmpty(adStateOpen) Then
OtherCnn.Close
End If
ConnStr = "Provider=MSDASQL.1;Persist Security Info=False;DRIVER=" & DriveName(DbType) & ";" & UserPwd(DbType) & "DBQ=" & FilePath
OtherCnn.ConnectionString = ConnStr
OtherCnn.Open
DoEvents

If Err.Number = 0 Then
DbStyle = tDbType(DbType)
CreateOtherConn = True
Else
Err.Clear
DbStyle = ""
CreateOtherConn = False
End If
Err.Clear
End Function

'=========================================================================
'打开一个记录集
'函数名:RsOpen
'参数: P_Cnn ADODB连接,StrSql SQL查询语句,SetNothing 非连接方式(TRUE默认).连接方式(FALSE)
'返回值:记录集
'例: RsOpen P_CNN,"SELECT ACHGOODS.* FROM ACHGOODS WHERE GDSID='001'
'=========================================================================
Public Function RsOpen(ByRef P_Cnn As ADODB.Connection, _
StrSql As String, _
Optional SetConnect As Boolean = True) As ADODB.Recordset

Dim Rs As New ADODB.Recordset

Err.Clear
On Error Resume Next

If P_Cnn.State <> 1 Then P_Cnn.Open

If SetConnect Then '使用非连接
Rs.CursorLocation = adUseClient '使用客户端游标
Rs.LockType = adLockBatchOptimistic '开放式批更新
Rs.CursorType = adOpenKeyset '键集游标
Else '使用连接(主要用于更新二进制字段)
Rs.CursorLocation = adUseClient
Rs.CursorType = adOpenKeyset
Rs.LockType = adLockOptimistic '记录锁定
End If
Rs.Open StrSql, P_Cnn '执行SQL
If SetConnect Then Set Rs.ActiveConnection = Nothing '设置非连接

If Err.Number = 0 Then
Set RsOpen = Rs.Clone
Else
Set RsOpen = Nothing
End If

Rs.

Close
Set Rs = Nothing
Err.Clear
End Function

'//执行一条SQL语句
Public Function ExecSql(ByRef P_Cnn As ADODB.Connection, _
StrSql As String) As Boolean

Err.Clear
If P_Cnn.State <> 1 Then P_Cnn.Open
P_Cnn.Execute StrSql
ExecSql = (Err.Number = 0)
Err.Clear
End Function
'

'========================================================================
'建立数据库
'函数名:CreateDataBase
'参数: ServerName 服务器名,UserID 用户名(SA),Pwd 登录密码,DataBasName 建立的数据库名,DataBasPath 库文件目录的绝对路径
'返回值:无
'例: CreateDataBase "CJH","SA","123","CJHERP001","C:\DB"
'========================================================================
Public Function CreateDataBase(ServerName As String, _
UserID As String, _
Pwd As String, _
DataBasName As String, _
DataBasPath As String) As Boolean

Dim A As Long, LeftName As String
Dim DbC As New ADODB.Connection
Dim CreateBasSql As String
Dim BagTrFlag As Boolean

Err.Clear

If CreateSqlConn(DbC, ServerName, "Master", UserID, Pwd) Then
If Right$(DataBasPath, 1) <> "\" Then DataBasPath = DataBasPath & "\"

On Error GoTo Errhan:

DataBasPath = Trim$(DataBasPath)

If Len(DataBasPath) < 2 Then Exit Function
If Dir$(Left$(DataBasPath, 2), vbDirectory) = "" Then Beep: Exit Function '根目录是否存在
'/---------------------------------------------------------
If Right$(DataBasPath, 1) <> "\" Then DataBasPath = DataBasPath & "\"
For A = 1 To Len(DataBasPath)
If Mid$(DataBasPath, A, 1) = "\" Then
LeftName = Left$(DataBasPath, A)
'/如果目录不存在,则先建立
If Dir$(LeftName, vbDirectory) = "" Then MkDir LeftName: DoEvents
End If
Next
Err.Clear
DbC.BeginTrans
'/---------------------------------------------------------
CreateBasSql = " CREATE DATABASE " & DataBasName & " ON (NAME=" & DataBasName & ",FILENAME='" & DataBasPath & DataBasName & ".mdf', SIZE=20,FILEGROWTH=4) " & _
" LOG ON (NAME=" & DataBasName & "Log" & ",FILENAME='" & DataBasPath & DataBasName & "Log.ldf',SIZE=20,FILEGROWTH=0)"
DbC.Execute CreateBasSql
https://www.wendangku.net/doc/925451052.html,mitTrans
End If

Errhan:
If Err.Number <> 0 Then DbC.RollbackTrans
CreateDataBase = (Err.Number = 0)
DbC.Close
Set DbC = Nothing
Err.Clear
End Function

'
'建立数据表
'函数名:CreageDbTab
'参数: P_Cnn ADO连接,CreateTableSql 建表字符串
'返回值:无
'例:

CreateDbTab P_CNN,CreateTabStr
Public Function CreateDbTab(ByRef P_Cnn As ADODB.Connection, _
CreateTableSql As String) As Boolean

Err.Clear
On Error Resume Next

If P_Cnn.State <> 1 Then P_Cnn.Open
P_Cnn.BeginTrans
P_Cnn.Execute CreateTableSql
P_https://www.wendangku.net/doc/925451052.html,mitTrans
CreateDbTab = (Err.Number = 0)
Err.Clear
End Function

'
'得到服务器上所有的数据库名
'函数名:GetAllDatabases
'参数: ServerName 服务器名,UserID 登录用户名(SA),Pwd 登录密码
'返回值:数据库名的字符串数组
'例: GetAllDatabases "CJH","SA","123"
Public Function GetAllDatabases(ServerName As String, _
UserID As String, _
Pwd As String, _
Optional strDriver As String = "SQL Server") As String()
Dim PCnn As New ADODB.Connection
Dim RsSchema As New ADODB.Recordset
Dim ConnStr As String
Dim ReturnVal() As String
Dim ReID As Long

Err.Clear
On Error Resume Next

ConnStr = "Driver={" & strDriver & "};"
ConnStr = ConnStr & "Server=" & ServerName & ";"
ConnStr = ConnStr & "uid=" & UserID & ";pwd=" & Pwd & ";"
PCnn.ConnectionString = ConnStr

PCnn.Open: ReID = 0
Set RsSchema = PCnn.OpenSchema(adSchemaCatalogs)
Do Until RsSchema.EOF
ReID = ReID + 1
ReDim Preserve ReturnVal(ReID - 1)
ReturnVal(ReID - 1) = RsSchema!Catalog_Name
RsSchema.MoveNext
Loop
If PCnn.State = adStateOpen And Not IsEmpty(adStateOpen) Then
PCnn.Close
End If
GetAllDatabases = ReturnVal
Err.Clear
End Function

'
'取某数据库下的数据表
'函数名:GetDbTabS
'参数: P_Cnn ADO连接
'返回值:包含数据表的字符串数组
'例: TabArr=GetDbTabS(P_CNN)

Public Function GetDbTabs(ByRef P_Cnn As ADODB.Connection) As String()
Dim RstSchema As ADODB.Recordset
Dim strCnn As String
Dim ReturnVal() As String
Dim ReID As Long

Err.Clear
On Error Resume Next

If P_Cnn.State <> 1 Then P_Cnn.Open

Set RstSchema = P_Cnn.OpenSchema(adSchemaTables)
ReID = 0
Do Until RstSchema.EOF
If UCase$(Left$(RstSchema.Fields("TABLE_TYPE"), 3)) <> "SYS" Then
ReID = ReID + 1
ReDim Preserve ReturnVal(ReID - 1)
ReturnVal(ReID - 1) = RstSchema.Fields("TABLE_NAME") ' & ":" & RstSchema!TABLE_TYPE
End If
RstSchema.MoveNext
Loop
RstSchema.Close
Set RstSchema = Nothing
GetDbTabs = ReturnVal
Err.Clear
End Function

'============================================================================
'取临时表名
'函数名:GetTmpName
'参数:
'返回值:一个唯一的临时表名
'例: TmpName=GetTmpName()
'(注:临时表名="#TmpTal" & 累加

数 & 毫秒数)
'============================================================================
Public Function GetTmpName(Optional UserName As String = "") As String
Dim ReturnVal As String
Dim TimVal As String
Static K As Long

Err.Clear
On Error Resume Next

K = K + 1
If K >= 2147483645# Then K = 0 '累加数
TimVal = timeGetTime() '毫秒数
ReturnVal = "#" & "TmpTal" & UserName & TimVal & CT.ToStr(K)
GetTmpName = IIf(Err.Number = 0, ReturnVal, "")
Err.Clear
End Function
'

'=======================================================================
'对 表格或记录集以 INSERT INTO 保存.
'函数名:GetInsertIntoSql
'参数: P_Cnn ADO连接,mRs 记录集,DateTabName 目标数据表名
'返回值:SQL语句
'例: InsertIntoDB P_CNN,RS,"ACHGOODS"
'=======================================================================
Public Function InsertIntoDB(ByRef P_Cnn As ADODB.Connection, _
DateTabName As String, _
ByRef MRs As ADODB.Recordset) As Boolean
Dim StrSql As String
Dim TabFied() As SmFiedArrtr '数据库字段
Dim SaveFied() As SmFiedArrtr '表格与数据库同时存在的字段
Dim SaveID As Long
Dim AddSave As Boolean
Dim AddFile As SmFiedArrtr
Dim FileCon As String
Dim FldVal As String
Dim TmpVal As Variant
Dim FldType As Long
Dim A As Long, B As Long, I As Long
Dim FldValColl As New Collection
'/--------------------------------------------------------------------------------------
Err.Clear
On Error Resume Next

If (MRs.EOF And MRs.BOF) Then Exit Function
Erase TabFied
If P_Cnn.State <> 1 Then P_Cnn.Open

TabFied = GetTabFldAttrib(P_Cnn, DateTabName) '取数据库字段
If UBound(TabFied, 1) > 0 Then
SaveID = 0: AddSave = False
For A = 0 To MRs.Fields.Count - 1
For B = 0 To UBound(TabFied, 1)
If UCase$(TabFied(B).FieldName) = UCase$(MRs.Fields(A).Name) Then

'处理重复的字段名.
Err.Clear
FldValColl.Add TabFied(B), "_" & UCase$(TabFied(B).FieldName)

If Err.Number <> 457 Then
SaveID = SaveID + 1
ReDim Preserve SaveFied(SaveID - 1)
SaveFied(SaveID - 1) = TabFied(B)
End If

Exit For

End If
Next
Next
'/---------------------------------------------------------------------

------------------
'/保存字段列表
For A = 0 To UBound(SaveFied, 1) '字段列表
If SaveFied(A).FieldType <> 205 Then
FileCon = FileCon & "[" & SaveFied(A).FieldName & "],"
End If
Next A
FileCon = Left$(FileCon, Len(FileCon) - 1)

MRs.MoveFirst

While Not MRs.EOF
FldVal = ""
For I = 0 To UBound(SaveFied, 1)
FldType = SaveFied(I).FieldType '字段类型
If FldType <> 205 Then '将IMAGE字段排除
TmpVal = CT.ToStr(MRs.Fields(SaveFied(I).FieldName)) '字段值
If Len(TmpVal) = 0 Then '对空或NULL的处理
Select Case FldType
Case 2, 3, 4, 5, 6, 17, 131 '数值类型
If SaveFied(I).FieldIsNull <> 0 Then '可接受NULL
FldVal = FldVal & "NULL,"
Else
FldVal = FldVal & "0,"
End If
Case 135 '日期
If SaveFied(I).FieldIsNull <> 0 Then '可接受NULL
FldVal = FldVal & "NULL,"
Else
If DbStyle = "MDB" Then
FldVal = FldVal & "#" & Now() & "#,"
Else
FldVal = FldVal & "'" & Now() & "',"
End If

End If
Case Else '其它类型
If SaveFied(I).FieldIsNull <> 0 Then
FldVal = FldVal & "NULL,"
Else
FldVal = FldVal & "'',"
End If
End Select
Else
Select Case FldType
Case 2, 3, 4, 5, 6, 17, 131 '数值类型
FldVal = FldVal & "" & TmpVal & ","
Case 135
If DbStyle = "MDB" Then
FldVal = FldVal & "#" & TmpVal & "#,"
El

se
FldVal = FldVal & "'" & TmpVal & "',"
End If
Case Else '其它类型
FldVal = FldVal & "'" & Replace(TmpVal, "'", "''") & "',"
End Select
End If
End If
Next
FldVal = Left$(FldVal, Len(FldVal) - 1)
StrSql = "INSERT INTO [" & DateTabName & "] (" & FileCon & ") VALUES (" & FldVal & ")"
P_Cnn.Execute StrSql
MRs.MoveNext
Wend
End If
Set FldValColl = Nothing
InsertIntoDB = (Err.Number = 0)
Err.Clear
End Function

'
'对表格或记录集以 UPDATE 保存.
'函数名:GetUpdataSql
'参数: P_Cnn ADO连接,mRs 记录集,DateTabName 目标数据表名,WhereStr 更新条件
'返回值:SQL语句
'例: UpdataDB P_CNN,RS,"ACHGOODS","WHERE GDSID='001'"
Public Function UpdataDB(ByRef P_Cnn As ADODB.Connection, _
DateTabName As String, _
ByRef MRs As ADODB.Recordset, _
WhereStr As String) As Boolean
Dim StrSql As String
Dim TabFied() As SmFiedArrtr '数据库字段
Dim SaveFied() As SmFiedArrtr '表格与数据库同时存在的字段
Dim SaveID As Long
Dim AddSave As Boolean
Dim AddFile As SmFiedArrtr
Dim FileCon As String
Dim FldVal As String
Dim TmpVal As Variant
Dim FldType As Long
Dim A As Long, B As Long, I As Long
'/----------------------------------------------------------------------------------------
Err.Clear
On Error Resume Next
'
If MRs.EOF And MRs.BOF Then Exit Function
Erase TabFied
If P_Cnn.State <> 1 Then P_Cnn.Open
TabFied = GetTabFldAttrib(P_Cnn, DateTabName) '取数据库字段
If UBound(TabFied, 1) > 0 Then
SaveID = 0
For A = 0 To MRs.Fields.Count - 1
For B = 0 To UBound(TabFied, 1)
If UCase$(TabFied(B).FieldName) = UCase$(MRs.Fields(A).Name) Then
SaveID = SaveID + 1
ReDim Preserve SaveFied(SaveID - 1)
SaveFied(SaveID - 1) = TabFied(B)
Exit For '找到数据库与记录集中相同的值,跳出循环.
End If
Next
Next
'/--------------------------------------------------------------------------------------
MRs.MoveFirst
While Not MRs.EOF
FldVal = ""
For I = 0 To UBound(SaveFied, 1)
FldType = SaveFied(I).FieldType '字段类型

If FldType <> 205 Then '将IMAGE字段排除
TmpVal = CT.ToStr(MRs.Fields(SaveFied(I).FieldName)) '字段值
If Len(TmpVal) = 0 Then '对空或NULL的处理
Select Case FldType
Case 2, 3, 4, 5, 6, 17, 131 '数值类型
If SaveFied(I).FieldIsNull <> 0 Then '可按受NULL
FldVal = FldVal & ",[" & SaveFied(I).FieldName & "]=NULL"
Else
FldVal = FldVal & ",[" & SaveFied(I).FieldName & "]=0"
End If
Case 135 '日期时间
If SaveFied(I).FieldIsNull <> 0 Then '可接受NULL
FldVal = FldVal & ",[" & SaveFied(I).FieldName & "]=NULL"
Else
If DbStyle = "MDB" Then
FldVal = FldVal & ",[" & SaveFied(I).FieldName & "]=#" & Now() & "#"
Else
FldVal = FldVal & ",[" & SaveFied(I).FieldName & "]='" & Now() & "'"
End If
End If
Case Else '其它类型
If SaveFied(I).FieldIsNull <> 0 Then
FldVal = FldVal & ",[" & SaveFied(I).FieldName & "]=NULL"
Else
FldVal = FldVal & ",[" & SaveFied(I).FieldName & "]=''"
End If
End Select
Else
Select Case FldType
Case 2, 3, 4, 5, 6, 17, 131 '数值类型
FldVal = FldVal & ",[" & SaveFied(I).FieldName & "]=" & TmpVal
Case 135
If DbStyle = "MDB" Then
FldVal = FldVal & ",[" & SaveFied(I).FieldName & "]=#" & TmpVal & "#"
Else
FldVal = FldVal & ",[" & SaveFied(I).FieldName & "]='" & TmpVal & "'"
End If
Case Else '其它类型
FldVal = FldVal & ",[" & SaveFied(I).FieldName & "]='" & Replace(TmpVal, "'", "''") & "'

"
End Select
End If
End If
Next
FldVal = " Set " & Right$(FldVal, Len(FldVal) - 1) & " " & WhereStr
StrSql = "UpDate [" & DateTabName & "]" & FldVal
P_Cnn.Execute StrSql
MRs.MoveNext
Wend
End If
UpdataDB = (Err.Number = 0)
Err.Clear
End Function

'
'取某 数据表 下所有的字段及其属性
'函数名:GetTabFldAttrib
'参数: P_Cnn ADO连接,DateTabName 目标数据表名
'返回值:SmFiedArrtr 类型数组
'例: FiedAtrrib=GetTabFldAttrib(P_CNN,"ACHGOODS")
Public Function GetTabFldAttrib(ByRef P_Cnn As ADODB.Connection, _
DbTableName As String) As SmFiedArrtr()
Dim A As Long
Dim StrSql As String
Dim Rs As New ADODB.Recordset
Dim ReturnVal() As SmFiedArrtr
Dim ReID As Long

Err.Clear
On Error Resume Next

If P_Cnn.State <> 1 Then P_Cnn.Open

StrSql = "Select Top 1 * From [" & DbTableName & "]" '取字段名
Set Rs = RsOpen(P_Cnn, StrSql)
Set Rs.ActiveConnection = Nothing
Erase ReturnVal: ReID = 0
For A = 0 To Rs.Fields.Count - 1
ReID = ReID + 1
ReDim Preserve ReturnVal(ReID - 1)
ReturnVal(ReID - 1).FieldType = Rs.Fields(A).Type '数据类型
ReturnVal(ReID - 1).FieldName = Rs.Fields(A).Name '字段名
ReturnVal(ReID - 1).FieldIsNull = Rs.Fields(A).Attributes And adFldIsNullable '是否可接受NULL
ReturnVal(ReID - 1).FieldDefSize = Rs.Fields(A).DefinedSize '定义的数据长度
ReturnVal(ReID - 1).FieldActSize = 0 '实际数据长度(因只有字段名),故此值是0
Next
Set Rs = Nothing
GetTabFldAttrib = ReturnVal
Err.Clear
End Function

'
'取某 数据表 下除IMAGE字段名的所有字段名
'函数名:GetTabFldName
'参数: P_Cnn ADO连接,DateTabName 目标数据表名
'返回值:String 类型数组
'例: StrFld=GetTabFldName(P_CNN,"ACHGOODS")
Public Function GetTabFldName(ByRef P_Cnn As ADODB.Connection, _
DbTabname As String) As String
Dim N As Long
Dim ReturnVal As String
Dim FltArt() As SmFiedArrtr

Err.Clear
On Error Resume Next

If P_Cnn.State <> 1 Then P_Cnn.Open

ReturnVal = ""
FltArt() = GetTabFldAttrib(P_Cnn, DbTabname)
For N = 0 To UBound(FltArt)
If FltArt(N).FieldType <> 205 Then
ReturnVal = ReturnVal & DbTabname & "." & FltArt(N).FieldName & ","
End If
Next
ReturnVal = Left$(ReturnVal, Len(ReturnVal) - 1)
GetTabFldName = IIf(Err.Number = 0,

ReturnVal, "")
Err.Clear
End Function

'
'取 记录集 下所有的字段及其属性
'函数名:GetRsAttrib
'参数: mRs 记录集
'返回值:FiedArrtr类型数组
'例: RsAtrrib=GetRsAttrib(Rs)
Public Function GetRsAttrib(ByRef MRs As ADODB.Recordset) As SmFiedArrtr()
Dim A As Long
Dim ReturnVal() As SmFiedArrtr
Dim Rs As New ADODB.Recordset
Dim ReID As Long

Err.Clear
Set Rs = MRs.Clone
Erase ReturnVal
For A = 0 To Rs.Fields.Count - 1
ReID = ReID + 1
ReDim Preserve ReturnVal(ReID - 1)
ReturnVal(ReID - 1).FieldType = Rs.Fields(A).Type '数据类型
ReturnVal(ReID - 1).FieldName = Rs.Fields(A).Name '字段名
ReturnVal(ReID - 1).FieldIsNull = Rs.Fields(A).Attributes And adFldIsNullable '是否可接受NULL
ReturnVal(ReID - 1).FieldDefSize = Rs.Fields(A).DefinedSize '定义的数据长度
ReturnVal(ReID - 1).FieldActSize = Rs.Fields(A).ActualSize '数据的实际长度
Next
Set Rs = Nothing
GetRsAttrib = ReturnVal
Err.Clear
End Function

'
'取[窗体控件]与[字段]的对应关系
'函数名:GetConToFld
'参数: P_Cnn ADODB.Connection,SelectStr SQL语句.
'返回值:SmCtrlCorRs 类型数组
'例: FrmAndFied=GetConToFld(P_Cnn,Me)
'*窗体控件命名规则:1-3 控件类型,4 W读写标志,R只读标志,其它,不作处理, 5 数据类型,6----最后.相对的字段名
'*关于数据类型:C -字符 I 整数 F 浮点数 A 金额 U 单价 D 日期 T 时间
Public Function GetConToFld(ByRef P_Cnn As ADODB.Connection, ByRef Frm As Object, SelectStr As String) As SmCtrlCorRs()
Dim RevArr() As SmCtrlCorRs
Dim StrSql As String
Dim Rs As New ADODB.Recordset

Err.Clear
On Error Resume Next

' If (Frm Is Nothing) Or (P_Cnn Is Nothing) Then Exit Function
' If Len(Trim$(DbTabname)) = 0 Then DbTabname = https://www.wendangku.net/doc/925451052.html,
'
' StrSql = "SELECT TOP 1 * FROM [" & DbTabname & "]"
StrSql = SelectStr

If P_Cnn.State <> 1 Then P_Cnn.Open

Set Rs = RsOpen(P_Cnn, StrSql)
RevArr = GetConToRs(Frm, Rs)
GetConToFld = RevArr
Set Rs = Nothing
Erase RevArr
Err.Clear
End Function

'
'取[窗体控件]与[记录集]的对应关系
'函数名:GetConToRs
'参数: Frm 源窗体名,mRs 源记录集
'返回值:SmCtrlCorRs 类型数组
'例: FrmAndFied=GetConToRs(Me,Rs)
'*窗体控件命名规则:1-3 控件类型,4 W读写标志,R只读标志,其它,不作处理, 5 数据类型,6----最后.相对的字段名
'*关于数据类型:C -字符 I 整数 F 浮点数 A 金额 U 单价 D 日期 T 时间
Public Function GetConToRs(ByRef m_Frm As Object, _
ByRef

MRs As ADODB.Recordset) As SmCtrlCorRs()
Dim A As Long, B As Long
Dim SaveID As Long
Dim AddSave As Boolean
Dim ArrayCon() As Control '控件
Dim TabFied() As SmFiedArrtr '数据库字段
Dim SetFied() As String '同时存在的字段
Dim ReturnVal() As SmCtrlCorRs '定义一个结构数组,用于返回
Dim AddFile As SmCtrlCorRs
Dim Rs As New ADODB.Recordset
Dim SId As Long
Dim FrmCon As Control
Dim ConName As String
Dim ConID As Long
Dim Frm As Form

Err.Clear
On Error Resume Next

Erase ArrayCon: ConID = 0
Set Frm = m_Frm
For Each FrmCon In Frm.Controls '取控件,放入一个数组中
ConName = https://www.wendangku.net/doc/925451052.html,
'/将图片框控件排除
If UCase$(TypeName(FrmCon)) = UCase$("PictureBox") Or UCase$(TypeName(FrmCon)) = UCase$("Image") Or UCase$(TypeName(FrmCon)) = UCase$("SMPICBOX") Then

Else
If Len(ConName) > 5 Then
If UCase$(Mid$(ConName, 4, 1)) = "W" Or UCase$(Mid$(ConName, 4, 1)) = "R" Then
ConID = ConID + 1
ReDim Preserve ArrayCon(ConID - 1)
Set ArrayCon(ConID - 1) = FrmCon
End If
End If
End If
Next
'/---------------------------------------------------------------------------------------------
Erase TabFied
Set Rs = MRs.Clone
If Rs.EOF And Rs.BOF Then
Rs.AddNew
End If

TabFied = GetRsAttrib(MRs) '取字段属性
If UBound(TabFied, 1) > 0 Then
SaveID = 0: AddSave = False
For A = 0 To UBound(TabFied, 1)
For B = 0 To UBound(ArrayCon, 1)
ConName = UCase$(Right$(ArrayCon(B).Name, Len(ArrayCon(B).Name) - 5))
If UCase$(TabFied(A).FieldName) = ConName Then
SId = SId + 1
ReDim Preserve ReturnVal(SId - 1)
ReturnVal(SId - 1).FieldName = TabFied(A).FieldName
ReturnVal(SId - 1).FieldActSize = TabFied(A).FieldActSize
ReturnVal(SId - 1).FieldDefSize = TabFied(A).FieldDefSize
ReturnVal(SId - 1).FieldIsNull = TabFied(A).FieldIsNull
ReturnVal(SId - 1).FieldName = TabFied(A).FieldName
ReturnVal(SId - 1).FieldType = TabFied(A).FieldType
Set ReturnVal(SId - 1).FrmCon = ArrayCon(B) '对应的控件
'/设置字符型的数据长度.
If UCase$(TypeName(ReturnVal(SId - 1).FrmCon)) = UCase$("TextBox") Then
Select Case ReturnVal(SId - 1).FieldType
Case Is = 200 'VARCHAR
ReturnVal(SId - 1).FrmCon.MaxLength = (ReturnVal(SId - 1).FieldDefSize) \ 2

Case Is = 202 'NVARCHAR
ReturnVal(SId - 1).FrmCon.MaxLength = (ReturnVal(SId - 1).FieldDefSize)
Case Is = 129 'CHAR
ReturnVal(SId - 1).FrmCon.MaxLength = (ReturnVal(SId - 1).FieldDefSize) \ 2
Case Is = 130 'NCHAR
ReturnVal(SId - 1).FrmCon.MaxLength = (ReturnVal(SId - 1).FieldDefSize)
Case Is = 201 'TEXT
ReturnVal(SId - 1).FrmCon.MaxLength = (ReturnVal(SId - 1).FieldDefSize) \ 2
Case Is = 203 'NTEXT
ReturnVal(SId - 1).FrmCon.MaxLength = (ReturnVal(SId - 1).FieldDefSize)
End Select
End If
End If
Next
Next
End If

Set Rs = Nothing
GetConToRs = ReturnVal
Erase ArrayCon: Erase ReturnVal
Err.Clear
End Function

'
'返回窗体中除IMAGE字段外的所有字段名
'函数名:GetFrmFld
'参数: ArrCon SmCtrlCorRs数组,TlbName 数据表名
'返回值:一个以","分隔的字段列表.
'例:
Public Function GetFrmFld(ByRef ArrCon() As SmCtrlCorRs, TlbName As String) As String
Dim ReturnVal As String
Dim N As Long
Dim ConName As String

Err.Clear
On Error Resume Next

For N = 0 To UBound(ArrCon, 1)
ConName = ArrCon(N)https://www.wendangku.net/doc/925451052.html,
If ArrCon(N).FieldType <> 205 And UCase$(Mid$(ConName, 4, 1)) = "W" Then
ReturnVal = ReturnVal & TlbName & "." & ArrCon(N).FieldName & ","
End If
Next
If Len(ReturnVal) > 0 Then ReturnVal = Left$(ReturnVal, Len(ReturnVal) - 1)
GetFrmFld = IIf(Err.Number = 0, ReturnVal, "")
Err.Clear
End Function

'
'从窗体的控件中生成 SQL (INSERT INTO)
'函数名:GetFrmIntoSql
'参数: tArrCon() DATAFRM类型数组,DateTabName 目标数据表名.Reorder 重新定位.
'返回值:Insert Inot Sql 语句
'例: FrmSql=GetFrmIntoSql(MeArrCon,"AchGoods")
Function GetFrmIntoSql(P_Cnn As ADODB.Connection, ByRef ArrCon() As SmCtrlCorRs, DateTabName As String, Optional Reorder As Boolean = False) As String
Dim I As Long
Dim StrSql As String
Dim TmpVal As Variant
Dim FldVal As String
Dim FileSum As String

Dim ReID As Long
Dim M As Long
Dim N As Long

Dim TArrCon() As SmCtrlCorRs
Dim TabFldAtt() As SmFiedArrtr
Dim TmpFldAtt As SmCtrlCorRs

Err.Clear
On Error Resume Next

If P_Cnn.State <> 1 Then P_Cnn.Open

If Reorder Then '//重新定位.
TabFldAtt = GetTabFldAttrib(P_Cnn, DateTabName)
For N = 0 To UBound(ArrCon

)
For M = 0 To UBound(TabFldAtt)
If UCase$(ArrCon(N).FieldName) = UCase$(TabFldAtt(M).FieldName) Then
ReID = ReID + 1
ReDim Preserve TArrCon(ReID - 1)
TArrCon(ReID - 1) = ArrCon(N)
End If
Next
Next
Else
TArrCon = ArrCon
End If
'***********************************************************************
For I = 0 To UBound(TArrCon, 1)
If UCase$(Mid$(TArrCon(I)https://www.wendangku.net/doc/925451052.html,, 4, 1)) = "W" Then '将具有写标志的控件组合成SQL语句
If TArrCon(I).FieldType = 205 Or UCase$(TypeName(TArrCon(I).FrmCon)) = UCase$("PictureBox") _
Or UCase$(TypeName(TArrCon(I).FrmCon)) = UCase$("Image") Or UCase$(TypeName(TArrCon(I).FrmCon)) = UCase$("SMPICBOX") Then '排除IMAGE字段
'/If tArrCon(I).FieldType <> 205 Then '排除IMAGE字段
Else
TmpVal = Trim$(CT.ToStr(TArrCon(I).FrmCon)) '取值
FileSum = FileSum & "[" & TArrCon(I).FieldName & "],"
If Len(TmpVal) = 0 Then '对空或NULL的处理
Select Case TArrCon(I).FieldType '数据类型
Case 2, 3, 4, 5, 6, 17, 131 '数值类型
If TArrCon(I).FieldIsNull <> 0 Then '可接受NULL
FldVal = FldVal & "NULL,"
Else
FldVal = FldVal & "0,"
End If
Case 135 '日期时间
If TArrCon(I).FieldIsNull <> 0 Then '可接受NULL
FldVal = FldVal & "NULL,"
Else
If DbStyle = "MDB" Then
FldVal = FldVal & "#" & Now() & "#,"
Else
FldVal = FldVal & "'" & Now() & "',"
End If
End If
Case Else '其它类型
If TArrCon(I).FieldIsNull <> 0 Then
FldVal = FldVal & "NULL,"
Else
FldVal = FldVal & "'',"
End If
End Select
Else
Select Case TArrCon(I).FieldType
Case 2, 3, 4, 5, 6, 17, 131 '数值类型
FldVal = FldVal & "" & TmpVal & ","
Case 135
If DbStyle = "MDB" Th

en
FldVal = FldVal & "#" & TmpVal & "#,"
Else
FldVal = FldVal & "'" & TmpVal & "',"
End If
Case Else '其它类型
FldVal = FldVal & "'" & CT.DetSem(TmpVal) & "',"
End Select
End If
End If
End If
Next I

FldVal = Left$(FldVal, Len(FldVal) - 1)
FileSum = Left$(FileSum, Len(FileSum) - 1)
StrSql = "INSERT INTO [" & DateTabName & "] (" & FileSum & ") VALUES (" & FldVal & ")"
FldVal = ""
GetFrmIntoSql = IIf(Err.Number = 0, StrSql, "")
Err.Clear
End Function

'
'从窗体的控件中生成 SQL (UPDATE)
'函数名:GetFrmUpSql
'参数: ArrCon() DATAFRM类型数组,DateTabName 目标数据表名,WhereStr 更新条件
'返回值:UPDATA Sql 语句
'例: FrmSql=GetFrmUpSql(MeArrCon,"AchGoods","Where gdsid='001'")

Public Function GetFrmUpSql(ByRef ArrCon() As SmCtrlCorRs, _
DateTabName As String, _
WhereStr As String) As String
Dim I As Long, StrSql As String
Dim TmpVal As Variant
Dim FldVal As String
Dim FileSum As String

Err.Clear
On Error Resume Next

For I = 0 To UBound(ArrCon, 1)
If UCase$(Mid$(ArrCon(I)https://www.wendangku.net/doc/925451052.html,, 4, 1)) = "W" Then '将具有写标志的控件组合成SQL语句
If ArrCon(I).FieldType = 205 Or UCase$(TypeName(ArrCon(I).FrmCon)) = UCase$("PictureBox") _
Or UCase$(TypeName(ArrCon(I).FrmCon)) = UCase$("Image") Or UCase$(TypeName(ArrCon(I).FrmCon)) = UCase$("SMPICBOX") Then '排除IMAGE字段
'/If ArrCon(I).FieldType <> 205 Then '排除IMAGE字段
Else
TmpVal = Trim$(CT.ToStr(ArrCon(I).FrmCon))
If Len(TmpVal) = 0 Then '对空或NULL的处理
Select Case ArrCon(I).FieldType
Case 2, 3, 4, 5, 6, 17, 131 '数值类型
If ArrCon(I).FieldIsNull <> 0 Then '可按受NULL
FldVal = FldVal & ",[" & ArrCon(I).FieldName & "]=NULL"
Else
FldVal = FldVal & ",[" & ArrCon(I).FieldName & "]=0"
End If
Case 135 '日期
If ArrCon(I).FieldIsNull <> 0 Then '可接受NULL
FldVal = FldVal & ",[" & ArrCon(I).FieldName & "]=NULL"
Else
If DbStyle = "MDB" Then
FldVal = F

ldVal & ",[" & ArrCon(I).FieldName & "]=#" & Now() & "#"
Else
FldVal = FldVal & ",[" & ArrCon(I).FieldName & "]='" & Now() & "'"
End If
End If
Case Else '其它类型
If ArrCon(I).FieldIsNull <> 0 Then
FldVal = FldVal & ",[" & ArrCon(I).FieldName & "]=NULL"
Else
FldVal = FldVal & ",[" & ArrCon(I).FieldName & "]=''"
End If
End Select
Else
Select Case ArrCon(I).FieldType
Case 2, 3, 4, 5, 6, 17, 131 '数值类型
FldVal = FldVal & ",[" & ArrCon(I).FieldName & "]=" & TmpVal
Case 135
If DbStyle = "MDB" Then
FldVal = FldVal & ",[" & ArrCon(I).FieldName & "]=#" & TmpVal & "#"
Else
FldVal = FldVal & ",[" & ArrCon(I).FieldName & "]='" & TmpVal & "'"
End If
Case Else '其它类型
FldVal = FldVal & ",[" & ArrCon(I).FieldName & "]='" & CT.DetSem(TmpVal) & "'"
End Select
End If
End If
End If
Next

FldVal = " Set " & Right$(FldVal, Len(FldVal) - 1) & " " & WhereStr
StrSql = "UpDate [" & DateTabName & "]" & FldVal
GetFrmUpSql = IIf(Err.Number = 0, StrSql, "")
FldVal = "": StrSql = ""
Err.Clear
End Function

'
'对窗体的所有控件赋值
'函数名:SetFrmCtrlValue
'参数: MRs 源记录集,SetConArr DATAFRM类型数组
'返回值:
'例: CALL SetFrmCtrlValue(RS,MEARRCON)

Public Function SetFrmCtrlValue(ByRef Rs As ADODB.Recordset, _
ByRef SetConArr() As SmCtrlCorRs) As Boolean
Dim N As Long
Dim MRs As New ADODB.Recordset
Dim ConTmp As Control
Dim TmpVal As String
Dim TmpFldName As String
Dim TP As Picture

Err.Clear
On Error Resume Next

Set TP = Nothing
Set MRs = Rs.Clone
If MRs.EOF And MRs.BOF Then
MRs.AddNew
End If

For N = 0 To UBound(SetConArr, 1)
Set ConTmp = SetConArr(N).FrmCon
TmpFldName = SetConArr(N).FieldName

If UCase$(TypeName(ConTmp)) = UCase$("OptionButton") Then
ConTmp = CT.ToBol(MRs.Fields(TmpFldName))
ElseIf UCase$(TypeName(ConTmp

)) = UCase$("CheckBox") Then
ConTmp = CT.ToLng(MRs.Fields(TmpFldName))
ElseIf SetConArr(N).FieldType = 205 Or UCase$(TypeName(ConTmp)) = UCase$("PictureBox") Or UCase$(TypeName(ConTmp)) = UCase$("Image") Or UCase$(TypeName(ConTmp)) = UCase$("SMPICBOX") Then
'/IMAGE字段要另行处理.在这里先清除原先图片
ConTmp.Picture = TP: Set ConTmp.Picture = Nothing
ElseIf SetConArr(N).FieldType = 135 Then '日期
TmpVal = CT.ToStr(MRs.Fields(TmpFldName))
If Len(TmpVal) > 0 And IsDate(TmpVal) Then
If UCase$(Mid$(https://www.wendangku.net/doc/925451052.html,, 5, 1)) = "T" Then '时间
ConTmp = Format$(TmpVal, P_UserDataFmt.TimeFmt)
Else '日期
ConTmp = Format$(TmpVal, P_UserDataFmt.DateFmt)
End If
Else
Err.Clear: ConTmp = ""
If Err.Number <> 0 Then '如果不能为NULL
If UCase$(Mid$(https://www.wendangku.net/doc/925451052.html,, 5, 1)) = "T" Then '时间
ConTmp = Format$(Now(), P_UserDataFmt.TimeFmt)
Else '日期
ConTmp = Format$(Now(), P_UserDataFmt.DateFmt)
End If
End If
End If
Else
If UCase$(Mid$(https://www.wendangku.net/doc/925451052.html,, 5, 1)) = "F" Then '如果是浮点数.
ConTmp = Format$(Val(CT.ToStr(MRs.Fields(TmpFldName))), "0.############")
Else
ConTmp = CT.ToStr(MRs.Fields(TmpFldName))
End If
End If
Next
SetFrmCtrlValue = (Err.Number = 0)

If MRs.State = adStateOpen Then
MRs.Close
Set MRs = Nothing
End If
Err.Clear
Set ConTmp = Nothing
'Errhan:

' If Err.Number <> 0 Then
' MsgBox Error(Err.Number) & ":" & TmpFldName
' End If
End Function

'
'对窗体所有控件值之和
'函数名:GetAddStr
'参数: SetConArr DATAFRM类型数组
'返回值:字符串
'例: CALL GetAddStr(MEARRCON)
'注:主要用来判断值是否改变.

Public Function GetAddStr(ByRef SetConArr() As SmCtrlCorRs) As String
Dim N As Long
Dim ConTmp As Control
Dim ReturnVal As String

Err.Clear
On Error Resume Next

For N = 0 To UBound(SetConArr, 1)
Set ConTmp = SetConArr(N).FrmCon
If UCase$(TypeName(ConTmp)) = UCase$("PictureBox") Or UCase$(TypeName(ConTmp)) = UCase$("Image") Or UCase$(TypeName(ConTmp)) = UCase$("SMPICBOX") Then
ReturnVal = ReturnVal & ConTmp.Tag
Else
ReturnVa

l = ReturnVal & CT.ToStr(ConTmp)
End If
Next
GetAddStr = IIf(Err.Number = 0, ReturnVal, "")
Set ConTmp = Nothing
Err.Clear
End Function

'
'清空窗体中所有与数据库相关控件的数据
'函数名:ClearFrmCtrlValue
'参数: SetConArr DATAFRM类型数组
'返回值:
'例: CALL ClearFrmCtrlValue(MEARRCON)

Public Function ClearFrmCtrlValue(ByRef SetConArr() As SmCtrlCorRs) As Boolean
Dim N As Long
Dim ConTmp As Control
Dim TP As Picture '清除图片框用.

Err.Clear
On Error Resume Next

Set TP = Nothing
For N = 0 To UBound(SetConArr, 1)
Set ConTmp = SetConArr(N).FrmCon
If UCase$(TypeName(ConTmp)) = UCase$("OptionButton") Then
ConTmp = False
ElseIf UCase$(TypeName(ConTmp)) = UCase$("CheckBox") Then
ConTmp = 0
ElseIf UCase$(TypeName(ConTmp)) = UCase$("PictureBox") Or UCase$(TypeName(ConTmp)) = UCase$("Image") Or UCase$(TypeName(ConTmp)) = UCase$("SMPICBOX") Then
ConTmp.Picture = TP: Set ConTmp.Picture = Nothing
ElseIf UCase$(TypeName(ConTmp)) = UCase$("DTPicker") Or UCase$(TypeName(ConTmp)) = UCase$("MonthView") Then
Err.Clear: ConTmp = ""
If Err.Number <> 0 Then
ConTmp = Now()
End If
Else
ConTmp = ""
End If
Next
ClearFrmCtrlValue = (Err.Number = 0)
Set ConTmp = Nothing
Err.Clear
End Function

'
'读写二进制数据(流)
'函数名:AdoStream
'参数: P_Cnn ADODB连接,TabName 目标数据表,FldName 目标字段,WhereStr 更新条件,
' FileName 源文件名或由流生成的文件名,RsStyle 记录集的操作类型.W:File to Recode,R:Recode to File
'返回值:
'例: CALL AdoStream(P_Cnn,"AchGoods","GdsPhoto","Where gdsid='001'","C:\Tmp.Bmp","W")

Public Function AdoStream(P_Cnn As ADODB.Connection, _
TabName As String, _
FldName As String, _
Optional WhereStr As String = "", _
Optional Filename As String, _
Optional RsStyle As SmRsType = RsWrite) As String

Dim StrSql As String
Dim TmpFileName As String
Dim Rs As New ADODB.Recordset
Dim AdoSem As New ADODB.Stream
Dim ReturnVal As String
Dim WorkPath As String
Dim RsType As Long
Dim RsStyleStr As String

Err.Clear
On Error Resume Next

WorkPath = App.Path

If P_Cnn.State <> 1 Then P_Cnn.Open

If Right$(WorkPath, 1) <> "\" Then WorkPath = WorkPath & "\"
ReturnVal = ""
AdoSem.Type = adTypeBinary '流数据类型
AdoSem.Open

'打开流
'/-----------------------------------------------------------
'将流写入记录集
RsType = RsStyle
RsStyleStr = Choose(RsType, "W", "R")
If RsStyleStr = "W" Then
If Left$(Trim$(UCase$(WhereStr)), Len("where")) <> UCase$("where") Then WhereStr = " Where " & Trim$(WhereStr)
StrSql = "Select Top 1 [" & TabName & "].[" & FldName & "] From [" & TabName & "] " & WhereStr
Set Rs = RsOpen(P_Cnn, StrSql, False) '连接式记录集
If Not (Rs.EOF And Rs.BOF) Then
Rs.MoveFirst
AdoSem.LoadFromFile Filename '将文件LOAD到流
DoEvents
Rs.Fields(FldName).AppendChunk AdoSem.Read
Rs.Update
End If
AdoStream = ""
ElseIf RsStyle = "R" Then
'/将流从记录集中取出
If Len(Trim$(Filename)) = 0 Then Filename = "TmpFile.Bmp"
If Len(Trim$(Dir$(TmpFileName, vbNormal + vbHidden))) > 0 Then Kill Filename
If Left$(Trim$(UCase$(WhereStr)), Len("where")) <> UCase$("where") Then WhereStr = " Where " & Trim$(WhereStr)

StrSql = "Select Top 1 [" & TabName & "].[" & FldName & "] From [" & TabName & "] " & WhereStr
Set Rs = RsOpen(P_Cnn, StrSql)
If Not (Rs.EOF And Rs.BOF) Then
Rs.MoveFirst
If Not (IsNull(Rs.Fields(FldName))) Then
TmpFileName = WorkPath & Filename
AdoSem.Write Rs.Fields(FldName).GetChunk(Rs.Fields(FldName).ActualSize)
DoEvents
AdoSem.SaveToFile TmpFileName, IIf(Len(Trim$(Dir$(TmpFileName, vbNormal + vbHidden))) > 0, adSaveCreateOverWrite, adSaveCreateNotExist)
AdoStream = TmpFileName
Else
AdoStream = ""
End If
Else
AdoStream = ""
End If
End If

If AdoSem.State = adStateOpen Then
AdoSem.Close
Set AdoSem = Nothing
End If

If Rs.State = adStateOpen Then
Rs.Close
Set Rs = Nothing
End If
Err.Clear
End Function

'将二进制文件添加到数据库中(该记录必须在存在)
'函数名:FileToRecode
'参数: P_Cnn ADODB连接,TabName 目标数据表,FldName 目标字段,WhereStr 更新条件,FileName 源文件名
'返回值:
'例: CALL FileToRecode(P_Cnn,"AchGoods","GdsPhoto","Where gdsid='001'","C:\Tmp.Bmp")
Public Function FileToRecode(ByRef P_Cnn As ADODB.Connection, _
TabName As String, _
FldName As String, _
WhereStr As String, _
Filename As String) As Boolean

Dim RsB As New ADODB.Recordset
Dim Person_name As String
Dim StrSql As String

Dim File_Num As String
Dim File_Length As String
Dim Bytes() As Byte
Dim Num_Blo

cks As Long
Dim Left_Over As Long
Dim Block_Num As Long

Err.Clear
On Error Resume Next

File_Num = FreeFile
Filename = Trim$(Filename)

If P_Cnn.State <> 1 Then P_Cnn.Open

If Len(Dir$(Filename)) = 0 Or Len(Filename) = 0 Then FileToRecode = False: Exit Function

Open Filename For Binary Access Read As #File_Num
File_Length = LOF(File_Num) '取文件大小
If File_Length > 0 Then
Num_Blocks = File_Length / Block_Size
Left_Over = File_Length Mod Block_Size

If Left$(Trim$(UCase$(WhereStr)), Len("where")) <> UCase$("where") Then WhereStr = "Where " & Trim$(WhereStr)
StrSql = "Select Top 1 [" & TabName & "].[" & FldName & "] From [" & TabName & "] " & WhereStr
Set RsB = RsOpen(P_Cnn, StrSql, False) '连接式记录集
If Not (RsB.EOF And RsB.BOF) Then

'/ '不分块写
'/ ReDim Bytes(File_Length)
'/ Get #File_Num, , Bytes()
'/ DoEvents
'/ RsB.Fields(FldName).AppendChunk Bytes()

'/分块写
ReDim Bytes(Block_Size)
For Block_Num = 1 To Num_Blocks
Get #File_Num, , Bytes()
RsB.Fields(FldName).AppendChunk Bytes()
Next

If Left_Over > 0 Then
ReDim Bytes(Left_Over)
Get #File_Num, , Bytes()
RsB.Fields(FldName).AppendChunk Bytes()
End If
RsB.Update
DoEvents
End If
If RsB.State = adStateOpen Then
RsB.Close
Set RsB = Nothing
End If
End If
Close #File_Num
Erase Bytes
FileToRecode = (Err.Number = 0)
Err.Clear
End Function

'
'将二进制数据从记录中取出
'函数名:RecodeToFile
'参数: P_Cnn ADODB连接,TabName 源数据表,FldName 源字段名, WhereStr 取字段条件,FileType 生成临时文件的类型
'返回值:'一个临时文件名
'例: GetTmpFile=RecodeToFile(P_Conn,"achgoods","achphoto","where gdsid='001',"bmp")

Public Function RecodeToFile(ByRef P_Cnn As ADODB.Connection, _
TabName As String, _
FldName As String, _
WhereStr As String, _
Optional FileType As String = "Bmp") As String

Dim Rs As New ADODB.Recordset
Dim StrSql As String

Dim Bytes() As Byte
Dim File_Name As String
Dim File_Num As Integer
Dim File_Length As Long
Dim Num_Blocks As Long
Dim Left_Over As Long
Dim Block_Num As Long
Dim WorkPath As String
Dim TmpDir As New SmSysCls

Err.