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

最新推荐文章于 2020-11-29 12:38:14 发布
华芸智森
最新推荐文章于 2020-11-29 12:38:14 发布
阅读量5k
点赞数 1
分类专栏： VB 文章标签：数据库 vb null image sqlserver access
本文链接：https://blog.csdn.net/MSTOP/article/details/3053475
版权
VB 专栏收录该内容
19 篇文章 0 订阅
订阅专栏
 
 
' 
'数据库操作(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
 
华芸智森
关注
1
点赞
踩
7

收藏

觉得还不错? 一键收藏
2
评论
VB中对数据库的各种操作.

数据库操作(SmDbCtrl) Option ExplicitPublic DbStyle As StringDim CT As SmDataDiap ======================================================================== 创建一个SQLSERVER定
复制链接

扫一扫
专栏目录