VB中对数据库的各种操作

lzqlaj

受帖子长度限制，分几部分。原帖网址：http://blog.csdn.net/MSTOP/article/details/3053475
'数据库操作(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

[ 本帖最后由 lzqlaj 于 2011-7-23 17:29 编辑 ]

lzqlaj

'建立数据表
'函数名: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

lzqlaj

'取某 数据表 下除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

lzqlaj

'从窗体的控件中生成 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

lzqlaj

'将二进制数据从记录中取出
'函数名: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

lzqlaj

'取局域网中所有SQL SERVER 服务器名称
'函数名:AddSqlServer
'参数:
'返回值:字符串数组
'引用SQLDMO LIB
Public Function AddSqlServer() As String()
    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

lzqlaj

'//将一个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

lzqlaj

其它帖子：
成绩录入工具（vb）
http://club.excelhome.net/thread-744536-1-1.html

空行操作（“插入空行”）
http://club.excelhome.net/thread-590404-1-1.html

[分享] （无意中发现的）罗刚君 底端标题生成工具（开放源码含附件）
http://club.excelhome.net/thread-601577-1-1.html

[源码全部公开] 分数段统计（数组）（vba）
http://club.excelhome.net/thread-750450-1-1.html

[源码全部公开] 分数段统计（vba）
http://club.excelhome.net/thread-599282-1-1.html

搜狗文本词库的制作（vb）
http://club.excelhome.net/thread-670925-1-1.html

汉字与区位码转换（vb版）
http://club.excelhome.net/thread-670918-1-1.html

[源码全部公开] 区位码与汉字相互转换
http://club.excelhome.net/thread-601351-1-1.html

优盘禁用工具
http://club.excelhome.net/thread-495008-1-1.html

[源码全部公开] 工资条通用生成程序（也可分考场）
http://club.excelhome.net/thread-487664-1-1.html

[转帖] 把excel追加导入到access数据库
http://club.excelhome.net/thread-745574-1-1.html

[转帖] 删除mbd数据库中所有记录
http://club.excelhome.net/thread-745139-1-1.html

[转帖] VB把access数据库里的表导出成EXCEL表
http://club.excelhome.net/thread-745132-1-1.html

zez

好贴，谢谢分享！

a8737461

好贴 好贴  学习一下