VB中对数据库的各种操作.

时间：2021-07-02 13:03:20
  • '
  • '数据库操作(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_Cnn.CommandTimeout = 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=" & Timerout & ";"
  •     
  •     P_Cnn.ConnectionTimeout = Timerout
  •     P_Cnn.CommandTimeout = 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
  •          DbC.CommitTrans
  •     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_Cnn.CommitTrans
  •     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 & "#,"
  •                                        Else
  •                                           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 = Frm.Name
  • '
  • '       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 = FrmCon.Name
  •         '/将图片框控件排除
  •         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).FrmCon.Name
  •              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).FrmCon.Name, 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" Then
  •                                   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).FrmCon.Name, 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 = FldVal & ",[" & 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$(ConTmp.Name, 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$(ConTmp.Name, 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$(ConTmp.Name, 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
  •                 ReturnVal = 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_Blocks 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.Clear
  •     On Error Resume Next
  •     
  •      WorkPath = TmpDir.GetFolder(SmWinTempDirectory)
  •      If Dir$(WorkPath, vbDirectory) = "" Then WorkPath = App.Path
  •      If Right$(WorkPath, 1) <> "/" Then WorkPath = WorkPath & "/"
  •     
  •      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 Rs.BOF And Rs.EOF Then Exit Function
  •      
  •      If P_Cnn.State <> 1 Then P_Cnn.Open
  •      
  •      If Not IsNull(Rs.Fields(FldName)) Then
  •          File_Name = WorkPath & "TmpFile." & FileType
  •          If Len(Dir(File_Name)) <> 0 Then Kill File_Name
  •          File_Num = FreeFile
  •          Open File_Name For Binary As #File_Num
  •              File_Length = CT.ToLng(Rs.Fields(FldName).ActualSize) '取字段的实际大小
  • '/不分块读写
  • '/             If File_Length > 0 Then
  • '/                Bytes() = Rs.Fields(FldName).GetChunk(File_Length)
  • '/                Put #File_Num, , Bytes()
  • '/             Else
  • '/                Err = -1
  • '/             End If
  • '/分块读写
  •              Num_Blocks = File_Length / Block_Size
  •              Left_Over = File_Length Mod Block_Size
  •              For Block_Num = 1 To Num_Blocks
  •                  Bytes() = Rs.Fields(FldName).GetChunk(Block_Size)
  •                  Put #File_Num, , Bytes()
  •              Next
  •              If Left_Over > 0 Then
  •                  Bytes() = Rs.Fields(FldName).GetChunk(Left_Over)
  •                  Put #File_Num, , Bytes()
  •              End If
  •              Erase Bytes
  •          Close #File_Num
  •          
  •         If Rs.State = adStateOpen Then
  •            Rs.Close
  •            Set Rs = Nothing
  •         End If
  •             
  •          Erase Bytes
  •     End If
  •     RecodeToFile = IIf(Err.Number = 0, File_Name, "")
  •     Set TmpDir = Nothing
  •     Err.Clear
  • End Function
  • '
  • '对组合框赋值(直接从数据库取值,如果有多个值,则只取第一个值.)
  • '函数名:SetFrmCtrlValue
  • '参数:  P_Cnn ADODB连接,StrSql 取值SQL语句,CtrFiedList 动态参数列表
  • '返回值:
  • '例:    CALL SetGroupVal(P_Cnn,"Select AchGds.* From AchGds Where GdsID='001'",TxtWNGdsID,"GdsID",TxtWNGdsName,"GdsName")
  • '*注:动态参数列表(CtrFiedList)的奇数位是 目标名,偶数位 是对应字段名.
  • Public Function SetGroupVal(ByRef P_Cnn As ADODB.Connection, _
  •                             StrSql As String, _
  •                             ParamArray CtrFiedList() As Variant) As Boolean
  •        
  •        Dim Rs As New ADODB.Recordset
  •        Dim N As Long
  •        Dim id As Long
  •        Dim ConFiedArr() As SmPutGroup
  •        Dim ReturnVal As Boolean
  •        
  •        Err.Clear
  •        On Error Resume Next
  •        
  •        ReturnVal = False
  •        
  •        If P_Cnn.State <> 1 Then P_Cnn.Open
  •        
  •        Set Rs = RsOpen(P_Cnn, StrSql)
  •        If Not (Rs.EOF And Rs.BOF) Then
  •             Rs.MoveFirst
  •             id = 0
  •             '/分解控件与字段名
  •             For N = 0 To UBound(CtrFiedList, 1)
  •                 If N Mod 2 = 0 Then
  •                    id = id + 1
  •                    ReDim Preserve ConFiedArr(id - 1)
  •                    '/控件
  •                    Set ConFiedArr(id - 1).FrmControl = CtrFiedList(N)
  •                 Else
  •                    '/字段名
  •                    ConFiedArr(id - 1).FldName = CtrFiedList(N)
  •                 End If
  •             Next
  •             '/对控件赋值
  •             For N = 0 To UBound(ConFiedArr, 1)
  •                 ConFiedArr(N).FrmControl = CStr("" & (Rs.Fields(ConFiedArr(N).FldName)))
  •             Next
  •             ReturnVal = True
  •        Else
  •             ReturnVal = False
  •        End If
  •        SetGroupVal = ReturnVal
  •        
  •         If Rs.State = adStateOpen Then
  •            Rs.Close
  •            Set Rs = Nothing
  •         End If
  •         Err.Clear
  • End Function
  • '
  • '返回单个数据字段值.
  • '函数名:SetFrmCtrlValue
  • '参数:  P_Cnn ADODB连接,DbTabName 源数据表名,FldName 源数据字段名,WhereStr 取值的条件语句
  • '返回值:相对应的字段值
  • '例:    GdsNameVal=GetOneValue(P_CNN,"ACHGOODS","GDSNAME","WHERE GDSID='001'")
  • Public Function GetOneValue(ByRef P_Cnn As ADODB.Connection, _
  •                             DbTabname As String, _
  •                             FldName As String, _
  •                             WhereStr As String) As String
  •        Dim StrSql As String
  •        Dim Rs As New ADODB.Recordset
  •               
  •        Err.Clear
  •        On Error Resume Next
  •        
  •        If P_Cnn.State <> 1 Then P_Cnn.Open
  •        
  •        If Left$(Trim$(UCase$(WhereStr)), Len("where")) <> UCase$("where") Then WhereStr = "Where " & Trim$(WhereStr)
  •        StrSql = "Select Top 1 [" & DbTabname & "].[" & FldName & "] From [" & DbTabname & "] " & WhereStr
  •        Set Rs = RsOpen(P_Cnn, StrSql)
  •        If Not (Rs.EOF And Rs.BOF) Then
  •           Rs.MoveFirst
  •           GetOneValue = CT.ToStr(Rs.Fields(FldName))
  •        Else
  •           GetOneValue = ""
  •        End If
  •         If Rs.State = adStateOpen Then
  •            Rs.Close
  •            Set Rs = Nothing
  •         End If
  •         Err.Clear
  • End Function
  • '
  • '删除记录
  • '函数:KillRecode
  • '参数:FldName 字段名,FldVal 字段值,TabName 表名
  • '
  • Function KillRecode(ByRef P_Cnn As ADODB.Connection, _
  •                     TabName As String, _
  •                     FldName As String, _
  •                     FldVal As String)
  •          Dim StrSql As String
  •          
  •          If P_Cnn.State <> 1 Then P_Cnn.Open
  •          
  •          StrSql = "Delete " & TabName & "  From " & TabName & " Where " & FldName & "='" & FldVal & "'"
  •          P_Cnn.Execute StrSql
  •          Err.Clear
  • End Function
  • '
  • '取最大单号
  • '前二位.单据类型.+四位年+二位月+二位日+4位单据流水号
  • '函数:GetMaxBillID
  • '参数:FldName 字段名(BillID),BillStyle 单据类型,TabName 表名
  • '返回值:可用最大单号
  • Function GetMaxBillID(ByRef P_Cnn As ADODB.Connection, _
  •                       TabName As String, _
  •                       FldName As String, _
  •                       BillStyle As String) As String
  •          
  •          Dim BillSD As String
  •          Dim StrSql As String
  •          Dim Rs As New ADODB.Recordset
  •          Dim BillNo As Long
  •          Dim NewBillID As Long
  •          Dim lLen As Long
  •          Dim ReturnVal As String
  •          Dim RNum As Long
  •          Dim RLen As Long
  •          Dim FmtStr As String
  •          Dim N As Long
  •          
  •          Err.Clear
  •          On Error Resume Next
  •          
  •          If P_Cnn.State <> 1 Then P_Cnn.Open
  •          
  •          BillSD = BillStyle & Format$(Date, "YYYYMMDD")
  •          '/--------------------------------------------------
  •          lLen = Len(BillSD): RLen = 4 '单据流水号位数
  •          '/--------------------------------------------------
  •          For N = 1 To RLen
  •              FmtStr = FmtStr & "0"
  •          Next
  •          '/--------------------------------------------------
  •          StrSql = "Select (Max(" & FldName & ")) AS MaxID From " & TabName & " Where LEFT(" & FldName & "," & lLen & ")='" & BillSD & "'"
  •          Set Rs = RsOpen(P_Cnn, StrSql)
  •          If Not (Rs.EOF And Rs.BOF) Then
  •             If Len(CT.ToStr(Rs.Fields("MaxID"))) > 0 Then
  •                RNum = Right$(CT.ToStr(Rs.Fields("MaxID")), RLen)
  •             Else
  •                RNum = 0
  •             End If
  •             NewBillID = CT.ToLng(RNum) + 1
  •          Else
  •             NewBillID = 1
  •          End If
  •         If Rs.State = adStateOpen Then
  •            Rs.Close
  •            Set Rs = Nothing
  •         End If
  •          ReturnVal = BillSD & "-" & Format$(NewBillID, FmtStr)
  •          GetMaxBillID = IIf(Err.Number = 0, ReturnVal, "")
  •          Err.Clear
  • End Function
  • '
  • '压缩MDB数据库
  • '函数名:ZipMdb
  • '参数:P_Cnn ADODB连接,SourFileName 源文件名,ObjFileName 目标文件名,
  • '     Provider Provider参数(视JET版而定,默认是4.0),UserID 用户名,
  • '     UserPwd 密码
  • '返回值:TRUE 成功,FALSE 失败.
  • Public Function ZipMdb(P_Cnn As ADODB.Connection, _
  •                        MdbFileName As String, _
  •                        Optional Provider As String = "Microsoft.Jet.OLEDB.4.0", _
  •                        Optional UserID As String = "admin", _
  •                        Optional UserPwd As String = "") As Boolean
  •     
  •     Dim Yjro As New JRO.JetEngine
  •     Dim WorkPath As String
  •     Dim TmpName As String
  •     Dim FileCon As SmFileCls
  •      
  •     Err.Clear
  •     On Error Resume Next
  •     '/关闭连接
  •     P_Cnn.Close: Set P_Cnn = Nothing
  •     DoEvents
  •     WorkPath = FileCon.FilePath(MdbFileName)
  •     TmpName = WorkPath & "mdbTmp.bak"
  •     '/-------------------------------
  •     DoEvents
  •     '/压缩
  •     Yjro.CompactDatabase "Provider=" & Provider & ";Data Source=" & MdbFileName & ";" & _
  •                          "Jet OLEDB:Database Password=" & UserPwd & ";" & _
  •                          "User ID=" & UserID & ";", _
  •                          "Provider=" & Provider & ";Data Source=" & TmpName & ";" & _
  •                          "Jet OLEDB:Database Password=" & UserPwd & ";" & _
  •                          "User ID=" & UserID & ";"
  •     DoEvents
  •     '/删除旧文件，将压缩后的文件ＣＯＰＹ到旧位置
  •     If FileCon.FileCheck(MdbFileName) And FileCon.FileCheck(TmpName) Then
  •         Kill MdbFileName
  •         DoEvents
  •         Call FileCopy(TmpName, MdbFileName)
  •         DoEvents
  •         Kill TmpName
  •         DoEvents
  •         '/重新连接
  •         Call CreateMdbConn(P_Cnn, MdbFileName, , UserID, UserPwd)
  •     Else
  •         Err.Number = -1
  •     End If
  •     Set Yjro = Nothing
  •     Set FileCon = Nothing
  •     Err.Clear
  •     ZipMdb = (Err.Number = 0)
  •     Err.Clear
  • End Function
  • '
  • '恢复和备份MDB数据库
  • '函数名:BakResumeMdb
  • '参数:P_Cnn ADODB连接,SourFileName 源文件名,ObjFileName 目标文件名,
  • '     Provider Provider参数(视JET版而定,默认是4.0),UserID 用户名,
  • '     UserPwd 密码,WorkType 操作类型(0 备份,1 恢复)
  • '返回值:TRUE 成功,FALSE 失败.
  • '注:当WorkType=0时,源文件名是要备份文件,目标文件名是备份文件.
  • '   当WorkType=1时,源文件名是备份文件,目标文件名要恢复的文件.
  • Public Function BakResumeMDB(P_Cnn As ADODB.Connection, _
  •                        SourFileName As String, _
  •                        ObjFileName As String, _
  •                        Optional Provider As String = "Microsoft.Jet.OLEDB.4.0", _
  •                        Optional UserID As String = "admin", _
  •                        Optional UserPwd As String = "", _
  •                        Optional WorkType As Long = 0) As Boolean
  •     
  •     Dim Yjro As New JRO.JetEngine
  •     Dim WorkPath As String
  •     Dim FileCon As New SmFileCls
  •     
  •     Err.Clear
  •     On Error Resume Next
  •     '/关闭连接
  •     P_Cnn.Close: Set P_Cnn = Nothing
  •     DoEvents
  •     '/-------------------------------
  •     '/压缩
  •     Yjro.CompactDatabase "Provider=" & Provider & SourFileName & ";" & _
  •                          "Jet OLEDB:Database Password=" & UserPwd & ";" & _
  •                          "User ID=" & UserID & ";", _
  •                          "Provider=" & Provider & ";Data Source=" & ObjFileName & ";" & _
  •                          "Jet OLEDB:Database Password=" & UserPwd & ";" & _
  •                          "User ID=" & UserID & ";"
  •     DoEvents
  •     '/删除旧文件，将压缩后的文件ＣＯＰＹ到旧位置
  •     If Not (FileCon.FileCheck(SourFileName) And FileCon.FileCheck(ObjFileName)) Then
  •        If WorkType = 0 Then
  •           '/备份。
  •           Call CreateMdbConn(P_Cnn, SourFileName, , UserID, UserPwd)
  •        Else
  •           '/恢复
  •           Call CreateMdbConn(P_Cnn, ObjFileName, , UserID, UserPwd)
  •        End If
  •        Err.Number = -1
  •     End If
  •     Set FileCon = Nothing
  •     Set Yjro = Nothing: Err.Clear
  •     BakResumeMDB = (Err.Number = 0)
  •     Err.Clear
  • End Function
  • '
  • '解读身份证信息
  • '函数名:GetIDCard
  • '参数:P_Cnn ADODB连接,IDCode 身份证编号,RevCodeInfo EmpCodeInfo(用于返回),
  • '返回值:无
  • Public Function GetIDCard(ByRef P_Cnn As ADODB.Connection, IDCode As String, ByRef RevCodeInfo As EmpCodeInfo)
  •         Dim Rs As New ADODB.Recordset
  •         Dim StrSql As String
  •         Dim I As Long
  •         Dim TAdd(6) As String
  •         Dim AddStr(6) As String
  •         Dim UserAdd As String
  •         Dim BirthStr As String
  •         Dim SexStr As String
  •         
  •         Err.Clear
  •         On Error Resume Next
  •         
  •         AddStr(0) = Left$(IDCode, 2) & "0000" '省
  •         AddStr(1) = Left$(IDCode, 4) & "00"   '市
  •         AddStr(2) = Left$(IDCode, 6)          '县及县级市
  •         UserAdd = ""
  •         
  •         If P_Cnn.State <> 1 Then P_Cnn.Open
  •         
  •         '取籍贯
  •         For I = 0 To UBound(AddStr)
  •             If Len(AddStr(I)) > 0 Then
  •                StrSql = "SELECT * FROM [Reglism] Where Code='" & AddStr(I) & "'"
  •                Set Rs = Nothing
  •                Rs.Open StrSql, P_Cnn, adOpenStatic, adLockReadOnly
  •                If Not (Rs.EOF And Rs.BOF) Then
  •                   TAdd(I) = "" & Rs.Fields("Name")
  •                   UserAdd = UserAdd & Rs.Fields("Name")
  •                End If
  •             End If
  •         Next
  •         RevCodeInfo.NativePlace = UserAdd
  •         '取电话区号
  •         For I = UBound(TAdd) To 0 Step -1
  •             If Len(TAdd(I)) > 1 Then
  •                 TAdd(I) = Left$(TAdd(I), 2)
  •                 StrSql = "SELECT * FROM [PhoCode] WHERE [Name] like '" & TAdd(I) & "%'"
  •                 Set Rs = Nothing
  •                 Rs.Open StrSql, P_Cnn, adOpenStatic, adLockReadOnly
  •                 If Not (Rs.EOF And Rs.BOF) Then
  •                    Rs.MoveFirst
  •                    RevCodeInfo.PhoCode = Format$(Rs.Fields("Code"), "0000")
  •                    Exit For
  •                 End If
  •             End If
  •         Next
  •         '取邮政编码
  •         For I = UBound(TAdd) To 0 Step -1
  •             If Len(TAdd(I)) > 1 Then
  •                 TAdd(I) = Left$(TAdd(I), 2)
  •                 StrSql = "SELECT * FROM [MailCode] WHERE [Name] Like '" & TAdd(I) & "%'"
  •                 Set Rs = Nothing
  •                 Rs.Open StrSql, P_Cnn, adOpenStatic, adLockReadOnly
  •                 If Not (Rs.EOF And Rs.BOF) Then
  •                    Rs.MoveFirst
  •                    RevCodeInfo.MailCode = Format$(Rs.Fields("Code"), "0000")
  •                    Exit For
  •                 End If
  •             End If
  •         Next
  •         '生日/性别
  •         If Len(IDCode) = 15 Then '旧身份证号码.
  •             BirthStr = Mid$(IDCode, 7, Len(IDCode) - 6 - 3) '出生日期
  •             BirthStr = "19" & BirthStr
  •             SexStr = CLng(Right$(IDCode, 1)) Mod 2 '顺序码奇数是男.偶数是女
  •         Else                         '新身份证号码.
  •             BirthStr = Mid$(IDCode, 7, Len(IDCode) - 6 - 4) '出生日期
  •             SexStr = CLng(Mid$(IDCode, Len(IDCode) - 3, 3)) Mod 2 '顺序码奇数是男.偶数是女
  •         End If
  •         BirthStr = Left$(BirthStr, 4) & "/" & Mid$(BirthStr, 5, 2) & "/" & Right$(BirthStr, 2)
  •         RevCodeInfo.Birthday = BirthStr
  •         RevCodeInfo.Sex = SexStr
  •         
  •         If Rs.State = adStateOpen Then
  •            Rs.Close
  •            Set Rs = Nothing
  •         End If
  •         Err.Clear
  • End Function
  • Private Sub Class_Initialize()
  •     Dim T As New ClsRev
  •     
  •     Set CT = New SmDataDiap
  •     Call T.GetIniVal
  •     Set T = Nothing
  • End Sub
  • Private Sub Class_Terminate()
  •         On Error Resume Next
  •         Set CT = Nothing
  • End Sub
  • '
  • '取局域网中所有SQL SERVER 服务器名称
  • '函数名:AddSqlServer
  • '参数:
  • '返回值:字符串数组
  • '引用SQLDMO LIB
  • Public Function AddSqlServer() As String()
  • '    Dim Server As SQLDMO.NameList
  • '    Dim appDMO As New SQLDMO.Application
  • '    Dim I As Long
  • '    Dim StrRev() As String
  • '
  • '    On Error Resume Next
  • '
  • '    Set Server = appDMO.ListAvailableSQLServers
  • '    For I = 1 To Server.Count
  • '        ComNNServerName.AddItem Server(I)
  • '        ReDim Preserve StrRev(I)
  • '        StrRev(I) = Server(I)
  • '    Next
  • '    Set Server = Nothing
  • '    Set appDMO = Nothing
  •     
  •     Dim oSQLServerDMOApp   As Object
  •     Dim I   As Integer
  •     Dim namX   As Object
  •     Dim StrRev() As String
  •     
  •     Err.Clear
  •     On Error Resume Next
  •     Set oSQLServerDMOApp = CreateObject("SQLDMO.Application")
  •     If oSQLServerDMOApp Is Nothing Then Exit Function
  •     Set namX = oSQLServerDMOApp.ListAvailableSQLServers
  •     For I = 1 To namX.Count
  •         ReDim Preserve StrRev(I - 1)
  •         StrRev(I - 1) = namX.Item(I)
  •     Next
  •     AddSqlServer = StrRev
  •     Set namX = Nothing
  • End Function
  • '
  • '对TDBGRID表格赋值.
  • Public Function SetGrdGroupVal(ByRef P_Cnn As ADODB.Connection, _
  •                                ByRef MRs As ADODB.Recordset, _
  •                                RepeaFldList As String, _
  •                                StrSql As String, _
  •                                ConAndFiedList As Variant) As Boolean
  •        
  •        Dim Rs As New ADODB.Recordset
  •        Dim N As Long
  •        Dim id As Long
  •        Dim ConFiedArr() As SmPutGroup
  •        Dim ReturnVal As Boolean
  •         
  •        Dim TRs As New ADODB.Recordset
  •        Dim RepFld() As String
  •         
  •        On Error Resume Next
  •         
  •        If P_Cnn.State <> 1 Then P_Cnn.Open
  •        ReturnVal = False
  •        Set Rs = RsOpen(P_Cnn, StrSql)
  •        If Not (Rs.EOF And Rs.BOF) Then
  •             Rs.MoveFirst
  •             id = 0
  •             '/分解控件与字段名.
  •             For N = 0 To UBound(ConAndFiedList, 1)
  •                 If N Mod 2 = 0 Then
  •                    id = id + 1
  •                    ReDim Preserve ConFiedArr(id - 1)
  •                    '/控件.
  •                    Set ConFiedArr(id - 1).FrmControl = ConAndFiedList(N)
  •                 Else
  •                    '/字段名.
  •                    ConFiedArr(id - 1).FldName = ConAndFiedList(N)
  •                 End If
  •             Next
  •             '/对控件赋值.
  •             MRs.AddNew: MRs.MoveLast
  •             For N = 0 To UBound(ConFiedArr, 1)
  •                 ConFiedArr(N).FrmControl = CStr("" & Rs.Fields(ConFiedArr(N).FldName))
  •             Next
  •             ReturnVal = True
  •        Else
  •             ReturnVal = False
  •        End If
  •        SetGrdGroupVal = ReturnVal
  •         If Rs.State = adStateOpen Then
  •             Rs.Close
  •             Set Rs = Nothing
  •         End If
  •         Err.Clear
  • End Function
  • '从RS到RS赋值.
  • Public Function SetRsToRs(ByRef SourRs As ADODB.Recordset, _
  •                           ByRef ObjRs As ADODB.Recordset, _
  •                           FldList As String, _
  •                           Optional BlnAddNew As Boolean = False) As Boolean
  •        Dim RsB As New ADODB.Recordset
  •        Dim N As Long
  •        Dim id As Long
  •        Dim SpArr() As String
  •        Dim EvaArr() As String
  •        Dim FldArr() As SmGrdGroup
  •        Dim ReturnVal As Boolean
  •        Dim TmpStr() As String
  •         
  •        Err.Clear
  •        On Error Resume Next
  •        ReturnVal = False
  •        If Not (SourRs.EOF And SourRs.BOF) Then
  •             id = 0
  •             SpArr = Split(FldList, ",")
  •             For N = 0 To UBound(SpArr)
  •                 If Len(SpArr(N)) > 0 And InStr(SpArr(N), "=") > 0 Then
  •                     Erase TmpStr
  •                     TmpStr = Split(SpArr(N), "=")
  •                     If Len(TmpStr(0)) > 0 And Len(TmpStr(1)) > 0 Then
  •                         id = id + 1
  •                         ReDim Preserve FldArr(id - 1)
  •                         FldArr(id - 1).ObjFldName = Trim$(TmpStr(0))
  •                         FldArr(id - 1).SourFldName = Trim$((TmpStr(1)))
  •                     End If
  •                 End If
  •             Next
  •             
  •             If UBound(FldArr, 1) > 0 Then
  •                 If BlnAddNew Then ObjRs.AddNew  '新增
  •                 For N = 0 To UBound(FldArr, 1)
  •                     ObjRs.Fields(FldArr(N).ObjFldName) = SourRs.Fields(FldArr(N).SourFldName)
  •                 Next
  •                 ReturnVal = True
  •             Else
  •                 ReturnVal = False
  •             End If
  •             
  •        Else
  •             ReturnVal = False
  •        End If
  •        SetRsToRs = ReturnVal
  •        Err.Clear
  • End Function
  • '
  • '对组合框赋值(直接从数据库取值,如果有多个值,则只取第一个值.)
  • '函数名:SetFrmCtrlValue
  • '参数:  P_Cnn ADODB连接,StrSql 取值SQL语句,ConAndFiedList 动态参数列表(注意,这里的列表是作为一个数组)
  • '返回值:
  • '例:    CALL SetGroupValB(P_Cnn,"Select AchGds.* From AchGds Where GdsID='001'",TxtWNGdsID,"GdsID",TxtWNGdsName,"GdsName")
  • '*注:动态参数列表(CtrFiedList)的奇数位是 目标名,偶数位 是对应字段名.
  • '组合框赋值
  • Public Function SetGroupValB(ByRef P_Cnn As ADODB.Connection, _
  •                             StrSql As String, _
  •                             ConAndFiedList As Variant) As Boolean
  •        Dim Rs As New ADODB.Recordset
  •        Dim N As Long
  •        Dim id As Long
  •        Dim ConFiedArr() As SmPutGroup
  •        Dim ReturnVal As Boolean
  •        
  •        Err.Clear
  •        On Error Resume Next
  •        
  •        ReturnVal = False
  •        If P_Cnn.State <> 1 Then P_Cnn.Open
  •        Set Rs = RsOpen(P_Cnn, StrSql)
  •        If Not (Rs.EOF And Rs.BOF) Then
  •             Rs.MoveFirst
  •             id = 0
  •             '/分解控件与字段名.
  •             For N = 0 To UBound(ConAndFiedList, 1)
  •                 If N Mod 2 = 0 Then
  •                    id = id + 1
  •                    ReDim Preserve ConFiedArr(id - 1)
  •                    '/控件
  •                    Set ConFiedArr(id - 1).FrmControl = ConAndFiedList(N)
  •                 Else
  •                    '/字段名
  •                    ConFiedArr(id - 1).FldName = ConAndFiedList(N)
  •                 End If
  •             Next
  •             '/对控件赋值
  •             For N = 0 To UBound(ConFiedArr, 1)
  •                 ConFiedArr(N).FrmControl = CStr("" & Rs.Fields(ConFiedArr(N).FldName))
  •             Next
  •             ReturnVal = True
  •        Else
  •             ReturnVal = False
  •        End If
  •        SetGroupValB = ReturnVal
  •         If Rs.State = adStateOpen Then
  •             Rs.Close
  •             Set Rs = Nothing
  •         End If
  •         Err.Clear
  • End Function
  • '//数据库排序
  • Public Function DbSort(Rs As ADODB.Recordset, SortFld As String, MdbPath As String) As Recordset
  •         Dim StrSql As String
  •         Dim I As Long
  •         Dim TmpName As String
  •         Dim TRs As New ADODB.Recordset
  •         Dim P_MdbCnn As New ADODB.Connection
  •         
  •         Err.Clear
  •         On Error Resume Next
  •         
  •         Set TRs = Rs.Clone
  •         TmpName = GetTmpName("S")
  •         TmpName = Right$(TmpName, Len(TmpName) - 1)
  •         
  •         If P_MdbCnn.State = adStateClosed Or P_MdbCnn Is Nothing Then
  •             CreateMdbConn P_MdbCnn, MdbPath, , "", ""
  •         End If
  •         
  •         StrSql = "DROP TABLE " & TmpName
  •         P_MdbCnn.Execute StrSql
  •         
  •         With TRs
  •         
  •         StrSql = ""
  •         For I = 0 To .Fields.Count - 1
  •             Select Case .Fields(I).Type
  •                    Case Is = 6 '货币 6
  •                         StrSql = StrSql & .Fields(I).Name & " Money NULL,"
  •                    Case Is = 11 'ACCESS 是/否 11
  •                         StrSql = StrSql & .Fields(I).Name & " VARCHAR(" & .Fields(I).DefinedSize & ") NULL,"
  •                    Case Is = 129 'CHAR
  •                         StrSql = StrSql & .Fields(I).Name & " VARCHAR(" & .Fields(I).DefinedSize & ") NULL,"
  •                    Case Is = 130 'NCHAR
  •                         StrSql = StrSql & .Fields(I).Name & " VARCHAR(" & .Fields(I).DefinedSize & ") NULL,"
  •                    Case Is = 202 'NVARCHAR
  •                         StrSql = StrSql & .Fields(I).Name & " VARCHAR(" & .Fields(I).DefinedSize & ") NULL,"
  •                    Case Is = 200 'VARCHAR
  •                         StrSql = StrSql & .Fields(I).Name & " VARCHAR(" & .Fields(I).DefinedSize & ") NULL,"
  •                    Case Is = 3  'INT
  •                         StrSql = StrSql & .Fields(I).Name & " LONG NULL,"
  •                    Case Is = 17 'TINYINT 字节 Access 17
  •                         StrSql = StrSql & .Fields(I).Name & " LONG NULL,"
  •                    Case Is = 2   'SMALLINT
  •                         StrSql = StrSql & .Fields(I).Name & " LONG NULL,"
  •                    Case Is = 20, 72 'BIGINT 同步复制 ID 72
  •                         StrSql = StrSql & .Fields(I).Name & " LONG NULL,"
  •                    Case Is = 201 'TEXT
  •                         StrSql = StrSql & .Fields(I).Name & " Memo NULL,"
  •                    Case Is = 203 'NTEXT
  •                         StrSql = StrSql & .Fields(I).Name & " Memo NULL,"
  •                    Case Is = 131, 4, 5 'NUMERIC|4,5 单精度型 4双精度型 5
  •                         StrSql = StrSql & .Fields(I).Name & " Numeric NULL,"
  •                    Case Is = 135, 7 'DATETIME  日期/时间 7
  •                         StrSql = StrSql & .Fields(I).Name & " DATETIME NULL,"
  •                    Case Is = 205 'IMAGE
  •                         StrSql = StrSql & .Fields(I).Name & " Image NULL,"
  •                    Case Is = 128 'BINARY
  •                         StrSql = StrSql & .Fields(I).Name & " Memo NULL,"
  •                    Case Is = 204 'VARBINARY
  •                         StrSql = StrSql & .Fields(I).Name & " Memo NULL,"
  •              End Select
  •         Next
  •         
  •         End With
  •         
  •         StrSql = Left$(StrSql, Len(StrSql) - 1)
  •         StrSql = "CREATE TABLE " & TmpName & " (" & StrSql & ")"
  •         P_MdbCnn.Execute StrSql
  •         
  •         InsertIntoDB P_MdbCnn, TmpName, TRs
  •         
  •         StrSql = "SELECT * FROM " & TmpName & " ORDER BY " & SortFld
  •         Set TRs = RsOpen(P_MdbCnn, StrSql)
  •         Set DbSort = TRs.Clone
  •         
  •         StrSql = "DROP TABLE " & TmpName
  •         P_MdbCnn.Execute StrSql
  •         
  •         If TRs.State = adStateOpen Then
  •              TRs.Close
  •              Set TRs = Nothing
  •         End If
  •         
  •         If P_MdbCnn.State = adStateOpen Then
  •             P_MdbCnn.Close
  •             Set P_MdbCnn = Nothing
  •         End If
  •         DbStyle = "SQL"
  •         Err.Clear
  • End Function
  • '//将一个RS保存到一个临时的ACCESS数据库...
  • Public Function SqlToMdb(Rs As ADODB.Recordset, MdbCnn As ADODB.Connection, Optional TabName As String = "") As String
  •         Dim StrSql As String
  •         Dim I As Long
  •         Dim TmpName As String
  •         Dim TRs As New ADODB.Recordset
  •         
  •         Err.Clear
  •         On Error Resume Next
  •         
  •         Set TRs = Rs.Clone
  •         If MdbCnn.State <> 1 Then MdbCnn.Open
  •         
  •         TabName = Trim$(TabName)
  •         If Len(TabName) > 0 Then
  •             TmpName = TabName
  •         Else
  •             TmpName = GetTmpName("S")
  •             TmpName = Right$(TmpName, Len(TmpName) - 1)
  •         End If
  •         
  •         StrSql = "DROP TABLE " & TmpName
  •         MdbCnn.Execute StrSql
  •         
  •         With TRs
  •         
  •         StrSql = ""
  •         For I = 0 To .Fields.Count - 1
  •             Select Case .Fields(I).Type
  •                    Case Is = 6 '货币 6
  •                         StrSql = StrSql & .Fields(I).Name & " Money NULL,"
  •                    Case Is = 11 'ACCESS 是/否 11
  •                         StrSql = StrSql & .Fields(I).Name & " VARCHAR(" & .Fields(I).DefinedSize & ") NULL,"
  •                    Case Is = 129 'CHAR
  •                         StrSql = StrSql & .Fields(I).Name & " VARCHAR(" & .Fields(I).DefinedSize & ") NULL,"
  •                    Case Is = 130 'NCHAR
  •                         StrSql = StrSql & .Fields(I).Name & " VARCHAR(" & .Fields(I).DefinedSize & ") NULL,"
  •                    Case Is = 202 'NVARCHAR
  •                         StrSql = StrSql & .Fields(I).Name & " VARCHAR(" & .Fields(I).DefinedSize & ") NULL,"
  •                    Case Is = 200 'VARCHAR
  •                         StrSql = StrSql & .Fields(I).Name & " VARCHAR(" & .Fields(I).DefinedSize & ") NULL,"
  •                    Case Is = 3  'INT
  •                         StrSql = StrSql & .Fields(I).Name & " LONG NULL,"
  •                    Case Is = 17 'TINYINT 字节 Access 17
  •                         StrSql = StrSql & .Fields(I).Name & " LONG NULL,"
  •                    Case Is = 2   'SMALLINT
  •                         StrSql = StrSql & .Fields(I).Name & " LONG NULL,"
  •                    Case Is = 20, 72 'BIGINT 同步复制 ID 72
  •                         StrSql = StrSql & .Fields(I).Name & " LONG NULL,"
  •                    Case Is = 201 'TEXT
  •                         StrSql = StrSql & .Fields(I).Name & " Memo NULL,"
  •                    Case Is = 203 'NTEXT
  •                         StrSql = StrSql & .Fields(I).Name & " Memo NULL,"
  •                    Case Is = 131, 4, 5 'NUMERIC|4,5 单精度型 4双精度型 5
  •                         StrSql = StrSql & .Fields(I).Name & " Numeric NULL,"
  •                    Case Is = 135, 7 'DATETIME  日期/时间 7
  •                         StrSql = StrSql & .Fields(I).Name & " DATETIME NULL,"
  •                    Case Is = 205 'IMAGE
  •                         StrSql = StrSql & .Fields(I).Name & " Image NULL,"
  •                    Case Is = 128 'BINARY
  •                         StrSql = StrSql & .Fields(I).Name & " Memo NULL,"
  •                    Case Is = 204 'VARBINARY
  •                         StrSql = StrSql & .Fields(I).Name & " Memo NULL,"
  •              End Select
  •         Next
  •         
  •         End With
  •         
  •         StrSql = Left$(StrSql, Len(StrSql) - 1)
  •         StrSql = "CREATE TABLE " & TmpName & " (" & StrSql & ")"
  •         MdbCnn.Execute StrSql
  •         InsertIntoDB MdbCnn, TmpName, TRs
  •         If TRs.State = adStateOpen Then
  •              TRs.Close
  •              Set TRs = Nothing
  •         End If
  •         SqlToMdb = TmpName
  •         Err.Clear
  • End Function
  • '//将一个RS保存到一个临时的表...
  • Public Function RsToTmp(Rs As ADODB.Recordset, P_Cnn As ADODB.Connection, Optional TabName As String = "") As String
  •         Dim StrSql As String
  •         Dim I As Long
  •         Dim TmpName As String
  •         Dim TRs As New ADODB.Recordset
  •         
  •         Err.Clear
  •         On Error Resume Next
  •         
  •         If P_Cnn.State <> 1 Then P_Cnn.Open
  •         Set TRs = Rs.Clone
  •         
  •         TabName = Trim$(TabName)
  •         If Len(TabName) > 0 Then
  •             TmpName = TabName
  •         Else
  •             TmpName = GetTmpName("S")
  •             StrSql = "DROP TABLE " & TmpName
  •         End If
  •         P_Cnn.Execute StrSql
  •         
  •         With TRs
  •         
  •         StrSql = ""
  •         For I = 0 To .Fields.Count - 1
  •             Select Case .Fields(I).Type
  •                    Case Is = 6 '货币 6
  •                         StrSql = StrSql & .Fields(I).Name & " Money NULL,"
  •                    Case Is = 11 'ACCESS 是/否 11
  •                         StrSql = StrSql & .Fields(I).Name & " VARCHAR(" & .Fields(I).DefinedSize & ") NULL,"
  •                    Case Is = 129 'CHAR
  •                         StrSql = StrSql & .Fields(I).Name & " VARCHAR(" & .Fields(I).DefinedSize & ") NULL,"
  •                    Case Is = 130 'NCHAR
  •                         StrSql = StrSql & .Fields(I).Name & " VARCHAR(" & .Fields(I).DefinedSize & ") NULL,"
  •                    Case Is = 202 'NVARCHAR
  •                         StrSql = StrSql & .Fields(I).Name & " VARCHAR(" & .Fields(I).DefinedSize & ") NULL,"
  •                    Case Is = 200 'VARCHAR
  •                         StrSql = StrSql & .Fields(I).Name & " VARCHAR(" & .Fields(I).DefinedSize & ") NULL,"
  •                    Case Is = 3  'INT
  •                         StrSql = StrSql & .Fields(I).Name & " INT NULL,"
  •                    Case Is = 17 'TINYINT 字节 Access 17
  •                         StrSql = StrSql & .Fields(I).Name & " INT NULL,"
  •                    Case Is = 2   'SMALLINT
  •                         StrSql = StrSql & .Fields(I).Name & " INT NULL,"
  •                    Case Is = 20, 72 'BIGINT 同步复制 ID 72
  •                         StrSql = StrSql & .Fields(I).Name & " INT NULL,"
  •                    Case Is = 201 'TEXT
  •                         StrSql = StrSql & .Fields(I).Name & " TEXT NULL,"
  •                    Case Is = 203 'NTEXT
  •                         StrSql = StrSql & .Fields(I).Name & " TEXT NULL,"
  •                    Case Is = 131, 4, 5 'NUMERIC|4,5 单精度型 4双精度型 5
  •                         StrSql = StrSql & .Fields(I).Name & " Numeric NULL,"
  •                    Case Is = 135, 7 'DATETIME  日期/时间 7
  •                         StrSql = StrSql & .Fields(I).Name & " DATETIME NULL,"
  •                    Case Is = 205 'IMAGE
  •                         StrSql = StrSql & .Fields(I).Name & " Image NULL,"
  •                    Case Is = 128 'BINARY
  •                         StrSql = StrSql & .Fields(I).Name & " TEXT NULL,"
  •                    Case Is = 204 'VARBINARY
  •                         StrSql = StrSql & .Fields(I).Name & " TEXT NULL,"
  •              End Select
  •         Next
  •         
  •         End With
  •         
  •         StrSql = Left$(StrSql, Len(StrSql) - 1)
  •         StrSql = "CREATE TABLE " & TmpName & " (" & StrSql & ")"
  •         P_Cnn.Execute StrSql
  •         InsertIntoDB P_Cnn, TmpName, TRs
  •         If TRs.State = adStateOpen Then
  •              TRs.Close
  •              Set TRs = Nothing
  •         End If
  •         RsToTmp = TmpName
  •         Err.Clear
  • End Function
  • '
  • '//将DBF导入MDB
  • Public Function DBFTOMDB(Rs As ADODB.Recordset, _
  •                          P_Cnn As ADODB.Connection, _
  •                          TabName As String, _
  •                          Optional strlen As Integer = 64)
  •        
  •         Dim FldList As String
  •         
  •         Dim FldValList As String
  •         Dim FldNameList As String
  •         
  •         Dim StrSql As String
  •         Dim TRs As New ADODB.Recordset
  •         Dim I As Long
  •         
  •         On Error Resume Next
  •         
  •         FldList = ""
  •         Set TRs = Rs.Clone
  •         For I = 0 To TRs.Fields.Count - 1
  •             FldList = FldList & TRs.Fields(I).Name & " VARCHAR(" & strlen & ") NULL,"
  •         Next
  •         If Len(FldList) > 0 Then
  •             FldList = Left$(FldList, Len(FldList) - 1)
  •             StrSql = "CREATE TABLE " & TabName & "  (" & FldList & ")"
  •             P_Cnn.Execute StrSql
  •             TRs.MovePrevious
  •             While Not TRs.EOF
  •                 
  •                 TRs.MoveNext
  •                 If Err.Number <> 0 Then
  •                     Exit Function
  •                 End If
  •             Wend
  •         End If
  • End Function
    • 标签：

    相关文章