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

 
  1. '
  2. '数据库操作(SmDbCtrl)
  3. '
  4. Option Explicit
  5. Public DbStyle As String
  6. Dim CT As SmDataDiap
  7. '
  8. '========================================================================
  9. '创建一个SQLSERVER定形连接(连接到SQL)
  10. '函数名:CreateShape
  11. '参数:  P_Cnn ADODB连接,ServerName 服务器名,DBname 数据库名,UserID 登录用户名,UPw 登录密码,Timerout 连接超时
  12. '返回值:TRUE 连接成功.FALSE 连接失败.
  13. '例:    CreateShape P_Cnn,"CJH","cjherp001","sa","123",15
  14. '========================================================================
  15. Public Function CreateShape(ByRef P_Cnn As ADODB.Connection, _
  16.                             ServerName As String, _
  17.                             DbName As String, _
  18.                             UserID As String, _
  19.                             UPw As String, _
  20.                             Optional Timerout As Long = 15) As Boolean
  21.         
  22.         Dim ReturnVal As Boolean
  23.         Dim ConnStr As String
  24.         
  25.         Err.Clear
  26.         On Error Resume Next
  27.         
  28.         ConnStr = "Provider=MSDataShape;Data Provider=SQLOLEDB.1;Password=" & UPw & ";Persist Security Info=True;User ID=" & UserID & _
  29.                   ";Initial Catalog=" & DbName & ";Data Source=" & ServerName
  30.         P_Cnn.ConnectionString = ConnStr
  31.         P_Cnn.ConnectionTimeout = Timerout
  32.         P_Cnn.CommandTimeout = Timerout
  33.         P_Cnn.Open
  34.         DoEvents
  35.         
  36.         If Err.Number = 0 Then
  37.            DbStyle = "SQL"
  38.            ReturnVal = True
  39.         Else
  40.            Err.Clear
  41.            DbStyle = ""
  42.            ReturnVal = False
  43.         End If
  44.         CreateShape = ReturnVal
  45.         Err.Clear
  46. End Function
  47. '========================================================================
  48. '创建一个连接(连接到SQL)
  49. '函数名:CreateSqlConn
  50. '参数:  P_Cnn ADODB连接,ServerName 服务器名,DBname 数据库名,UserID 登录用户名,UPw 登录密码,Timerout 连接超时
  51. '返回值:TRUE 连接成功.FALSE 连接失败.
  52. '例:    CreateSqlConn p_cnn,"CJH","cjherp001","sa","123",15
  53. '========================================================================
  54. Public Function CreateSqlConn(ByRef P_Cnn As ADODB.Connection, _
  55.                               ServerName As String, _
  56.                               DbName As String, _
  57.                               UserID As String, _
  58.                               UPw As String, _
  59.                               Optional Timerout As Long = 15) As Boolean
  60.     Dim ReturnVal As Boolean
  61.     
  62.     Err.Clear
  63.     On Error Resume Next
  64.     If P_Cnn.State = adStateOpen And Not IsEmpty(adStateOpen) Then
  65.        P_Cnn.Close
  66.     End If
  67.     
  68.     P_Cnn.Provider = "MSDASQL.1"
  69.     P_Cnn.ConnectionString = "Driver={SQL Server};Server=" & ServerName & ";DataBase=" & DbName & ";Uid=" & UserID & ";Pwd=" & UPw & ";APP=" & App.Path & ";WSID=" & UserID & ";Connect Timeout=" & Timerout & ";"
  70.     
  71.     P_Cnn.ConnectionTimeout = Timerout
  72.     P_Cnn.CommandTimeout = Timerout
  73.     P_Cnn.Open
  74.     DoEvents
  75.     If Err.Number = 0 Then
  76.        DbStyle = "SQL"
  77.        ReturnVal = True
  78.     Else
  79.        Err.Clear
  80.        DbStyle = ""
  81.        ReturnVal = False
  82.     End If
  83.     CreateSqlConn = ReturnVal
  84.     Err.Clear
  85. End Function
  86. '
  87. '========================================================================
  88. '创建一个连接(连接到ACCESS)
  89. '函数名:CreateMdbConn
  90. '参数:  MdbCnn ADODB连接,MdbPath ACCESS数据库路径,Provider JET引擎版本,UserID 登录用户名,UserWord 登录密码
  91. '返回值:TRUE 连接成功.FALSE 连接失败.
  92. '例:    CreateMdbConn p_cnn,"C:/DEMO.MDB","sa","123"
  93. '========================================================================
  94. Public Function CreateMdbConn(ByRef MdbCnn As ADODB.Connection, _
  95.                               MdbPath As String, _
  96.                               Optional Provider = "Microsoft.Jet.OLEDB.4.0;", _
  97.                               Optional UserID As String = "admin", _
  98.                               Optional UserWord As String = ""As Boolean
  99.   Dim ConStr As String
  100.     
  101.   Err.Clear
  102.   On Error Resume Next
  103.   
  104.   If MdbCnn.State = adStateOpen And Not IsEmpty(adStateOpen) Then
  105.      MdbCnn.Close
  106.   End If
  107.   '/------------------------------------------------------------------
  108.   ConStr = "Provider=" & Provider & _
  109.            "Data Source=" & MdbPath & ";" & _
  110.            "Jet OLEDB:Database Password=" & UserWord & ";" & _
  111.            "User ID=" & UserID & ";"
  112.   MdbCnn.ConnectionString = ConStr
  113.   MdbCnn.Open
  114.   DoEvents
  115.   If Err.Number = 0 Then
  116.      DbStyle = "MDB"
  117.      CreateMdbConn = True
  118.   Else
  119.      Err.Clear
  120.      DbStyle = ""
  121.      CreateMdbConn = False
  122.   End If
  123.   Err.Clear
  124. End Function
  125. '=====================================================================
  126. '创建一个连接(连接到其它数据库类型)
  127. '函数名:CreateOtherConn
  128. '参数:  OtherCnn ADODB连接,FilePath 数据库路径,UserName 登录用户名,PassWord 登录密码,DbType SmDbType枚举数据库类型
  129. '返回值:TRUE 连接成功.FALSE 连接失败.
  130. '例:
  131. 'CreateOtherConn Cnn, "E:/CjhLx/dbf", , , FoxPro
  132. 'StrSql = "select * from [employee.dbf]"
  133. 'Set Rs = RsOpen(Cnn, StrSql)
  134. 'Set DataGrid1.DataSource = Rs
  135. '=====================================================================
  136. Public Function CreateOtherConn(ByRef OtherCnn As ADODB.Connection, _
  137.                                FilePath As String, _
  138.                                Optional UserName As String = "admin", _
  139.                                Optional PassWord As String = "", _
  140.                                Optional DbType As SmDbType = Access) As Boolean
  141.         Dim ConnStr As String
  142.         Dim DriveName(5) As String
  143.         Dim tDbType(5) As String
  144.         Dim UserPwd(5) As String
  145.         
  146.         Err.Clear
  147.         '/驱动程序
  148.         DriveName(1) = "{Microsoft Access Driver (*.mdb)}"
  149.         DriveName(2) = "{Microsoft Excel Driver (*.xls)}"
  150.         DriveName(3) = "{Microsoft Text Driver (*.txt; *.csv)}"
  151.         DriveName(4) = "{Microsoft Visual FoxPro Driver};SourceType=DBF"
  152.         DriveName(5) = "{Microsoft dBase Driver (*.dbf)}"
  153.         '/类型
  154.         tDbType(1) = "MDB"
  155.         tDbType(2) = "XLS"
  156.         tDbType(3) = "TXT"
  157.         tDbType(4) = "FDB"
  158.         tDbType(5) = "DDB"
  159.         '/用户名和密码.
  160.         UserPwd(1) = "Uid=" & UserName & ";Pwd=" & PassWord & ";"
  161.         UserPwd(2) = "Uid=" & UserName & ";Pwd=" & PassWord & ";"
  162.         UserPwd(3) = ""
  163.         UserPwd(4) = "Uid=" & UserName & ";Pwd=" & PassWord & ";"
  164.         UserPwd(5) = "Uid=" & UserName & ";Pwd=" & PassWord & ";"
  165.         
  166.         On Error Resume Next
  167.         
  168.         If OtherCnn.State = adStateOpen And Not IsEmpty(adStateOpen) Then
  169.            OtherCnn.Close
  170.         End If
  171.         ConnStr = "Provider=MSDASQL.1;Persist Security Info=False;DRIVER=" & DriveName(DbType) & ";" & UserPwd(DbType) & "DBQ=" & FilePath
  172.         OtherCnn.ConnectionString = ConnStr
  173.         OtherCnn.Open
  174.         DoEvents
  175.           
  176.         If Err.Number = 0 Then
  177.            DbStyle = tDbType(DbType)
  178.            CreateOtherConn = True
  179.         Else
  180.            Err.Clear
  181.            DbStyle = ""
  182.            CreateOtherConn = False
  183.         End If
  184.         Err.Clear
  185.   End Function
  186. '=========================================================================
  187. '打开一个记录集
  188. '函数名:RsOpen
  189. '参数:  P_Cnn ADODB连接,StrSql SQL查询语句,SetNothing 非连接方式(TRUE默认).连接方式(FALSE)
  190. '返回值:记录集
  191. '例:    RsOpen P_CNN,"SELECT ACHGOODS.* FROM ACHGOODS WHERE GDSID='001'
  192. '=========================================================================
  193. Public Function RsOpen(ByRef P_Cnn As ADODB.Connection, _
  194.                 StrSql As String, _
  195.                 Optional SetConnect As Boolean = TrueAs ADODB.Recordset
  196.     
  197.     Dim Rs As New ADODB.Recordset
  198.     
  199.     Err.Clear
  200.     On Error Resume Next
  201.        
  202.     If P_Cnn.State <> 1 Then P_Cnn.Open
  203.     
  204.     If SetConnect Then '使用非连接
  205.         Rs.CursorLocation = adUseClient      '使用客户端游标
  206.         Rs.LockType = adLockBatchOptimistic  '开放式批更新
  207.         Rs.CursorType = adOpenKeyset         '键集游标
  208.     Else '使用连接(主要用于更新二进制字段)
  209.         Rs.CursorLocation = adUseClient
  210.         Rs.CursorType = adOpenKeyset
  211.         Rs.LockType = adLockOptimistic       '记录锁定
  212.     End If
  213.     Rs.Open StrSql, P_Cnn                                   '执行SQL
  214.     If SetConnect Then Set Rs.ActiveConnection = Nothing    '设置非连接
  215.     
  216.     If Err.Number = 0 Then
  217.        Set RsOpen = Rs.Clone
  218.     Else
  219.        Set RsOpen = Nothing
  220.     End If
  221.     
  222.     Rs.Close
  223.     Set Rs = Nothing
  224.     Err.Clear
  225. End Function
  226. '//执行一条SQL语句
  227. Public Function ExecSql(ByRef P_Cnn As ADODB.Connection, _
  228.                 StrSql As StringAs Boolean
  229.          
  230.          Err.Clear
  231.          If P_Cnn.State <> 1 Then P_Cnn.Open
  232.          P_Cnn.Execute StrSql
  233.          ExecSql = (Err.Number = 0)
  234.          Err.Clear
  235. End Function
  236. '
  237. '========================================================================
  238. '建立数据库
  239. '函数名:CreateDataBase
  240. '参数:  ServerName 服务器名,UserID 用户名(SA),Pwd 登录密码,DataBasName 建立的数据库名,DataBasPath 库文件目录的绝对路径
  241. '返回值:无
  242. '例:    CreateDataBase "CJH","SA","123","CJHERP001","C:/DB"
  243. '========================================================================
  244. Public Function CreateDataBase(ServerName As String, _
  245.                                UserID As String, _
  246.                                Pwd As String, _
  247.                                DataBasName As String, _
  248.                                DataBasPath As StringAs Boolean
  249.     
  250.     Dim A As Long, LeftName As String
  251.     Dim DbC As New ADODB.Connection
  252.     Dim CreateBasSql As String
  253.     Dim BagTrFlag As Boolean
  254.     
  255.     Err.Clear
  256.     
  257.     If CreateSqlConn(DbC, ServerName, "Master", UserID, Pwd) Then
  258.          If Right$(DataBasPath, 1) <> "/" Then DataBasPath = DataBasPath & "/"
  259.          
  260.          On Error GoTo Errhan:
  261.          
  262.          DataBasPath = Trim$(DataBasPath)
  263.          
  264.          If Len(DataBasPath) < 2 Then Exit Function
  265.          If Dir$(Left$(DataBasPath, 2), vbDirectory) = "" Then Beep: Exit Function '根目录是否存在
  266.         '/---------------------------------------------------------
  267.          If Right$(DataBasPath, 1) <> "/" Then DataBasPath = DataBasPath & "/"
  268.          For A = 1 To Len(DataBasPath)
  269.              If Mid$(DataBasPath, A, 1) = "/" Then
  270.                 LeftName = Left$(DataBasPath, A)
  271.                 '/如果目录不存在,则先建立
  272.                 If Dir$(LeftName, vbDirectory) = "" Then MkDir LeftName: DoEvents
  273.              End If
  274.          Next
  275.          Err.Clear
  276.          DbC.BeginTrans
  277.         '/---------------------------------------------------------
  278.          CreateBasSql = " CREATE DATABASE " & DataBasName & " ON (NAME=" & DataBasName & ",FILENAME='" & DataBasPath & DataBasName & ".mdf', SIZE=20,FILEGROWTH=4) " & _
  279.                         " LOG ON (NAME=" & DataBasName & "Log" & ",FILENAME='" & DataBasPath & DataBasName & "Log.ldf',SIZE=20,FILEGROWTH=0)"
  280.          DbC.Execute CreateBasSql
  281.          DbC.CommitTrans
  282.     End If
  283.     
  284. Errhan:
  285.     If Err.Number <> 0 Then DbC.RollbackTrans
  286.     CreateDataBase = (Err.Number = 0)
  287.     DbC.Close
  288.     Set DbC = Nothing
  289.     Err.Clear
  290. End Function
  291. '
  292. '建立数据表
  293. '函数名:CreageDbTab
  294. '参数:  P_Cnn ADO连接,CreateTableSql 建表字符串
  295. '返回值:无
  296. '例:    CreateDbTab P_CNN,CreateTabStr
  297. Public Function CreateDbTab(ByRef P_Cnn As ADODB.Connection, _
  298.                             CreateTableSql As StringAs Boolean
  299.     
  300.     Err.Clear
  301.     On Error Resume Next
  302.     
  303.     If P_Cnn.State <> 1 Then P_Cnn.Open
  304.     P_Cnn.BeginTrans
  305.     P_Cnn.Execute CreateTableSql
  306.     P_Cnn.CommitTrans
  307.     CreateDbTab = (Err.Number = 0)
  308.     Err.Clear
  309. End Function
  310. '
  311. '得到服务器上所有的数据库名
  312. '函数名:GetAllDatabases
  313. '参数:  ServerName 服务器名,UserID 登录用户名(SA),Pwd 登录密码
  314. '返回值:数据库名的字符串数组
  315. '例:    GetAllDatabases "CJH","SA","123"
  316. Public Function GetAllDatabases(ServerName As String, _
  317.                                 UserID As String, _
  318.                                 Pwd As String, _
  319.                                 Optional strDriver As String = "SQL Server"As String()
  320.     Dim PCnn As New ADODB.Connection
  321.     Dim RsSchema As New ADODB.Recordset
  322.     Dim ConnStr As String
  323.     Dim ReturnVal() As String
  324.     Dim ReID As Long
  325.     
  326.     Err.Clear
  327.     On Error Resume Next
  328.     
  329.     ConnStr = "Driver={" & strDriver & "};"
  330.     ConnStr = ConnStr & "Server=" & ServerName & ";"
  331.     ConnStr = ConnStr & "uid=" & UserID & ";pwd=" & Pwd & ";"
  332.     PCnn.ConnectionString = ConnStr
  333.     
  334.     PCnn.Open: ReID = 0
  335.     Set RsSchema = PCnn.OpenSchema(adSchemaCatalogs)
  336.     Do Until RsSchema.EOF
  337.         ReID = ReID + 1
  338.         ReDim Preserve ReturnVal(ReID - 1)
  339.         ReturnVal(ReID - 1) = RsSchema!Catalog_Name
  340.         RsSchema.MoveNext
  341.     Loop
  342.     If PCnn.State = adStateOpen And Not IsEmpty(adStateOpen) Then
  343.        PCnn.Close
  344.     End If
  345.     GetAllDatabases = ReturnVal
  346.     Err.Clear
  347. End Function
  348. '
  349. '取某数据库下的数据表
  350. '函数名:GetDbTabS
  351. '参数:  P_Cnn ADO连接
  352. '返回值:包含数据表的字符串数组
  353. '例:    TabArr=GetDbTabS(P_CNN)
  354. Public Function GetDbTabs(ByRef P_Cnn As ADODB.Connection) As String()
  355.    Dim RstSchema As ADODB.Recordset
  356.    Dim strCnn As String
  357.    Dim ReturnVal() As String
  358.    Dim ReID As Long
  359.    
  360.    Err.Clear
  361.    On Error Resume Next
  362.    
  363.    If P_Cnn.State <> 1 Then P_Cnn.Open
  364.    Set RstSchema = P_Cnn.OpenSchema(adSchemaTables)
  365.    ReID = 0
  366.    Do Until RstSchema.EOF
  367.       If UCase$(Left$(RstSchema.Fields("TABLE_TYPE"), 3)) <> "SYS" Then
  368.             ReID = ReID + 1
  369.             ReDim Preserve ReturnVal(ReID - 1)
  370.             ReturnVal(ReID - 1) = RstSchema.Fields("TABLE_NAME"' & ":" & RstSchema!TABLE_TYPE
  371.       End If
  372.       RstSchema.MoveNext
  373.    Loop
  374.    RstSchema.Close
  375.    Set RstSchema = Nothing
  376.    GetDbTabs = ReturnVal
  377.    Err.Clear
  378. End Function
  379. '============================================================================
  380. '取临时表名
  381. '函数名:GetTmpName
  382. '参数:
  383. '返回值:一个唯一的临时表名
  384. '例:    TmpName=GetTmpName()
  385. '(注:临时表名="#TmpTal" &  累加数 & 毫秒数)
  386. '============================================================================
  387. Public Function GetTmpName(Optional UserName As String = ""As String
  388.       Dim ReturnVal As String
  389.       Dim TimVal As String
  390.       Static K As Long
  391.       
  392.       Err.Clear
  393.       On Error Resume Next
  394.       
  395.       K = K + 1
  396.       If K >= 2147483645# Then K = 0          '累加数
  397.       TimVal = timeGetTime()                  '毫秒数
  398.       ReturnVal = "#" & "TmpTal" & UserName & TimVal & CT.ToStr(K)
  399.       GetTmpName = IIf(Err.Number = 0, ReturnVal, "")
  400.       Err.Clear
  401. End Function
  402. '
  403. '=======================================================================
  404. '对 表格或记录集以 INSERT INTO 保存.
  405. '函数名:GetInsertIntoSql
  406. '参数:  P_Cnn ADO连接,mRs 记录集,DateTabName 目标数据表名
  407. '返回值:SQL语句
  408. '例:    InsertIntoDB P_CNN,RS,"ACHGOODS"
  409. '=======================================================================
  410. Public Function InsertIntoDB(ByRef P_Cnn As ADODB.Connection, _
  411.                              DateTabName As String, _
  412.                              ByRef MRs As ADODB.Recordset) As Boolean
  413.        Dim StrSql As String
  414.        Dim TabFied() As SmFiedArrtr     '数据库字段
  415.        Dim SaveFied() As SmFiedArrtr    '表格与数据库同时存在的字段
  416.        Dim SaveID As Long
  417.        Dim AddSave As Boolean
  418.        Dim AddFile As SmFiedArrtr
  419.        Dim FileCon As String
  420.        Dim FldVal As String
  421.        Dim TmpVal As Variant
  422.        Dim FldType As Long
  423.        Dim A As Long, B As Long, I As Long
  424.        Dim FldValColl As New Collection
  425. '/--------------------------------------------------------------------------------------
  426.        Err.Clear
  427.        On Error Resume Next
  428.        
  429.        If (MRs.EOF And MRs.BOF) Then Exit Function
  430.        Erase TabFied
  431.        If P_Cnn.State <> 1 Then P_Cnn.Open
  432.        
  433.        TabFied = GetTabFldAttrib(P_Cnn, DateTabName)                  '取数据库字段
  434.        If UBound(TabFied, 1) > 0 Then
  435.             SaveID = 0: AddSave = False
  436.             For A = 0 To MRs.Fields.Count - 1
  437.                 For B = 0 To UBound(TabFied, 1)
  438.                     If UCase$(TabFied(B).FieldName) = UCase$(MRs.Fields(A).Name) Then
  439.                     
  440.                         '处理重复的字段名.
  441.                         Err.Clear
  442.                         FldValColl.Add TabFied(B), "_" & UCase$(TabFied(B).FieldName)
  443.                         
  444.                         If Err.Number <> 457 Then
  445.                             SaveID = SaveID + 1
  446.                             ReDim Preserve SaveFied(SaveID - 1)
  447.                             SaveFied(SaveID - 1) = TabFied(B)
  448.                         End If
  449.                         
  450.                         Exit For
  451.                     End If
  452.                 Next
  453.             Next
  454. '/---------------------------------------------------------------------------------------
  455.             '/保存字段列表
  456.             For A = 0 To UBound(SaveFied, 1) '字段列表
  457.                 If SaveFied(A).FieldType <> 205 Then
  458.                     FileCon = FileCon & "[" & SaveFied(A).FieldName & "],"
  459.                 End If
  460.             Next A
  461.             FileCon = Left$(FileCon, Len(FileCon) - 1)
  462.             
  463.             MRs.MoveFirst
  464.             
  465.             While Not MRs.EOF
  466.                 FldVal = ""
  467.                 For I = 0 To UBound(SaveFied, 1)
  468.                     FldType = SaveFied(I).FieldType                  '字段类型
  469.                     If FldType <> 205 Then                           '将IMAGE字段排除
  470.                         TmpVal = CT.ToStr(MRs.Fields(SaveFied(I).FieldName))  '字段值
  471.                         If Len(TmpVal) = 0 Then                               '对空或NULL的处理
  472.                            Select Case FldType
  473.                                   Case 2, 3, 4, 5, 6, 17, 131                      '数值类型
  474.                                        If SaveFied(I).FieldIsNull <> 0 Then        '可接受NULL
  475.                                           FldVal = FldVal & "NULL,"
  476.                                        Else
  477.                                           FldVal = FldVal & "0,"
  478.                                        End If
  479.                                   Case 135 '日期
  480.                                        If SaveFied(I).FieldIsNull <> 0 Then        '可接受NULL
  481.                                           FldVal = FldVal & "NULL,"
  482.                                        Else
  483.                                           If DbStyle = "MDB" Then
  484.                                              FldVal = FldVal & "#" & Now() & "#,"
  485.                                           Else
  486.                                              FldVal = FldVal & "'" & Now() & "',"
  487.                                           End If
  488.                                           
  489.                                        End If
  490.                                   Case Else                                       '其它类型
  491.                                        If SaveFied(I).FieldIsNull <> 0 Then
  492.                                           FldVal = FldVal & "NULL,"
  493.                                        Else
  494.                                           FldVal = FldVal & "'',"
  495.                                        End If
  496.                            End Select
  497.                         Else
  498.                            Select Case FldType
  499.                                   Case 2, 3, 4, 5, 6, 17, 131            '数值类型
  500.                                        FldVal = FldVal & "" & TmpVal & ","
  501.                                   Case 135
  502.                                        If DbStyle = "MDB" Then
  503.                                           FldVal = FldVal & "#" & TmpVal & "#,"
  504.                                        Else
  505.                                           FldVal = FldVal & "'" & TmpVal & "',"
  506.                                        End If
  507.                                   Case Else                              '其它类型
  508.                                        FldVal = FldVal & "'" & Replace(TmpVal, "'""''") & "',"
  509.                            End Select
  510.                         End If
  511.                     End If
  512.                 Next
  513.                 FldVal = Left$(FldVal, Len(FldVal) - 1)
  514.                 StrSql = "INSERT INTO [" & DateTabName & "] (" & FileCon & ") VALUES (" & FldVal & ")"
  515.                 P_Cnn.Execute StrSql
  516.                 MRs.MoveNext
  517.             Wend
  518.        End If
  519.        Set FldValColl = Nothing
  520.        InsertIntoDB = (Err.Number = 0)
  521.        Err.Clear
  522. End Function
  523. '
  524. '对表格或记录集以 UPDATE 保存.
  525. '函数名:GetUpdataSql
  526. '参数:  P_Cnn ADO连接,mRs 记录集,DateTabName 目标数据表名,WhereStr 更新条件
  527. '返回值:SQL语句
  528. '例:    UpdataDB P_CNN,RS,"ACHGOODS","WHERE GDSID='001'"
  529. Public Function UpdataDB(ByRef P_Cnn As ADODB.Connection, _
  530.                          DateTabName As String, _
  531.                          ByRef MRs As ADODB.Recordset, _
  532.                          WhereStr As StringAs Boolean
  533.        Dim StrSql As String
  534.        Dim TabFied() As SmFiedArrtr   '数据库字段
  535.        Dim SaveFied() As SmFiedArrtr  '表格与数据库同时存在的字段
  536.        Dim SaveID As Long
  537.        Dim AddSave As Boolean
  538.        Dim AddFile As SmFiedArrtr
  539.        Dim FileCon As String
  540.        Dim FldVal As String
  541.        Dim TmpVal As Variant
  542.        Dim FldType As Long
  543.        Dim A As Long, B As Long, I As Long
  544. '/----------------------------------------------------------------------------------------
  545.        Err.Clear
  546.        On Error Resume Next
  547. '
  548.        If MRs.EOF And MRs.BOF Then Exit Function
  549.        Erase TabFied
  550.        If P_Cnn.State <> 1 Then P_Cnn.Open
  551.        TabFied = GetTabFldAttrib(P_Cnn, DateTabName)    '取数据库字段
  552.        If UBound(TabFied, 1) > 0 Then
  553.             SaveID = 0
  554.             For A = 0 To MRs.Fields.Count - 1
  555.                 For B = 0 To UBound(TabFied, 1)
  556.                     If UCase$(TabFied(B).FieldName) = UCase$(MRs.Fields(A).Name) Then
  557.                         SaveID = SaveID + 1
  558.                         ReDim Preserve SaveFied(SaveID - 1)
  559.                         SaveFied(SaveID - 1) = TabFied(B)
  560.                         Exit For '找到数据库与记录集中相同的值,跳出循环.
  561.                     End If
  562.                 Next
  563.             Next
  564. '/--------------------------------------------------------------------------------------
  565.             MRs.MoveFirst
  566.             While Not MRs.EOF
  567.                 FldVal = ""
  568.                 For I = 0 To UBound(SaveFied, 1)
  569.                     FldType = SaveFied(I).FieldType                           '字段类型
  570.                     If FldType <> 205 Then                                    '将IMAGE字段排除
  571.                         TmpVal = CT.ToStr(MRs.Fields(SaveFied(I).FieldName))  '字段值
  572.                         If Len(TmpVal) = 0 Then                               '对空或NULL的处理
  573.                            Select Case FldType
  574.                                   Case 2, 3, 4, 5, 6, 17, 131                 '数值类型
  575.                                        If SaveFied(I).FieldIsNull <> 0 Then   '可按受NULL
  576.                                           FldVal = FldVal & ",[" & SaveFied(I).FieldName & "]=NULL"
  577.                                        Else
  578.                                           FldVal = FldVal & ",[" & SaveFied(I).FieldName & "]=0"
  579.                                        End If
  580.                                   Case 135 '日期时间
  581.                                        If SaveFied(I).FieldIsNull <> 0 Then   '可接受NULL
  582.                                           FldVal = FldVal & ",[" & SaveFied(I).FieldName & "]=NULL"
  583.                                        Else
  584.                                           If DbStyle = "MDB" Then
  585.                                              FldVal = FldVal & ",[" & SaveFied(I).FieldName & "]=#" & Now() & "#"
  586.                                           Else
  587.                                              FldVal = FldVal & ",[" & SaveFied(I).FieldName & "]='" & Now() & "'"
  588.                                           End If
  589.                                        End If
  590.                                   Case Else                                   '其它类型
  591.                                        If SaveFied(I).FieldIsNull <> 0 Then
  592.                                           FldVal = FldVal & ",[" & SaveFied(I).FieldName & "]=NULL"
  593.                                        Else
  594.                                           FldVal = FldVal & ",[" & SaveFied(I).FieldName & "]=''"
  595.                                        End If
  596.                            End Select
  597.                         Else
  598.                            Select Case FldType
  599.                                   Case 2, 3, 4, 5, 6, 17, 131            '数值类型
  600.                                        FldVal = FldVal & ",[" & SaveFied(I).FieldName & "]=" & TmpVal
  601.                                   Case 135
  602.                                        If DbStyle = "MDB" Then
  603.                                           FldVal = FldVal & ",[" & SaveFied(I).FieldName & "]=#" & TmpVal & "#"
  604.                                        Else
  605.                                           FldVal = FldVal & ",[" & SaveFied(I).FieldName & "]='" & TmpVal & "'"
  606.                                        End If
  607.                                   Case Else                              '其它类型
  608.                                        FldVal = FldVal & ",[" & SaveFied(I).FieldName & "]='" & Replace(TmpVal, "'""''") & "'"
  609.                            End Select
  610.                         End If
  611.                     End If
  612.                 Next
  613.                 FldVal = " Set " & Right$(FldVal, Len(FldVal) - 1) & " " & WhereStr
  614.                 StrSql = "UpDate [" & DateTabName & "]" & FldVal
  615.                 P_Cnn.Execute StrSql
  616.                 MRs.MoveNext
  617.             Wend
  618.        End If
  619.        UpdataDB = (Err.Number = 0)
  620.        Err.Clear
  621. End Function
  622. '
  623. '取某 数据表 下所有的字段及其属性
  624. '函数名:GetTabFldAttrib
  625. '参数:  P_Cnn ADO连接,DateTabName 目标数据表名
  626. '返回值:SmFiedArrtr 类型数组
  627. '例:    FiedAtrrib=GetTabFldAttrib(P_CNN,"ACHGOODS")
  628. Public Function GetTabFldAttrib(ByRef P_Cnn As ADODB.Connection, _
  629.                                 DbTableName As StringAs SmFiedArrtr()
  630.     Dim A As Long
  631.     Dim StrSql As String
  632.     Dim Rs As New ADODB.Recordset
  633.     Dim ReturnVal() As SmFiedArrtr
  634.     Dim ReID As Long
  635.     
  636.     Err.Clear
  637.     On Error Resume Next
  638.     
  639.     If P_Cnn.State <> 1 Then P_Cnn.Open
  640.     
  641.     StrSql = "Select Top 1 * From [" & DbTableName & "]" '取字段名
  642.     Set Rs = RsOpen(P_Cnn, StrSql)
  643.     Set Rs.ActiveConnection = Nothing
  644.     Erase ReturnVal: ReID = 0
  645.     For A = 0 To Rs.Fields.Count - 1
  646.         ReID = ReID + 1
  647.         ReDim Preserve ReturnVal(ReID - 1)
  648.         ReturnVal(ReID - 1).FieldType = Rs.Fields(A).Type                            '数据类型
  649.         ReturnVal(ReID - 1).FieldName = Rs.Fields(A).Name                            '字段名
  650.         ReturnVal(ReID - 1).FieldIsNull = Rs.Fields(A).Attributes And adFldIsNullable '是否可接受NULL
  651.         ReturnVal(ReID - 1).FieldDefSize = Rs.Fields(A).DefinedSize                  '定义的数据长度
  652.         ReturnVal(ReID - 1).FieldActSize = 0                                         '实际数据长度(因只有字段名),故此值是0
  653.     Next
  654.     Set Rs = Nothing
  655.     GetTabFldAttrib = ReturnVal
  656.     Err.Clear
  657. End Function
  658. '
  659. '取某 数据表 下除IMAGE字段名的所有字段名
  660. '函数名:GetTabFldName
  661. '参数:  P_Cnn ADO连接,DateTabName 目标数据表名
  662. '返回值:String 类型数组
  663. '例:    StrFld=GetTabFldName(P_CNN,"ACHGOODS")
  664. Public Function GetTabFldName(ByRef P_Cnn As ADODB.Connection, _
  665.                               DbTabname As StringAs String
  666.        Dim N As Long
  667.        Dim ReturnVal As String
  668.        Dim FltArt() As SmFiedArrtr
  669.        
  670.        Err.Clear
  671.        On Error Resume Next
  672.        
  673.        If P_Cnn.State <> 1 Then P_Cnn.Open
  674.       
  675.        ReturnVal = ""
  676.        FltArt() = GetTabFldAttrib(P_Cnn, DbTabname)
  677.        For N = 0 To UBound(FltArt)
  678.            If FltArt(N).FieldType <> 205 Then
  679.               ReturnVal = ReturnVal & DbTabname & "." & FltArt(N).FieldName & ","
  680.            End If
  681.        Next
  682.        ReturnVal = Left$(ReturnVal, Len(ReturnVal) - 1)
  683.        GetTabFldName = IIf(Err.Number = 0, ReturnVal, "")
  684.        Err.Clear
  685. End Function
  686. '
  687. '取 记录集 下所有的字段及其属性
  688. '函数名:GetRsAttrib
  689. '参数:  mRs 记录集
  690. '返回值:FiedArrtr类型数组
  691. '例:    RsAtrrib=GetRsAttrib(Rs)
  692. Public Function GetRsAttrib(ByRef MRs As ADODB.Recordset) As SmFiedArrtr()
  693.     Dim A As Long
  694.     Dim ReturnVal() As SmFiedArrtr
  695.     Dim Rs As New ADODB.Recordset
  696.     Dim ReID As Long
  697.     
  698.     Err.Clear
  699.     Set Rs = MRs.Clone
  700.     Erase ReturnVal
  701.     For A = 0 To Rs.Fields.Count - 1
  702.         ReID = ReID + 1
  703.         ReDim Preserve ReturnVal(ReID - 1)
  704.         ReturnVal(ReID - 1).FieldType = Rs.Fields(A).Type                             '数据类型
  705.         ReturnVal(ReID - 1).FieldName = Rs.Fields(A).Name                             '字段名
  706.         ReturnVal(ReID - 1).FieldIsNull = Rs.Fields(A).Attributes And adFldIsNullable '是否可接受NULL
  707.         ReturnVal(ReID - 1).FieldDefSize = Rs.Fields(A).DefinedSize                   '定义的数据长度
  708.         ReturnVal(ReID - 1).FieldActSize = Rs.Fields(A).ActualSize                    '数据的实际长度
  709.     Next
  710.     Set Rs = Nothing
  711.     GetRsAttrib = ReturnVal
  712.     Err.Clear
  713. End Function
  714. '
  715. '取[窗体控件]与[字段]的对应关系
  716. '函数名:GetConToFld
  717. '参数:  P_Cnn ADODB.Connection,SelectStr SQL语句.
  718. '返回值:SmCtrlCorRs 类型数组
  719. '例:    FrmAndFied=GetConToFld(P_Cnn,Me)
  720. '*窗体控件命名规则:1-3 控件类型,4 W读写标志,R只读标志,其它,不作处理, 5 数据类型,6----最后.相对的字段名
  721. '*关于数据类型:C -字符  I 整数  F 浮点数  A 金额  U 单价   D 日期    T 时间
  722. Public Function GetConToFld(ByRef P_Cnn As ADODB.Connection, ByRef Frm As Object, SelectStr As StringAs SmCtrlCorRs()
  723.        Dim RevArr() As SmCtrlCorRs
  724.        Dim StrSql As String
  725.        Dim Rs As New ADODB.Recordset
  726.        
  727.        Err.Clear
  728.        On Error Resume Next
  729.        
  730. '       If (Frm Is Nothing) Or (P_Cnn Is Nothing) Then Exit Function
  731. '       If Len(Trim$(DbTabname)) = 0 Then DbTabname = Frm.Name
  732. '
  733. '       StrSql = "SELECT TOP 1 * FROM [" & DbTabname & "]"
  734.        StrSql = SelectStr
  735.        
  736.        If P_Cnn.State <> 1 Then P_Cnn.Open
  737.        
  738.        Set Rs = RsOpen(P_Cnn, StrSql)
  739.        RevArr = GetConToRs(Frm, Rs)
  740.        GetConToFld = RevArr
  741.        Set Rs = Nothing
  742.        Erase RevArr
  743.        Err.Clear
  744. End Function
  745. '
  746. '取[窗体控件]与[记录集]的对应关系
  747. '函数名:GetConToRs
  748. '参数:  Frm 源窗体名,mRs 源记录集
  749. '返回值:SmCtrlCorRs 类型数组
  750. '例:    FrmAndFied=GetConToRs(Me,Rs)
  751. '*窗体控件命名规则:1-3 控件类型,4 W读写标志,R只读标志,其它,不作处理, 5 数据类型,6----最后.相对的字段名
  752. '*关于数据类型:C -字符  I 整数  F 浮点数  A 金额  U 单价   D 日期    T 时间
  753. Public Function GetConToRs(ByRef m_Frm As Object, _
  754.                            ByRef MRs As ADODB.Recordset) As SmCtrlCorRs()
  755.     Dim A As Long, B As Long
  756.     Dim SaveID As Long
  757.     Dim AddSave As Boolean
  758.     Dim ArrayCon() As Control   '控件
  759.     Dim TabFied() As SmFiedArrtr  '数据库字段
  760.     Dim SetFied() As String     '同时存在的字段
  761.     Dim ReturnVal() As SmCtrlCorRs  '定义一个结构数组,用于返回
  762.     Dim AddFile As SmCtrlCorRs
  763.     Dim Rs As New ADODB.Recordset
  764.     Dim SId As Long
  765.     Dim FrmCon As Control
  766.     Dim ConName As String
  767.     Dim ConID As Long
  768.     Dim Frm As Form
  769.     
  770.     Err.Clear
  771.     On Error Resume Next
  772.     Erase ArrayCon:  ConID = 0
  773.     Set Frm = m_Frm
  774.     For Each FrmCon In Frm.Controls           '取控件,放入一个数组中
  775.         ConName = FrmCon.Name
  776.         '/将图片框控件排除
  777.         If UCase$(TypeName(FrmCon)) = UCase$("PictureBox"Or UCase$(TypeName(FrmCon)) = UCase$("Image"Or UCase$(TypeName(FrmCon)) = UCase$("SMPICBOX"Then
  778.            
  779.         Else
  780.            If Len(ConName) > 5 Then
  781.               If UCase$(Mid$(ConName, 4, 1)) = "W" Or UCase$(Mid$(ConName, 4, 1)) = "R" Then
  782.                     ConID = ConID + 1
  783.                     ReDim Preserve ArrayCon(ConID - 1)
  784.                     Set ArrayCon(ConID - 1) = FrmCon
  785.               End If
  786.            End If
  787.         End If
  788.     Next
  789. '/---------------------------------------------------------------------------------------------
  790.     Erase TabFied
  791.     Set Rs = MRs.Clone
  792.     If Rs.EOF And Rs.BOF Then
  793.        Rs.AddNew
  794.     End If
  795.     
  796.     TabFied = GetRsAttrib(MRs)                '取字段属性
  797.     If UBound(TabFied, 1) > 0 Then
  798.          SaveID = 0: AddSave = False
  799.          For A = 0 To UBound(TabFied, 1)
  800.              For B = 0 To UBound(ArrayCon, 1)
  801.                  ConName = UCase$(Right$(ArrayCon(B).Name, Len(ArrayCon(B).Name) - 5))
  802.                  If UCase$(TabFied(A).FieldName) = ConName Then
  803.                     SId = SId + 1
  804.                     ReDim Preserve ReturnVal(SId - 1)
  805.                     ReturnVal(SId - 1).FieldName = TabFied(A).FieldName
  806.                     ReturnVal(SId - 1).FieldActSize = TabFied(A).FieldActSize
  807.                     ReturnVal(SId - 1).FieldDefSize = TabFied(A).FieldDefSize
  808.                     ReturnVal(SId - 1).FieldIsNull = TabFied(A).FieldIsNull
  809.                     ReturnVal(SId - 1).FieldName = TabFied(A).FieldName
  810.                     ReturnVal(SId - 1).FieldType = TabFied(A).FieldType
  811.                     Set ReturnVal(SId - 1).FrmCon = ArrayCon(B)              '对应的控件
  812.                     '/设置字符型的数据长度.
  813.                     If UCase$(TypeName(ReturnVal(SId - 1).FrmCon)) = UCase$("TextBox"Then
  814.                         Select Case ReturnVal(SId - 1).FieldType
  815.                                Case Is = 200 'VARCHAR
  816.                                     ReturnVal(SId - 1).FrmCon.MaxLength = (ReturnVal(SId - 1).FieldDefSize) / 2
  817.                                Case Is = 202 'NVARCHAR
  818.                                     ReturnVal(SId - 1).FrmCon.MaxLength = (ReturnVal(SId - 1).FieldDefSize)
  819.                                Case Is = 129 'CHAR
  820.                                     ReturnVal(SId - 1).FrmCon.MaxLength = (ReturnVal(SId - 1).FieldDefSize) / 2
  821.                                Case Is = 130 'NCHAR
  822.                                     ReturnVal(SId - 1).FrmCon.MaxLength = (ReturnVal(SId - 1).FieldDefSize)
  823.                                Case Is = 201 'TEXT
  824.                                     ReturnVal(SId - 1).FrmCon.MaxLength = (ReturnVal(SId - 1).FieldDefSize) / 2
  825.                                Case Is = 203 'NTEXT
  826.                                     ReturnVal(SId - 1).FrmCon.MaxLength = (ReturnVal(SId - 1).FieldDefSize)
  827.                         End Select
  828.                     End If
  829.                  End If
  830.              Next
  831.          Next
  832.    End If
  833.    
  834.    Set Rs = Nothing
  835.    GetConToRs = ReturnVal
  836.    Erase ArrayCon: Erase ReturnVal
  837.    Err.Clear
  838. End Function
  839. '
  840. '返回窗体中除IMAGE字段外的所有字段名
  841. '函数名:GetFrmFld
  842. '参数:  ArrCon SmCtrlCorRs数组,TlbName 数据表名
  843. '返回值:一个以","分隔的字段列表.
  844. '例:
  845. Public Function GetFrmFld(ByRef ArrCon() As SmCtrlCorRs, TlbName As StringAs String
  846.          Dim ReturnVal As String
  847.          Dim N As Long
  848.          Dim ConName As String
  849.          
  850.          Err.Clear
  851.          On Error Resume Next
  852.          
  853.          For N = 0 To UBound(ArrCon, 1)
  854.              ConName = ArrCon(N).FrmCon.Name
  855.              If ArrCon(N).FieldType <> 205 And UCase$(Mid$(ConName, 4, 1)) = "W" Then
  856.                 ReturnVal = ReturnVal & TlbName & "." & ArrCon(N).FieldName & ","
  857.              End If
  858.          Next
  859.          If Len(ReturnVal) > 0 Then ReturnVal = Left$(ReturnVal, Len(ReturnVal) - 1)
  860.          GetFrmFld = IIf(Err.Number = 0, ReturnVal, "")
  861.          Err.Clear
  862. End Function
  863. '
  864. '从窗体的控件中生成 SQL (INSERT INTO)
  865. '函数名:GetFrmIntoSql
  866. '参数:  tArrCon() DATAFRM类型数组,DateTabName 目标数据表名.Reorder 重新定位.
  867. '返回值:Insert Inot Sql 语句
  868. '例:    FrmSql=GetFrmIntoSql(MeArrCon,"AchGoods")
  869. Function GetFrmIntoSql(P_Cnn As ADODB.Connection, ByRef ArrCon() As SmCtrlCorRs, DateTabName As StringOptional Reorder As Boolean = FalseAs String
  870.      Dim I As Long
  871.      Dim StrSql As String
  872.      Dim TmpVal As Variant
  873.      Dim FldVal As String
  874.      Dim FileSum As String
  875.      
  876.      Dim ReID As Long
  877.      Dim M As Long
  878.      Dim N As Long
  879.      
  880.      Dim TArrCon() As SmCtrlCorRs
  881.      Dim TabFldAtt() As SmFiedArrtr
  882.      Dim TmpFldAtt As SmCtrlCorRs
  883.      
  884.      Err.Clear
  885.      On Error Resume Next
  886.      
  887.      If P_Cnn.State <> 1 Then P_Cnn.Open
  888.      If Reorder Then '//重新定位.
  889.         TabFldAtt = GetTabFldAttrib(P_Cnn, DateTabName)
  890.         For N = 0 To UBound(ArrCon)
  891.             For M = 0 To UBound(TabFldAtt)
  892.                 If UCase$(ArrCon(N).FieldName) = UCase$(TabFldAtt(M).FieldName) Then
  893.                     ReID = ReID + 1
  894.                     ReDim Preserve TArrCon(ReID - 1)
  895.                     TArrCon(ReID - 1) = ArrCon(N)
  896.                 End If
  897.             Next
  898.         Next
  899.      Else
  900.         TArrCon = ArrCon
  901.      End If
  902. '***********************************************************************
  903.      For I = 0 To UBound(TArrCon, 1)
  904.         If UCase$(Mid$(TArrCon(I).FrmCon.Name, 4, 1)) = "W" Then     '将具有写标志的控件组合成SQL语句
  905.             If TArrCon(I).FieldType = 205 Or UCase$(TypeName(TArrCon(I).FrmCon)) = UCase$("PictureBox") _
  906.                Or UCase$(TypeName(TArrCon(I).FrmCon)) = UCase$("Image"Or UCase$(TypeName(TArrCon(I).FrmCon)) = UCase$("SMPICBOX"Then                    '排除IMAGE字段
  907.             '/If tArrCon(I).FieldType <> 205 Then                        '排除IMAGE字段
  908.             Else
  909.                 TmpVal = Trim$(CT.ToStr(TArrCon(I).FrmCon))                        '取值
  910.                 FileSum = FileSum & "[" & TArrCon(I).FieldName & "],"
  911.                 If Len(TmpVal) = 0 Then                           '对空或NULL的处理
  912.                    Select Case TArrCon(I).FieldType                '数据类型
  913.                           Case 2, 3, 4, 5, 6, 17, 131             '数值类型
  914.                                If TArrCon(I).FieldIsNull <> 0 Then '可接受NULL
  915.                                   FldVal = FldVal & "NULL,"
  916.                                Else
  917.                                   FldVal = FldVal & "0,"
  918.                                End If
  919.                           Case 135 '日期时间
  920.                                If TArrCon(I).FieldIsNull <> 0 Then   '可接受NULL
  921.                                   FldVal = FldVal & "NULL,"
  922.                                Else
  923.                                   If DbStyle = "MDB" Then
  924.                                      FldVal = FldVal & "#" & Now() & "#,"
  925.                                   Else
  926.                                      FldVal = FldVal & "'" & Now() & "',"
  927.                                   End If
  928.                                End If
  929.                           Case Else                               '其它类型
  930.                                If TArrCon(I).FieldIsNull <> 0 Then
  931.                                   FldVal = FldVal & "NULL,"
  932.                                Else
  933.                                   FldVal = FldVal & "'',"
  934.                                End If
  935.                    End Select
  936.                 Else
  937.                    Select Case TArrCon(I).FieldType
  938.                           Case 2, 3, 4, 5, 6, 17, 131            '数值类型
  939.                                FldVal = FldVal & "" & TmpVal & ","
  940.                           Case 135
  941.                                If DbStyle = "MDB" Then
  942.                                   FldVal = FldVal & "#" & TmpVal & "#,"
  943.                                Else
  944.                                   FldVal = FldVal & "'" & TmpVal & "',"
  945.                                End If
  946.                           Case Else                              '其它类型
  947.                                FldVal = FldVal & "'" & CT.DetSem(TmpVal) & "',"
  948.                    End Select
  949.                 End If
  950.              End If
  951.            End If
  952.         Next I
  953.     FldVal = Left$(FldVal, Len(FldVal) - 1)
  954.     FileSum = Left$(FileSum, Len(FileSum) - 1)
  955.     StrSql = "INSERT INTO [" & DateTabName & "] (" & FileSum & ") VALUES (" & FldVal & ")"
  956.     FldVal = ""
  957.     GetFrmIntoSql = IIf(Err.Number = 0, StrSql, "")
  958.     Err.Clear
  959. End Function
  960. '
  961. '从窗体的控件中生成 SQL (UPDATE)
  962. '函数名:GetFrmUpSql
  963. '参数:  ArrCon() DATAFRM类型数组,DateTabName 目标数据表名,WhereStr 更新条件
  964. '返回值:UPDATA Sql 语句
  965. '例:    FrmSql=GetFrmUpSql(MeArrCon,"AchGoods","Where gdsid='001'")
  966. Public Function GetFrmUpSql(ByRef ArrCon() As SmCtrlCorRs, _
  967.                             DateTabName As String, _
  968.                             WhereStr As StringAs String
  969.     Dim I As Long, StrSql As String
  970.     Dim TmpVal As Variant
  971.     Dim FldVal As String
  972.     Dim FileSum As String
  973.     
  974.     Err.Clear
  975.     On Error Resume Next
  976.     For I = 0 To UBound(ArrCon, 1)
  977.         If UCase$(Mid$(ArrCon(I).FrmCon.Name, 4, 1)) = "W" Then         '将具有写标志的控件组合成SQL语句
  978.             If ArrCon(I).FieldType = 205 Or UCase$(TypeName(ArrCon(I).FrmCon)) = UCase$("PictureBox") _
  979.                Or UCase$(TypeName(ArrCon(I).FrmCon)) = UCase$("Image"Or UCase$(TypeName(ArrCon(I).FrmCon)) = UCase$("SMPICBOX"Then                      '排除IMAGE字段
  980.             '/If ArrCon(I).FieldType <> 205 Then                        '排除IMAGE字段
  981.             Else
  982.                 TmpVal = Trim$(CT.ToStr(ArrCon(I).FrmCon))
  983.                 If Len(TmpVal) = 0 Then                                 '对空或NULL的处理
  984.                    Select Case ArrCon(I).FieldType
  985.                           Case 2, 3, 4, 5, 6, 17, 131                   '数值类型
  986.                                If ArrCon(I).FieldIsNull <> 0 Then        '可按受NULL
  987.                                   FldVal = FldVal & ",[" & ArrCon(I).FieldName & "]=NULL"
  988.                                Else
  989.                                   FldVal = FldVal & ",[" & ArrCon(I).FieldName & "]=0"
  990.                                End If
  991.                           Case 135 '日期
  992.                                If ArrCon(I).FieldIsNull <> 0 Then       '可接受NULL
  993.                                   FldVal = FldVal & ",[" & ArrCon(I).FieldName & "]=NULL"
  994.                                Else
  995.                                   If DbStyle = "MDB" Then
  996.                                      FldVal = FldVal & ",[" & ArrCon(I).FieldName & "]=#" & Now() & "#"
  997.                                   Else
  998.                                      FldVal = FldVal & ",[" & ArrCon(I).FieldName & "]='" & Now() & "'"
  999.                                   End If
  1000.                                End If
  1001.                           Case Else                              '其它类型
  1002.                                If ArrCon(I).FieldIsNull <> 0 Then
  1003.                                   FldVal = FldVal & ",[" & ArrCon(I).FieldName & "]=NULL"
  1004.                                Else
  1005.                                   FldVal = FldVal & ",[" & ArrCon(I).FieldName & "]=''"
  1006.                                End If
  1007.                    End Select
  1008.                 Else
  1009.                    Select Case ArrCon(I).FieldType
  1010.                           Case 2, 3, 4, 5, 6, 17, 131            '数值类型
  1011.                                FldVal = FldVal & ",[" & ArrCon(I).FieldName & "]=" & TmpVal
  1012.                           Case 135
  1013.                                If DbStyle = "MDB" Then
  1014.                                   FldVal = FldVal & ",[" & ArrCon(I).FieldName & "]=#" & TmpVal & "#"
  1015.                                Else
  1016.                                   FldVal = FldVal & ",[" & ArrCon(I).FieldName & "]='" & TmpVal & "'"
  1017.                                End If
  1018.                           Case Else                              '其它类型
  1019.                                FldVal = FldVal & ",[" & ArrCon(I).FieldName & "]='" & CT.DetSem(TmpVal) & "'"
  1020.                    End Select
  1021.                 End If
  1022.             End If
  1023.          End If
  1024.     Next
  1025.     FldVal = " Set " & Right$(FldVal, Len(FldVal) - 1) & " " & WhereStr
  1026.     StrSql = "UpDate [" & DateTabName & "]" & FldVal
  1027.     GetFrmUpSql = IIf(Err.Number = 0, StrSql, "")
  1028.     FldVal = "": StrSql = ""
  1029.     Err.Clear
  1030. End Function
  1031. '
  1032. '对窗体的所有控件赋值
  1033. '函数名:SetFrmCtrlValue
  1034. '参数:  MRs 源记录集,SetConArr DATAFRM类型数组
  1035. '返回值:
  1036. '例:    CALL SetFrmCtrlValue(RS,MEARRCON)
  1037. Public Function SetFrmCtrlValue(ByRef Rs As ADODB.Recordset, _
  1038.                                 ByRef SetConArr() As SmCtrlCorRs) As Boolean
  1039.          Dim N As Long
  1040.          Dim MRs As New ADODB.Recordset
  1041.          Dim ConTmp As Control
  1042.          Dim TmpVal As String
  1043.          Dim TmpFldName As String
  1044.          Dim TP As Picture
  1045.          
  1046.          Err.Clear
  1047.          On Error Resume Next
  1048.          
  1049.          Set TP = Nothing
  1050.          Set MRs = Rs.Clone
  1051.          If MRs.EOF And MRs.BOF Then
  1052.             MRs.AddNew
  1053.          End If
  1054.          
  1055.          For N = 0 To UBound(SetConArr, 1)
  1056.              Set ConTmp = SetConArr(N).FrmCon
  1057.              TmpFldName = SetConArr(N).FieldName
  1058.              
  1059.              If UCase$(TypeName(ConTmp)) = UCase$("OptionButton"Then
  1060.                 ConTmp = CT.ToBol(MRs.Fields(TmpFldName))
  1061.              ElseIf UCase$(TypeName(ConTmp)) = UCase$("CheckBox"Then
  1062.                 ConTmp = CT.ToLng(MRs.Fields(TmpFldName))
  1063.              ElseIf SetConArr(N).FieldType = 205 Or UCase$(TypeName(ConTmp)) = UCase$("PictureBox"Or UCase$(TypeName(ConTmp)) = UCase$("Image"Or UCase$(TypeName(ConTmp)) = UCase$("SMPICBOX"Then
  1064.              '/IMAGE字段要另行处理.在这里先清除原先图片
  1065.                  ConTmp.Picture = TP: Set ConTmp.Picture = Nothing
  1066.              ElseIf SetConArr(N).FieldType = 135 Then '日期
  1067.                 TmpVal = CT.ToStr(MRs.Fields(TmpFldName))
  1068.                 If Len(TmpVal) > 0 And IsDate(TmpVal) Then
  1069.                    If UCase$(Mid$(ConTmp.Name, 5, 1)) = "T" Then '时间
  1070.                       ConTmp = Format$(TmpVal, P_UserDataFmt.TimeFmt)
  1071.                    Else                                          '日期
  1072.                       ConTmp = Format$(TmpVal, P_UserDataFmt.DateFmt)
  1073.                    End If
  1074.                 Else
  1075.                    Err.Clear: ConTmp = ""
  1076.                    If Err.Number <> 0 Then '如果不能为NULL
  1077.                         If UCase$(Mid$(ConTmp.Name, 5, 1)) = "T" Then '时间
  1078.                            ConTmp = Format$(Now(), P_UserDataFmt.TimeFmt)
  1079.                         Else                                          '日期
  1080.                            ConTmp = Format$(Now(), P_UserDataFmt.DateFmt)
  1081.                         End If
  1082.                    End If
  1083.                 End If
  1084.              Else
  1085.                 If UCase$(Mid$(ConTmp.Name, 5, 1)) = "F" Then '如果是浮点数.
  1086.                    ConTmp = Format$(Val(CT.ToStr(MRs.Fields(TmpFldName))), "0.############")
  1087.                 Else
  1088.                    ConTmp = CT.ToStr(MRs.Fields(TmpFldName))
  1089.                 End If
  1090.              End If
  1091.          Next
  1092.          SetFrmCtrlValue = (Err.Number = 0)
  1093.          If MRs.State = adStateOpen Then
  1094.             MRs.Close
  1095.             Set MRs = Nothing
  1096.          End If
  1097.          Err.Clear
  1098.          Set ConTmp = Nothing
  1099. 'Errhan:
  1100.          
  1101. '         If Err.Number <> 0 Then
  1102. '            MsgBox Error(Err.Number) & ":" & TmpFldName
  1103. '         End If
  1104. End Function
  1105. '
  1106. '对窗体所有控件值之和
  1107. '函数名:GetAddStr
  1108. '参数:  SetConArr DATAFRM类型数组
  1109. '返回值:字符串
  1110. '例:    CALL GetAddStr(MEARRCON)
  1111. '注:主要用来判断值是否改变.
  1112. Public Function GetAddStr(ByRef SetConArr() As SmCtrlCorRs) As String
  1113.          Dim N As Long
  1114.          Dim ConTmp As Control
  1115.          Dim ReturnVal As String
  1116.          
  1117.          Err.Clear
  1118.          On Error Resume Next
  1119.          
  1120.          For N = 0 To UBound(SetConArr, 1)
  1121.              Set ConTmp = SetConArr(N).FrmCon
  1122.              If UCase$(TypeName(ConTmp)) = UCase$("PictureBox"Or UCase$(TypeName(ConTmp)) = UCase$("Image"Or UCase$(TypeName(ConTmp)) = UCase$("SMPICBOX"Then
  1123.                 ReturnVal = ReturnVal & ConTmp.Tag
  1124.              Else
  1125.                 ReturnVal = ReturnVal & CT.ToStr(ConTmp)
  1126.              End If
  1127.          Next
  1128.          GetAddStr = IIf(Err.Number = 0, ReturnVal, "")
  1129.          Set ConTmp = Nothing
  1130.          Err.Clear
  1131. End Function
  1132. '
  1133. '清空窗体中所有与数据库相关控件的数据
  1134. '函数名:ClearFrmCtrlValue
  1135. '参数:  SetConArr DATAFRM类型数组
  1136. '返回值:
  1137. '例:    CALL ClearFrmCtrlValue(MEARRCON)
  1138. Public Function ClearFrmCtrlValue(ByRef SetConArr() As SmCtrlCorRs) As Boolean
  1139.          Dim N As Long
  1140.          Dim ConTmp As Control
  1141.          Dim TP As Picture '清除图片框用.
  1142.          
  1143.          Err.Clear
  1144.          On Error Resume Next
  1145.          
  1146.          Set TP = Nothing
  1147.          For N = 0 To UBound(SetConArr, 1)
  1148.              Set ConTmp = SetConArr(N).FrmCon
  1149.              If UCase$(TypeName(ConTmp)) = UCase$("OptionButton"Then
  1150.                 ConTmp = False
  1151.              ElseIf UCase$(TypeName(ConTmp)) = UCase$("CheckBox"Then
  1152.                 ConTmp = 0
  1153.              ElseIf UCase$(TypeName(ConTmp)) = UCase$("PictureBox"Or UCase$(TypeName(ConTmp)) = UCase$("Image"Or UCase$(TypeName(ConTmp)) = UCase$("SMPICBOX"Then
  1154.                 ConTmp.Picture = TP: Set ConTmp.Picture = Nothing
  1155.              ElseIf UCase$(TypeName(ConTmp)) = UCase$("DTPicker"Or UCase$(TypeName(ConTmp)) = UCase$("MonthView"Then
  1156.                 Err.Clear: ConTmp = ""
  1157.                 If Err.Number <> 0 Then
  1158.                    ConTmp = Now()
  1159.                 End If
  1160.              Else
  1161.                 ConTmp = ""
  1162.              End If
  1163.          Next
  1164.          ClearFrmCtrlValue = (Err.Number = 0)
  1165.          Set ConTmp = Nothing
  1166.          Err.Clear
  1167. End Function
  1168. '
  1169. '读写二进制数据(流)
  1170. '函数名:AdoStream
  1171. '参数:  P_Cnn ADODB连接,TabName 目标数据表,FldName 目标字段,WhereStr 更新条件,
  1172. '       FileName 源文件名或由流生成的文件名,RsStyle 记录集的操作类型.W:File to Recode,R:Recode to File
  1173. '返回值:
  1174. '例:    CALL  AdoStream(P_Cnn,"AchGoods","GdsPhoto","Where gdsid='001'","C:/Tmp.Bmp","W")
  1175. Public Function AdoStream(P_Cnn As ADODB.Connection, _
  1176.                           TabName As String, _
  1177.                           FldName As String, _
  1178.                           Optional WhereStr As String = "", _
  1179.                           Optional Filename As String, _
  1180.                           Optional RsStyle As SmRsType = RsWrite) As String
  1181.     
  1182.     Dim StrSql As String
  1183.     Dim TmpFileName As String
  1184.     Dim Rs As New ADODB.Recordset
  1185.     Dim AdoSem As New ADODB.Stream
  1186.     Dim ReturnVal As String
  1187.     Dim WorkPath As String
  1188.     Dim RsType  As Long
  1189.     Dim RsStyleStr As String
  1190.     
  1191.     Err.Clear
  1192.     On Error Resume Next
  1193.     
  1194.     WorkPath = App.Path
  1195.     
  1196.     If P_Cnn.State <> 1 Then P_Cnn.Open
  1197.     
  1198.     If Right$(WorkPath, 1) <> "/" Then WorkPath = WorkPath & "/"
  1199.     ReturnVal = ""
  1200.     AdoSem.Type = adTypeBinary    '流数据类型
  1201.     AdoSem.Open                  '打开流
  1202. '/-----------------------------------------------------------
  1203.     '将流写入记录集
  1204.     RsType = RsStyle
  1205.     RsStyleStr = Choose(RsType, "W""R")
  1206.     If RsStyleStr = "W" Then
  1207.         If Left$(Trim$(UCase$(WhereStr)), Len("where")) <> UCase$("where"Then WhereStr = " Where " & Trim$(WhereStr)
  1208.         StrSql = "Select Top 1 [" & TabName & "].[" & FldName & "] From [" & TabName & "] " & WhereStr
  1209.         Set Rs = RsOpen(P_Cnn, StrSql, False)  '连接式记录集
  1210.         If Not (Rs.EOF And Rs.BOF) Then
  1211.             Rs.MoveFirst
  1212.             AdoSem.LoadFromFile Filename            '将文件LOAD到流
  1213.             DoEvents
  1214.             Rs.Fields(FldName).AppendChunk AdoSem.Read
  1215.             Rs.Update
  1216.         End If
  1217.         AdoStream = ""
  1218.     ElseIf RsStyle = "R" Then
  1219.         '/将流从记录集中取出
  1220.         If Len(Trim$(Filename)) = 0 Then Filename = "TmpFile.Bmp"
  1221.         If Len(Trim$(Dir$(TmpFileName, vbNormal + vbHidden))) > 0 Then Kill Filename
  1222.         If Left$(Trim$(UCase$(WhereStr)), Len("where")) <> UCase$("where"Then WhereStr = " Where " & Trim$(WhereStr)
  1223.         
  1224.         StrSql = "Select Top 1 [" & TabName & "].[" & FldName & "] From [" & TabName & "] " & WhereStr
  1225.         Set Rs = RsOpen(P_Cnn, StrSql)
  1226.         If Not (Rs.EOF And Rs.BOF) Then
  1227.             Rs.MoveFirst
  1228.             If Not (IsNull(Rs.Fields(FldName))) Then
  1229.                 TmpFileName = WorkPath & Filename
  1230.                 AdoSem.Write Rs.Fields(FldName).GetChunk(Rs.Fields(FldName).ActualSize)
  1231.                 DoEvents
  1232.                 AdoSem.SaveToFile TmpFileName, IIf(Len(Trim$(Dir$(TmpFileName, vbNormal + vbHidden))) > 0, adSaveCreateOverWrite, adSaveCreateNotExist)
  1233.                 AdoStream = TmpFileName
  1234.             Else
  1235.                 AdoStream = ""
  1236.             End If
  1237.         Else
  1238.             AdoStream = ""
  1239.         End If
  1240.     End If
  1241.     If AdoSem.State = adStateOpen Then
  1242.        AdoSem.Close
  1243.        Set AdoSem = Nothing
  1244.     End If
  1245.     
  1246.     If Rs.State = adStateOpen Then
  1247.        Rs.Close
  1248.        Set Rs = Nothing
  1249.     End If
  1250.     Err.Clear
  1251. End Function
  1252. '将二进制文件添加到数据库中(该记录必须在存在)
  1253. '函数名:FileToRecode
  1254. '参数:  P_Cnn ADODB连接,TabName 目标数据表,FldName 目标字段,WhereStr 更新条件,FileName 源文件名
  1255. '返回值:
  1256. '例:    CALL  FileToRecode(P_Cnn,"AchGoods","GdsPhoto","Where gdsid='001'","C:/Tmp.Bmp")
  1257. Public Function FileToRecode(ByRef P_Cnn As ADODB.Connection, _
  1258.                              TabName As String, _
  1259.                              FldName As String, _
  1260.                              WhereStr As String, _
  1261.                              Filename As StringAs Boolean
  1262.     
  1263.     Dim RsB As New ADODB.Recordset
  1264.     Dim Person_name As String
  1265.     Dim StrSql As String
  1266.     Dim File_Num As String
  1267.     Dim File_Length As String
  1268.     Dim Bytes() As Byte
  1269.     Dim Num_Blocks As Long
  1270.     Dim Left_Over As Long
  1271.     Dim Block_Num As Long
  1272.     
  1273.     Err.Clear
  1274.     On Error Resume Next
  1275.     
  1276.     File_Num = FreeFile
  1277.     Filename = Trim$(Filename)
  1278.     
  1279.     If P_Cnn.State <> 1 Then P_Cnn.Open
  1280.     
  1281.     If Len(Dir$(Filename)) = 0 Or Len(Filename) = 0 Then FileToRecode = FalseExit Function
  1282.     
  1283.     Open Filename For Binary Access Read As #File_Num
  1284.         File_Length = LOF(File_Num)                 '取文件大小
  1285.         If File_Length > 0 Then
  1286.             Num_Blocks = File_Length / Block_Size
  1287.             Left_Over = File_Length Mod Block_Size
  1288.             
  1289.             If Left$(Trim$(UCase$(WhereStr)), Len("where")) <> UCase$("where"Then WhereStr = "Where " & Trim$(WhereStr)
  1290.             StrSql = "Select Top 1 [" & TabName & "].[" & FldName & "] From [" & TabName & "] " & WhereStr
  1291.             Set RsB = RsOpen(P_Cnn, StrSql, False'连接式记录集
  1292.             If Not (RsB.EOF And RsB.BOF) Then
  1293.             
  1294. '/            '不分块写
  1295. '/            ReDim Bytes(File_Length)
  1296. '/            Get #File_Num, , Bytes()
  1297. '/            DoEvents
  1298. '/            RsB.Fields(FldName).AppendChunk Bytes()
  1299.             '/分块写
  1300.                 ReDim Bytes(Block_Size)
  1301.                 For Block_Num = 1 To Num_Blocks
  1302.                     Get #File_Num, , Bytes()
  1303.                     RsB.Fields(FldName).AppendChunk Bytes()
  1304.                 Next
  1305.                 
  1306.                 If Left_Over > 0 Then
  1307.                     ReDim Bytes(Left_Over)
  1308.                     Get #File_Num, , Bytes()
  1309.                     RsB.Fields(FldName).AppendChunk Bytes()
  1310.                 End If
  1311.                 RsB.Update
  1312.                 DoEvents
  1313.             End If
  1314.             If RsB.State = adStateOpen Then
  1315.                RsB.Close
  1316.                Set RsB = Nothing
  1317.             End If
  1318.         End If
  1319.     Close #File_Num
  1320.     Erase Bytes
  1321.     FileToRecode = (Err.Number = 0)
  1322.     Err.Clear
  1323. End Function
  1324. '
  1325. '将二进制数据从记录中取出
  1326. '函数名:RecodeToFile
  1327. '参数:  P_Cnn ADODB连接,TabName 源数据表,FldName 源字段名, WhereStr 取字段条件,FileType 生成临时文件的类型
  1328. '返回值:'一个临时文件名
  1329. '例:    GetTmpFile=RecodeToFile(P_Conn,"achgoods","achphoto","where gdsid='001',"bmp")
  1330. Public Function RecodeToFile(ByRef P_Cnn As ADODB.Connection, _
  1331.                              TabName As String, _
  1332.                              FldName As String, _
  1333.                              WhereStr As String, _
  1334.                              Optional FileType As String = "Bmp"As String
  1335.     
  1336.     Dim Rs As New ADODB.Recordset
  1337.     Dim StrSql As String
  1338.     
  1339.     Dim Bytes() As Byte
  1340.     Dim File_Name As String
  1341.     Dim File_Num As Integer
  1342.     Dim File_Length As Long
  1343.     Dim Num_Blocks As Long
  1344.     Dim Left_Over As Long
  1345.     Dim Block_Num As Long
  1346.     Dim WorkPath As String
  1347.     Dim TmpDir As New SmSysCls
  1348.     
  1349.     Err.Clear
  1350.     On Error Resume Next
  1351.     
  1352.      WorkPath = TmpDir.GetFolder(SmWinTempDirectory)
  1353.      If Dir$(WorkPath, vbDirectory) = "" Then WorkPath = App.Path
  1354.      If Right$(WorkPath, 1) <> "/" Then WorkPath = WorkPath & "/"
  1355.     
  1356.      If Left$(Trim$(UCase$(WhereStr)), Len("where")) <> UCase$("where"Then WhereStr = "Where " & Trim$(WhereStr)
  1357.      StrSql = "Select Top 1 [" & TabName & "].[" & FldName & "] From [" & TabName & "] " & WhereStr
  1358.      Set Rs = RsOpen(P_Cnn, StrSql)
  1359.      If Rs.BOF And Rs.EOF Then Exit Function
  1360.      
  1361.      If P_Cnn.State <> 1 Then P_Cnn.Open
  1362.      
  1363.      If Not IsNull(Rs.Fields(FldName)) Then
  1364.          File_Name = WorkPath & "TmpFile." & FileType
  1365.          If Len(Dir(File_Name)) <> 0 Then Kill File_Name
  1366.          File_Num = FreeFile
  1367.          Open File_Name For Binary As #File_Num
  1368.              File_Length = CT.ToLng(Rs.Fields(FldName).ActualSize) '取字段的实际大小
  1369. '/不分块读写
  1370. '/             If File_Length > 0 Then
  1371. '/                Bytes() = Rs.Fields(FldName).GetChunk(File_Length)
  1372. '/                Put #File_Num, , Bytes()
  1373. '/             Else
  1374. '/                Err = -1
  1375. '/             End If
  1376. '/分块读写
  1377.              Num_Blocks = File_Length / Block_Size
  1378.              Left_Over = File_Length Mod Block_Size
  1379.              For Block_Num = 1 To Num_Blocks
  1380.                  Bytes() = Rs.Fields(FldName).GetChunk(Block_Size)
  1381.                  Put #File_Num, , Bytes()
  1382.              Next
  1383.              If Left_Over > 0 Then
  1384.                  Bytes() = Rs.Fields(FldName).GetChunk(Left_Over)
  1385.                  Put #File_Num, , Bytes()
  1386.              End If
  1387.              Erase Bytes
  1388.          Close #File_Num
  1389.          
  1390.         If Rs.State = adStateOpen Then
  1391.            Rs.Close
  1392.            Set Rs = Nothing
  1393.         End If
  1394.             
  1395.          Erase Bytes
  1396.     End If
  1397.     RecodeToFile = IIf(Err.Number = 0, File_Name, "")
  1398.     Set TmpDir = Nothing
  1399.     Err.Clear
  1400. End Function
  1401. '
  1402. '对组合框赋值(直接从数据库取值,如果有多个值,则只取第一个值.)
  1403. '函数名:SetFrmCtrlValue
  1404. '参数:  P_Cnn ADODB连接,StrSql 取值SQL语句,CtrFiedList 动态参数列表
  1405. '返回值:
  1406. '例:    CALL SetGroupVal(P_Cnn,"Select AchGds.* From AchGds Where GdsID='001'",TxtWNGdsID,"GdsID",TxtWNGdsName,"GdsName")
  1407. '*注:动态参数列表(CtrFiedList)的奇数位是 目标名,偶数位 是对应字段名.
  1408. Public Function SetGroupVal(ByRef P_Cnn As ADODB.Connection, _
  1409.                             StrSql As String, _
  1410.                             ParamArray CtrFiedList() As VariantAs Boolean
  1411.        
  1412.        Dim Rs As New ADODB.Recordset
  1413.        Dim N As Long
  1414.        Dim id As Long
  1415.        Dim ConFiedArr() As SmPutGroup
  1416.        Dim ReturnVal As Boolean
  1417.        
  1418.        Err.Clear
  1419.        On Error Resume Next
  1420.        
  1421.        ReturnVal = False
  1422.        
  1423.        If P_Cnn.State <> 1 Then P_Cnn.Open
  1424.        
  1425.        Set Rs = RsOpen(P_Cnn, StrSql)
  1426.        If Not (Rs.EOF And Rs.BOF) Then
  1427.             Rs.MoveFirst
  1428.             id = 0
  1429.             '/分解控件与字段名
  1430.             For N = 0 To UBound(CtrFiedList, 1)
  1431.                 If N Mod 2 = 0 Then
  1432.                    id = id + 1
  1433.                    ReDim Preserve ConFiedArr(id - 1)
  1434.                    '/控件
  1435.                    Set ConFiedArr(id - 1).FrmControl = CtrFiedList(N)
  1436.                 Else
  1437.                    '/字段名
  1438.                    ConFiedArr(id - 1).FldName = CtrFiedList(N)
  1439.                 End If
  1440.             Next
  1441.             '/对控件赋值
  1442.             For N = 0 To UBound(ConFiedArr, 1)
  1443.                 ConFiedArr(N).FrmControl = CStr("" & (Rs.Fields(ConFiedArr(N).FldName)))
  1444.             Next
  1445.             ReturnVal = True
  1446.        Else
  1447.             ReturnVal = False
  1448.        End If
  1449.        SetGroupVal = ReturnVal
  1450.        
  1451.         If Rs.State = adStateOpen Then
  1452.            Rs.Close
  1453.            Set Rs = Nothing
  1454.         End If
  1455.         Err.Clear
  1456. End Function
  1457. '
  1458. '返回单个数据字段值.
  1459. '函数名:SetFrmCtrlValue
  1460. '参数:  P_Cnn ADODB连接,DbTabName 源数据表名,FldName 源数据字段名,WhereStr 取值的条件语句
  1461. '返回值:相对应的字段值
  1462. '例:    GdsNameVal=GetOneValue(P_CNN,"ACHGOODS","GDSNAME","WHERE GDSID='001'")
  1463. Public Function GetOneValue(ByRef P_Cnn As ADODB.Connection, _
  1464.                             DbTabname As String, _
  1465.                             FldName As String, _
  1466.                             WhereStr As StringAs String
  1467.        Dim StrSql As String
  1468.        Dim Rs As New ADODB.Recordset
  1469.               
  1470.        Err.Clear
  1471.        On Error Resume Next
  1472.        
  1473.        If P_Cnn.State <> 1 Then P_Cnn.Open
  1474.        
  1475.        If Left$(Trim$(UCase$(WhereStr)), Len("where")) <> UCase$("where"Then WhereStr = "Where " & Trim$(WhereStr)
  1476.        StrSql = "Select Top 1 [" & DbTabname & "].[" & FldName & "] From [" & DbTabname & "] " & WhereStr
  1477.        Set Rs = RsOpen(P_Cnn, StrSql)
  1478.        If Not (Rs.EOF And Rs.BOF) Then
  1479.           Rs.MoveFirst
  1480.           GetOneValue = CT.ToStr(Rs.Fields(FldName))
  1481.        Else
  1482.           GetOneValue = ""
  1483.        End If
  1484.         If Rs.State = adStateOpen Then
  1485.            Rs.Close
  1486.            Set Rs = Nothing
  1487.         End If
  1488.         Err.Clear
  1489. End Function
  1490. '
  1491. '删除记录
  1492. '函数:KillRecode
  1493. '参数:FldName 字段名,FldVal 字段值,TabName 表名
  1494. '
  1495. Function KillRecode(ByRef P_Cnn As ADODB.Connection, _
  1496.                     TabName As String, _
  1497.                     FldName As String, _
  1498.                     FldVal As String)
  1499.          Dim StrSql As String
  1500.          
  1501.          If P_Cnn.State <> 1 Then P_Cnn.Open
  1502.          
  1503.          StrSql = "Delete " & TabName & "  From " & TabName & " Where " & FldName & "='" & FldVal & "'"
  1504.          P_Cnn.Execute StrSql
  1505.          Err.Clear
  1506. End Function
  1507. '
  1508. '取最大单号
  1509. '前二位.单据类型.+四位年+二位月+二位日+4位单据流水号
  1510. '函数:GetMaxBillID
  1511. '参数:FldName 字段名(BillID),BillStyle 单据类型,TabName 表名
  1512. '返回值:可用最大单号
  1513. Function GetMaxBillID(ByRef P_Cnn As ADODB.Connection, _
  1514.                       TabName As String, _
  1515.                       FldName As String, _
  1516.                       BillStyle As StringAs String
  1517.          
  1518.          Dim BillSD As String
  1519.          Dim StrSql As String
  1520.          Dim Rs As New ADODB.Recordset
  1521.          Dim BillNo As Long
  1522.          Dim NewBillID As Long
  1523.          Dim lLen As Long
  1524.          Dim ReturnVal As String
  1525.          Dim RNum As Long
  1526.          Dim RLen As Long
  1527.          Dim FmtStr As String
  1528.          Dim N As Long
  1529.          
  1530.          Err.Clear
  1531.          On Error Resume Next
  1532.          
  1533.          If P_Cnn.State <> 1 Then P_Cnn.Open
  1534.          
  1535.          BillSD = BillStyle & Format$(Date"YYYYMMDD")
  1536.          '/--------------------------------------------------
  1537.          lLen = Len(BillSD): RLen = 4 '单据流水号位数
  1538.          '/--------------------------------------------------
  1539.          For N = 1 To RLen
  1540.              FmtStr = FmtStr & "0"
  1541.          Next
  1542.          '/--------------------------------------------------
  1543.          StrSql = "Select (Max(" & FldName & ")) AS MaxID From " & TabName & " Where LEFT(" & FldName & "," & lLen & ")='" & BillSD & "'"
  1544.          Set Rs = RsOpen(P_Cnn, StrSql)
  1545.          If Not (Rs.EOF And Rs.BOF) Then
  1546.             If Len(CT.ToStr(Rs.Fields("MaxID"))) > 0 Then
  1547.                RNum = Right$(CT.ToStr(Rs.Fields("MaxID")), RLen)
  1548.             Else
  1549.                RNum = 0
  1550.             End If
  1551.             NewBillID = CT.ToLng(RNum) + 1
  1552.          Else
  1553.             NewBillID = 1
  1554.          End If
  1555.         If Rs.State = adStateOpen Then
  1556.            Rs.Close
  1557.            Set Rs = Nothing
  1558.         End If
  1559.          ReturnVal = BillSD & "-" & Format$(NewBillID, FmtStr)
  1560.          GetMaxBillID = IIf(Err.Number = 0, ReturnVal, "")
  1561.          Err.Clear
  1562. End Function
  1563. '
  1564. '压缩MDB数据库
  1565. '函数名:ZipMdb
  1566. '参数:P_Cnn ADODB连接,SourFileName 源文件名,ObjFileName 目标文件名,
  1567. '     Provider Provider参数(视JET版而定,默认是4.0),UserID 用户名,
  1568. '     UserPwd 密码
  1569. '返回值:TRUE 成功,FALSE 失败.
  1570. Public Function ZipMdb(P_Cnn As ADODB.Connection, _
  1571.                        MdbFileName As String, _
  1572.                        Optional Provider As String = "Microsoft.Jet.OLEDB.4.0", _
  1573.                        Optional UserID As String = "admin", _
  1574.                        Optional UserPwd As String = ""As Boolean
  1575.     
  1576.     Dim Yjro As New JRO.JetEngine
  1577.     Dim WorkPath As String
  1578.     Dim TmpName As String
  1579.     Dim FileCon As SmFileCls
  1580.      
  1581.     Err.Clear
  1582.     On Error Resume Next
  1583.     '/关闭连接
  1584.     P_Cnn.Close: Set P_Cnn = Nothing
  1585.     DoEvents
  1586.     WorkPath = FileCon.FilePath(MdbFileName)
  1587.     TmpName = WorkPath & "mdbTmp.bak"
  1588.     '/-------------------------------
  1589.     DoEvents
  1590.     '/压缩
  1591.     Yjro.CompactDatabase "Provider=" & Provider & ";Data Source=" & MdbFileName & ";" & _
  1592.                          "Jet OLEDB:Database Password=" & UserPwd & ";" & _
  1593.                          "User ID=" & UserID & ";", _
  1594.                          "Provider=" & Provider & ";Data Source=" & TmpName & ";" & _
  1595.                          "Jet OLEDB:Database Password=" & UserPwd & ";" & _
  1596.                          "User ID=" & UserID & ";"
  1597.     DoEvents
  1598.     '/删除旧文件,将压缩后的文件COPY到旧位置
  1599.     If FileCon.FileCheck(MdbFileName) And FileCon.FileCheck(TmpName) Then
  1600.         Kill MdbFileName
  1601.         DoEvents
  1602.         Call FileCopy(TmpName, MdbFileName)
  1603.         DoEvents
  1604.         Kill TmpName
  1605.         DoEvents
  1606.         '/重新连接
  1607.         Call CreateMdbConn(P_Cnn, MdbFileName, , UserID, UserPwd)
  1608.     Else
  1609.         Err.Number = -1
  1610.     End If
  1611.     Set Yjro = Nothing
  1612.     Set FileCon = Nothing
  1613.     Err.Clear
  1614.     ZipMdb = (Err.Number = 0)
  1615.     Err.Clear
  1616. End Function
  1617. '
  1618. '恢复和备份MDB数据库
  1619. '函数名:BakResumeMdb
  1620. '参数:P_Cnn ADODB连接,SourFileName 源文件名,ObjFileName 目标文件名,
  1621. '     Provider Provider参数(视JET版而定,默认是4.0),UserID 用户名,
  1622. '     UserPwd 密码,WorkType 操作类型(0 备份,1 恢复)
  1623. '返回值:TRUE 成功,FALSE 失败.
  1624. '注:当WorkType=0时,源文件名是要备份文件,目标文件名是备份文件.
  1625. '   当WorkType=1时,源文件名是备份文件,目标文件名要恢复的文件.
  1626. Public Function BakResumeMDB(P_Cnn As ADODB.Connection, _
  1627.                        SourFileName As String, _
  1628.                        ObjFileName As String, _
  1629.                        Optional Provider As String = "Microsoft.Jet.OLEDB.4.0", _
  1630.                        Optional UserID As String = "admin", _
  1631.                        Optional UserPwd As String = "", _
  1632.                        Optional WorkType As Long = 0) As Boolean
  1633.     
  1634.     Dim Yjro As New JRO.JetEngine
  1635.     Dim WorkPath As String
  1636.     Dim FileCon As New SmFileCls
  1637.     
  1638.     Err.Clear
  1639.     On Error Resume Next
  1640.     '/关闭连接
  1641.     P_Cnn.Close: Set P_Cnn = Nothing
  1642.     DoEvents
  1643.     '/-------------------------------
  1644.     '/压缩
  1645.     Yjro.CompactDatabase "Provider=" & Provider & SourFileName & ";" & _
  1646.                          "Jet OLEDB:Database Password=" & UserPwd & ";" & _
  1647.                          "User ID=" & UserID & ";", _
  1648.                          "Provider=" & Provider & ";Data Source=" & ObjFileName & ";" & _
  1649.                          "Jet OLEDB:Database Password=" & UserPwd & ";" & _
  1650.                          "User ID=" & UserID & ";"
  1651.     DoEvents
  1652.     '/删除旧文件,将压缩后的文件COPY到旧位置
  1653.     If Not (FileCon.FileCheck(SourFileName) And FileCon.FileCheck(ObjFileName)) Then
  1654.        If WorkType = 0 Then
  1655.           '/备份。
  1656.           Call CreateMdbConn(P_Cnn, SourFileName, , UserID, UserPwd)
  1657.        Else
  1658.           '/恢复
  1659.           Call CreateMdbConn(P_Cnn, ObjFileName, , UserID, UserPwd)
  1660.        End If
  1661.        Err.Number = -1
  1662.     End If
  1663.     Set FileCon = Nothing
  1664.     Set Yjro = Nothing: Err.Clear
  1665.     BakResumeMDB = (Err.Number = 0)
  1666.     Err.Clear
  1667. End Function
  1668. '
  1669. '解读身份证信息
  1670. '函数名:GetIDCard
  1671. '参数:P_Cnn ADODB连接,IDCode 身份证编号,RevCodeInfo EmpCodeInfo(用于返回),
  1672. '返回值:无
  1673. Public Function GetIDCard(ByRef P_Cnn As ADODB.Connection, IDCode As StringByRef RevCodeInfo As EmpCodeInfo)
  1674.         Dim Rs As New ADODB.Recordset
  1675.         Dim StrSql As String
  1676.         Dim I As Long
  1677.         Dim TAdd(6) As String
  1678.         Dim AddStr(6) As String
  1679.         Dim UserAdd As String
  1680.         Dim BirthStr As String
  1681.         Dim SexStr As String
  1682.         
  1683.         Err.Clear
  1684.         On Error Resume Next
  1685.         
  1686.         AddStr(0) = Left$(IDCode, 2) & "0000" '省
  1687.         AddStr(1) = Left$(IDCode, 4) & "00"   '市
  1688.         AddStr(2) = Left$(IDCode, 6)          '县及县级市
  1689.         UserAdd = ""
  1690.         
  1691.         If P_Cnn.State <> 1 Then P_Cnn.Open
  1692.         
  1693.         '取籍贯
  1694.         For I = 0 To UBound(AddStr)
  1695.             If Len(AddStr(I)) > 0 Then
  1696.                StrSql = "SELECT * FROM [Reglism] Where Code='" & AddStr(I) & "'"
  1697.                Set Rs = Nothing
  1698.                Rs.Open StrSql, P_Cnn, adOpenStatic, adLockReadOnly
  1699.                If Not (Rs.EOF And Rs.BOF) Then
  1700.                   TAdd(I) = "" & Rs.Fields("Name")
  1701.                   UserAdd = UserAdd & Rs.Fields("Name")
  1702.                End If
  1703.             End If
  1704.         Next
  1705.         RevCodeInfo.NativePlace = UserAdd
  1706.         '取电话区号
  1707.         For I = UBound(TAdd) To 0 Step -1
  1708.             If Len(TAdd(I)) > 1 Then
  1709.                 TAdd(I) = Left$(TAdd(I), 2)
  1710.                 StrSql = "SELECT * FROM [PhoCode] WHERE [Name] like '" & TAdd(I) & "%'"
  1711.                 Set Rs = Nothing
  1712.                 Rs.Open StrSql, P_Cnn, adOpenStatic, adLockReadOnly
  1713.                 If Not (Rs.EOF And Rs.BOF) Then
  1714.                    Rs.MoveFirst
  1715.                    RevCodeInfo.PhoCode = Format$(Rs.Fields("Code"), "0000")
  1716.                    Exit For
  1717.                 End If
  1718.             End If
  1719.         Next
  1720.         '取邮政编码
  1721.         For I = UBound(TAdd) To 0 Step -1
  1722.             If Len(TAdd(I)) > 1 Then
  1723.                 TAdd(I) = Left$(TAdd(I), 2)
  1724.                 StrSql = "SELECT * FROM [MailCode] WHERE [Name] Like '" & TAdd(I) & "%'"
  1725.                 Set Rs = Nothing
  1726.                 Rs.Open StrSql, P_Cnn, adOpenStatic, adLockReadOnly
  1727.                 If Not (Rs.EOF And Rs.BOF) Then
  1728.                    Rs.MoveFirst
  1729.                    RevCodeInfo.MailCode = Format$(Rs.Fields("Code"), "0000")
  1730.                    Exit For
  1731.                 End If
  1732.             End If
  1733.         Next
  1734.         '生日/性别
  1735.         If Len(IDCode) = 15 Then '旧身份证号码.
  1736.             BirthStr = Mid$(IDCode, 7, Len(IDCode) - 6 - 3) '出生日期
  1737.             BirthStr = "19" & BirthStr
  1738.             SexStr = CLng(Right$(IDCode, 1)) Mod 2 '顺序码奇数是男.偶数是女
  1739.         Else                         '新身份证号码.
  1740.             BirthStr = Mid$(IDCode, 7, Len(IDCode) - 6 - 4) '出生日期
  1741.             SexStr = CLng(Mid$(IDCode, Len(IDCode) - 3, 3)) Mod 2 '顺序码奇数是男.偶数是女
  1742.         End If
  1743.         BirthStr = Left$(BirthStr, 4) & "/" & Mid$(BirthStr, 5, 2) & "/" & Right$(BirthStr, 2)
  1744.         RevCodeInfo.Birthday = BirthStr
  1745.         RevCodeInfo.Sex = SexStr
  1746.         
  1747.         If Rs.State = adStateOpen Then
  1748.            Rs.Close
  1749.            Set Rs = Nothing
  1750.         End If
  1751.         Err.Clear
  1752. End Function
  1753. Private Sub Class_Initialize()
  1754.     Dim T As New ClsRev
  1755.     
  1756.     Set CT = New SmDataDiap
  1757.     Call T.GetIniVal
  1758.     Set T = Nothing
  1759. End Sub
  1760. Private Sub Class_Terminate()
  1761.         On Error Resume Next
  1762.         Set CT = Nothing
  1763. End Sub
  1764. '
  1765. '取局域网中所有SQL SERVER 服务器名称
  1766. '函数名:AddSqlServer
  1767. '参数:
  1768. '返回值:字符串数组
  1769. '引用SQLDMO LIB
  1770. Public Function AddSqlServer() As String()
  1771. '    Dim Server As SQLDMO.NameList
  1772. '    Dim appDMO As New SQLDMO.Application
  1773. '    Dim I As Long
  1774. '    Dim StrRev() As String
  1775. '
  1776. '    On Error Resume Next
  1777. '
  1778. '    Set Server = appDMO.ListAvailableSQLServers
  1779. '    For I = 1 To Server.Count
  1780. '        ComNNServerName.AddItem Server(I)
  1781. '        ReDim Preserve StrRev(I)
  1782. '        StrRev(I) = Server(I)
  1783. '    Next
  1784. '    Set Server = Nothing
  1785. '    Set appDMO = Nothing
  1786.     
  1787.     Dim oSQLServerDMOApp   As Object
  1788.     Dim I   As Integer
  1789.     Dim namX   As Object
  1790.     Dim StrRev() As String
  1791.     
  1792.     Err.Clear
  1793.     On Error Resume Next
  1794.     Set oSQLServerDMOApp = CreateObject("SQLDMO.Application")
  1795.     If oSQLServerDMOApp Is Nothing Then Exit Function
  1796.     Set namX = oSQLServerDMOApp.ListAvailableSQLServers
  1797.     For I = 1 To namX.Count
  1798.         ReDim Preserve StrRev(I - 1)
  1799.         StrRev(I - 1) = namX.Item(I)
  1800.     Next
  1801.     AddSqlServer = StrRev
  1802.     Set namX = Nothing
  1803. End Function
  1804. '
  1805. '对TDBGRID表格赋值.
  1806. Public Function SetGrdGroupVal(ByRef P_Cnn As ADODB.Connection, _
  1807.                                ByRef MRs As ADODB.Recordset, _
  1808.                                RepeaFldList As String, _
  1809.                                StrSql As String, _
  1810.                                ConAndFiedList As VariantAs Boolean
  1811.        
  1812.        Dim Rs As New ADODB.Recordset
  1813.        Dim N As Long
  1814.        Dim id As Long
  1815.        Dim ConFiedArr() As SmPutGroup
  1816.        Dim ReturnVal As Boolean
  1817.         
  1818.        Dim TRs As New ADODB.Recordset
  1819.        Dim RepFld() As String
  1820.         
  1821.        On Error Resume Next
  1822.         
  1823.        If P_Cnn.State <> 1 Then P_Cnn.Open
  1824.        ReturnVal = False
  1825.        Set Rs = RsOpen(P_Cnn, StrSql)
  1826.        If Not (Rs.EOF And Rs.BOF) Then
  1827.             Rs.MoveFirst
  1828.             id = 0
  1829.             '/分解控件与字段名.
  1830.             For N = 0 To UBound(ConAndFiedList, 1)
  1831.                 If N Mod 2 = 0 Then
  1832.                    id = id + 1
  1833.                    ReDim Preserve ConFiedArr(id - 1)
  1834.                    '/控件.
  1835.                    Set ConFiedArr(id - 1).FrmControl = ConAndFiedList(N)
  1836.                 Else
  1837.                    '/字段名.
  1838.                    ConFiedArr(id - 1).FldName = ConAndFiedList(N)
  1839.                 End If
  1840.             Next
  1841.             '/对控件赋值.
  1842.             MRs.AddNew: MRs.MoveLast
  1843.             For N = 0 To UBound(ConFiedArr, 1)
  1844.                 ConFiedArr(N).FrmControl = CStr("" & Rs.Fields(ConFiedArr(N).FldName))
  1845.             Next
  1846.             ReturnVal = True
  1847.        Else
  1848.             ReturnVal = False
  1849.        End If
  1850.        SetGrdGroupVal = ReturnVal
  1851.         If Rs.State = adStateOpen Then
  1852.             Rs.Close
  1853.             Set Rs = Nothing
  1854.         End If
  1855.         Err.Clear
  1856. End Function
  1857. '从RS到RS赋值.
  1858. Public Function SetRsToRs(ByRef SourRs As ADODB.Recordset, _
  1859.                           ByRef ObjRs As ADODB.Recordset, _
  1860.                           FldList As String, _
  1861.                           Optional BlnAddNew As Boolean = FalseAs Boolean
  1862.        Dim RsB As New ADODB.Recordset
  1863.        Dim N As Long
  1864.        Dim id As Long
  1865.        Dim SpArr() As String
  1866.        Dim EvaArr() As String
  1867.        Dim FldArr() As SmGrdGroup
  1868.        Dim ReturnVal As Boolean
  1869.        Dim TmpStr() As String
  1870.         
  1871.        Err.Clear
  1872.        On Error Resume Next
  1873.        ReturnVal = False
  1874.        If Not (SourRs.EOF And SourRs.BOF) Then
  1875.             id = 0
  1876.             SpArr = Split(FldList, ",")
  1877.             For N = 0 To UBound(SpArr)
  1878.                 If Len(SpArr(N)) > 0 And InStr(SpArr(N), "=") > 0 Then
  1879.                     Erase TmpStr
  1880.                     TmpStr = Split(SpArr(N), "=")
  1881.                     If Len(TmpStr(0)) > 0 And Len(TmpStr(1)) > 0 Then
  1882.                         id = id + 1
  1883.                         ReDim Preserve FldArr(id - 1)
  1884.                         FldArr(id - 1).ObjFldName = Trim$(TmpStr(0))
  1885.                         FldArr(id - 1).SourFldName = Trim$((TmpStr(1)))
  1886.                     End If
  1887.                 End If
  1888.             Next
  1889.             
  1890.             If UBound(FldArr, 1) > 0 Then
  1891.                 If BlnAddNew Then ObjRs.AddNew  '新增
  1892.                 For N = 0 To UBound(FldArr, 1)
  1893.                     ObjRs.Fields(FldArr(N).ObjFldName) = SourRs.Fields(FldArr(N).SourFldName)
  1894.                 Next
  1895.                 ReturnVal = True
  1896.             Else
  1897.                 ReturnVal = False
  1898.             End If
  1899.             
  1900.        Else
  1901.             ReturnVal = False
  1902.        End If
  1903.        SetRsToRs = ReturnVal
  1904.        Err.Clear
  1905. End Function
  1906. '
  1907. '对组合框赋值(直接从数据库取值,如果有多个值,则只取第一个值.)
  1908. '函数名:SetFrmCtrlValue
  1909. '参数:  P_Cnn ADODB连接,StrSql 取值SQL语句,ConAndFiedList 动态参数列表(注意,这里的列表是作为一个数组)
  1910. '返回值:
  1911. '例:    CALL SetGroupValB(P_Cnn,"Select AchGds.* From AchGds Where GdsID='001'",TxtWNGdsID,"GdsID",TxtWNGdsName,"GdsName")
  1912. '*注:动态参数列表(CtrFiedList)的奇数位是 目标名,偶数位 是对应字段名.
  1913. '组合框赋值
  1914. Public Function SetGroupValB(ByRef P_Cnn As ADODB.Connection, _
  1915.                             StrSql As String, _
  1916.                             ConAndFiedList As VariantAs Boolean
  1917.        Dim Rs As New ADODB.Recordset
  1918.        Dim N As Long
  1919.        Dim id As Long
  1920.        Dim ConFiedArr() As SmPutGroup
  1921.        Dim ReturnVal As Boolean
  1922.        
  1923.        Err.Clear
  1924.        On Error Resume Next
  1925.        
  1926.        ReturnVal = False
  1927.        If P_Cnn.State <> 1 Then P_Cnn.Open
  1928.        Set Rs = RsOpen(P_Cnn, StrSql)
  1929.        If Not (Rs.EOF And Rs.BOF) Then
  1930.             Rs.MoveFirst
  1931.             id = 0
  1932.             '/分解控件与字段名.
  1933.             For N = 0 To UBound(ConAndFiedList, 1)
  1934.                 If N Mod 2 = 0 Then
  1935.                    id = id + 1
  1936.                    ReDim Preserve ConFiedArr(id - 1)
  1937.                    '/控件
  1938.                    Set ConFiedArr(id - 1).FrmControl = ConAndFiedList(N)
  1939.                 Else
  1940.                    '/字段名
  1941.                    ConFiedArr(id - 1).FldName = ConAndFiedList(N)
  1942.                 End If
  1943.             Next
  1944.             '/对控件赋值
  1945.             For N = 0 To UBound(ConFiedArr, 1)
  1946.                 ConFiedArr(N).FrmControl = CStr("" & Rs.Fields(ConFiedArr(N).FldName))
  1947.             Next
  1948.             ReturnVal = True
  1949.        Else
  1950.             ReturnVal = False
  1951.        End If
  1952.        SetGroupValB = ReturnVal
  1953.         If Rs.State = adStateOpen Then
  1954.             Rs.Close
  1955.             Set Rs = Nothing
  1956.         End If
  1957.         Err.Clear
  1958. End Function
  1959. '//数据库排序
  1960. Public Function DbSort(Rs As ADODB.Recordset, SortFld As String, MdbPath As StringAs Recordset
  1961.         Dim StrSql As String
  1962.         Dim I As Long
  1963.         Dim TmpName As String
  1964.         Dim TRs As New ADODB.Recordset
  1965.         Dim P_MdbCnn As New ADODB.Connection
  1966.         
  1967.         Err.Clear
  1968.         On Error Resume Next
  1969.         
  1970.         Set TRs = Rs.Clone
  1971.         TmpName = GetTmpName("S")
  1972.         TmpName = Right$(TmpName, Len(TmpName) - 1)
  1973.         
  1974.         If P_MdbCnn.State = adStateClosed Or P_MdbCnn Is Nothing Then
  1975.             CreateMdbConn P_MdbCnn, MdbPath, , """"
  1976.         End If
  1977.         
  1978.         StrSql = "DROP TABLE " & TmpName
  1979.         P_MdbCnn.Execute StrSql
  1980.         
  1981.         With TRs
  1982.         
  1983.         StrSql = ""
  1984.         For I = 0 To .Fields.Count - 1
  1985.             Select Case .Fields(I).Type
  1986.                    Case Is = 6 '货币 6
  1987.                         StrSql = StrSql & .Fields(I).Name & " Money NULL,"
  1988.                    Case Is = 11 'ACCESS 是/否 11
  1989.                         StrSql = StrSql & .Fields(I).Name & " VARCHAR(" & .Fields(I).DefinedSize & ") NULL,"
  1990.                    Case Is = 129 'CHAR
  1991.                         StrSql = StrSql & .Fields(I).Name & " VARCHAR(" & .Fields(I).DefinedSize & ") NULL,"
  1992.                    Case Is = 130 'NCHAR
  1993.                         StrSql = StrSql & .Fields(I).Name & " VARCHAR(" & .Fields(I).DefinedSize & ") NULL,"
  1994.                    Case Is = 202 'NVARCHAR
  1995.                         StrSql = StrSql & .Fields(I).Name & " VARCHAR(" & .Fields(I).DefinedSize & ") NULL,"
  1996.                    Case Is = 200 'VARCHAR
  1997.                         StrSql = StrSql & .Fields(I).Name & " VARCHAR(" & .Fields(I).DefinedSize & ") NULL,"
  1998.                    Case Is = 3  'INT
  1999.                         StrSql = StrSql & .Fields(I).Name & " LONG NULL,"
  2000.                    Case Is = 17 'TINYINT 字节 Access 17
  2001.                         StrSql = StrSql & .Fields(I).Name & " LONG NULL,"
  2002.                    Case Is = 2   'SMALLINT
  2003.                         StrSql = StrSql & .Fields(I).Name & " LONG NULL,"
  2004.                    Case Is = 20, 72 'BIGINT 同步复制 ID 72
  2005.                         StrSql = StrSql & .Fields(I).Name & " LONG NULL,"
  2006.                    Case Is = 201 'TEXT
  2007.                         StrSql = StrSql & .Fields(I).Name & " Memo NULL,"
  2008.                    Case Is = 203 'NTEXT
  2009.                         StrSql = StrSql & .Fields(I).Name & " Memo NULL,"
  2010.                    Case Is = 131, 4, 5 'NUMERIC|4,5 单精度型 4双精度型 5
  2011.                         StrSql = StrSql & .Fields(I).Name & " Numeric NULL,"
  2012.                    Case Is = 135, 7 'DATETIME  日期/时间 7
  2013.                         StrSql = StrSql & .Fields(I).Name & " DATETIME NULL,"
  2014.                    Case Is = 205 'IMAGE
  2015.                         StrSql = StrSql & .Fields(I).Name & " Image NULL,"
  2016.                    Case Is = 128 'BINARY
  2017.                         StrSql = StrSql & .Fields(I).Name & " Memo NULL,"
  2018.                    Case Is = 204 'VARBINARY
  2019.                         StrSql = StrSql & .Fields(I).Name & " Memo NULL,"
  2020.              End Select
  2021.         Next
  2022.         
  2023.         End With
  2024.         
  2025.         StrSql = Left$(StrSql, Len(StrSql) - 1)
  2026.         StrSql = "CREATE TABLE " & TmpName & " (" & StrSql & ")"
  2027.         P_MdbCnn.Execute StrSql
  2028.         
  2029.         InsertIntoDB P_MdbCnn, TmpName, TRs
  2030.         
  2031.         StrSql = "SELECT * FROM " & TmpName & " ORDER BY " & SortFld
  2032.         Set TRs = RsOpen(P_MdbCnn, StrSql)
  2033.         Set DbSort = TRs.Clone
  2034.         
  2035.         StrSql = "DROP TABLE " & TmpName
  2036.         P_MdbCnn.Execute StrSql
  2037.         
  2038.         If TRs.State = adStateOpen Then
  2039.              TRs.Close
  2040.              Set TRs = Nothing
  2041.         End If
  2042.         
  2043.         If P_MdbCnn.State = adStateOpen Then
  2044.             P_MdbCnn.Close
  2045.             Set P_MdbCnn = Nothing
  2046.         End If
  2047.         DbStyle = "SQL"
  2048.         Err.Clear
  2049. End Function
  2050. '//将一个RS保存到一个临时的ACCESS数据库...
  2051. Public Function SqlToMdb(Rs As ADODB.Recordset, MdbCnn As ADODB.Connection, Optional TabName As String = ""As String
  2052.         Dim StrSql As String
  2053.         Dim I As Long
  2054.         Dim TmpName As String
  2055.         Dim TRs As New ADODB.Recordset
  2056.         
  2057.         Err.Clear
  2058.         On Error Resume Next
  2059.         
  2060.         Set TRs = Rs.Clone
  2061.         If MdbCnn.State <> 1 Then MdbCnn.Open
  2062.         
  2063.         TabName = Trim$(TabName)
  2064.         If Len(TabName) > 0 Then
  2065.             TmpName = TabName
  2066.         Else
  2067.             TmpName = GetTmpName("S")
  2068.             TmpName = Right$(TmpName, Len(TmpName) - 1)
  2069.         End If
  2070.         
  2071.         StrSql = "DROP TABLE " & TmpName
  2072.         MdbCnn.Execute StrSql
  2073.         
  2074.         With TRs
  2075.         
  2076.         StrSql = ""
  2077.         For I = 0 To .Fields.Count - 1
  2078.             Select Case .Fields(I).Type
  2079.                    Case Is = 6 '货币 6
  2080.                         StrSql = StrSql & .Fields(I).Name & " Money NULL,"
  2081.                    Case Is = 11 'ACCESS 是/否 11
  2082.                         StrSql = StrSql & .Fields(I).Name & " VARCHAR(" & .Fields(I).DefinedSize & ") NULL,"
  2083.                    Case Is = 129 'CHAR
  2084.                         StrSql = StrSql & .Fields(I).Name & " VARCHAR(" & .Fields(I).DefinedSize & ") NULL,"
  2085.                    Case Is = 130 'NCHAR
  2086.                         StrSql = StrSql & .Fields(I).Name & " VARCHAR(" & .Fields(I).DefinedSize & ") NULL,"
  2087.                    Case Is = 202 'NVARCHAR
  2088.                         StrSql = StrSql & .Fields(I).Name & " VARCHAR(" & .Fields(I).DefinedSize & ") NULL,"
  2089.                    Case Is = 200 'VARCHAR
  2090.                         StrSql = StrSql & .Fields(I).Name & " VARCHAR(" & .Fields(I).DefinedSize & ") NULL,"
  2091.                    Case Is = 3  'INT
  2092.                         StrSql = StrSql & .Fields(I).Name & " LONG NULL,"
  2093.                    Case Is = 17 'TINYINT 字节 Access 17
  2094.                         StrSql = StrSql & .Fields(I).Name & " LONG NULL,"
  2095.                    Case Is = 2   'SMALLINT
  2096.                         StrSql = StrSql & .Fields(I).Name & " LONG NULL,"
  2097.                    Case Is = 20, 72 'BIGINT 同步复制 ID 72
  2098.                         StrSql = StrSql & .Fields(I).Name & " LONG NULL,"
  2099.                    Case Is = 201 'TEXT
  2100.                         StrSql = StrSql & .Fields(I).Name & " Memo NULL,"
  2101.                    Case Is = 203 'NTEXT
  2102.                         StrSql = StrSql & .Fields(I).Name & " Memo NULL,"
  2103.                    Case Is = 131, 4, 5 'NUMERIC|4,5 单精度型 4双精度型 5
  2104.                         StrSql = StrSql & .Fields(I).Name & " Numeric NULL,"
  2105.                    Case Is = 135, 7 'DATETIME  日期/时间 7
  2106.                         StrSql = StrSql & .Fields(I).Name & " DATETIME NULL,"
  2107.                    Case Is = 205 'IMAGE
  2108.                         StrSql = StrSql & .Fields(I).Name & " Image NULL,"
  2109.                    Case Is = 128 'BINARY
  2110.                         StrSql = StrSql & .Fields(I).Name & " Memo NULL,"
  2111.                    Case Is = 204 'VARBINARY
  2112.                         StrSql = StrSql & .Fields(I).Name & " Memo NULL,"
  2113.              End Select
  2114.         Next
  2115.         
  2116.         End With
  2117.         
  2118.         StrSql = Left$(StrSql, Len(StrSql) - 1)
  2119.         StrSql = "CREATE TABLE " & TmpName & " (" & StrSql & ")"
  2120.         MdbCnn.Execute StrSql
  2121.         InsertIntoDB MdbCnn, TmpName, TRs
  2122.         If TRs.State = adStateOpen Then
  2123.              TRs.Close
  2124.              Set TRs = Nothing
  2125.         End If
  2126.         SqlToMdb = TmpName
  2127.         Err.Clear
  2128. End Function
  2129. '//将一个RS保存到一个临时的表...
  2130. Public Function RsToTmp(Rs As ADODB.Recordset, P_Cnn As ADODB.Connection, Optional TabName As String = ""As String
  2131.         Dim StrSql As String
  2132.         Dim I As Long
  2133.         Dim TmpName As String
  2134.         Dim TRs As New ADODB.Recordset
  2135.         
  2136.         Err.Clear
  2137.         On Error Resume Next
  2138.         
  2139.         If P_Cnn.State <> 1 Then P_Cnn.Open
  2140.         Set TRs = Rs.Clone
  2141.         
  2142.         TabName = Trim$(TabName)
  2143.         If Len(TabName) > 0 Then
  2144.             TmpName = TabName
  2145.         Else
  2146.             TmpName = GetTmpName("S")
  2147.             StrSql = "DROP TABLE " & TmpName
  2148.         End If
  2149.         P_Cnn.Execute StrSql
  2150.         
  2151.         With TRs
  2152.         
  2153.         StrSql = ""
  2154.         For I = 0 To .Fields.Count - 1
  2155.             Select Case .Fields(I).Type
  2156.                    Case Is = 6 '货币 6
  2157.                         StrSql = StrSql & .Fields(I).Name & " Money NULL,"
  2158.                    Case Is = 11 'ACCESS 是/否 11
  2159.                         StrSql = StrSql & .Fields(I).Name & " VARCHAR(" & .Fields(I).DefinedSize & ") NULL,"
  2160.                    Case Is = 129 'CHAR
  2161.                         StrSql = StrSql & .Fields(I).Name & " VARCHAR(" & .Fields(I).DefinedSize & ") NULL,"
  2162.                    Case Is = 130 'NCHAR
  2163.                         StrSql = StrSql & .Fields(I).Name & " VARCHAR(" & .Fields(I).DefinedSize & ") NULL,"
  2164.                    Case Is = 202 'NVARCHAR
  2165.                         StrSql = StrSql & .Fields(I).Name & " VARCHAR(" & .Fields(I).DefinedSize & ") NULL,"
  2166.                    Case Is = 200 'VARCHAR
  2167.                         StrSql = StrSql & .Fields(I).Name & " VARCHAR(" & .Fields(I).DefinedSize & ") NULL,"
  2168.                    Case Is = 3  'INT
  2169.                         StrSql = StrSql & .Fields(I).Name & " INT NULL,"
  2170.                    Case Is = 17 'TINYINT 字节 Access 17
  2171.                         StrSql = StrSql & .Fields(I).Name & " INT NULL,"
  2172.                    Case Is = 2   'SMALLINT
  2173.                         StrSql = StrSql & .Fields(I).Name & " INT NULL,"
  2174.                    Case Is = 20, 72 'BIGINT 同步复制 ID 72
  2175.                         StrSql = StrSql & .Fields(I).Name & " INT NULL,"
  2176.                    Case Is = 201 'TEXT
  2177.                         StrSql = StrSql & .Fields(I).Name & " TEXT NULL,"
  2178.                    Case Is = 203 'NTEXT
  2179.                         StrSql = StrSql & .Fields(I).Name & " TEXT NULL,"
  2180.                    Case Is = 131, 4, 5 'NUMERIC|4,5 单精度型 4双精度型 5
  2181.                         StrSql = StrSql & .Fields(I).Name & " Numeric NULL,"
  2182.                    Case Is = 135, 7 'DATETIME  日期/时间 7
  2183.                         StrSql = StrSql & .Fields(I).Name & " DATETIME NULL,"
  2184.                    Case Is = 205 'IMAGE
  2185.                         StrSql = StrSql & .Fields(I).Name & " Image NULL,"
  2186.                    Case Is = 128 'BINARY
  2187.                         StrSql = StrSql & .Fields(I).Name & " TEXT NULL,"
  2188.                    Case Is = 204 'VARBINARY
  2189.                         StrSql = StrSql & .Fields(I).Name & " TEXT NULL,"
  2190.              End Select
  2191.         Next
  2192.         
  2193.         End With
  2194.         
  2195.         StrSql = Left$(StrSql, Len(StrSql) - 1)
  2196.         StrSql = "CREATE TABLE " & TmpName & " (" & StrSql & ")"
  2197.         P_Cnn.Execute StrSql
  2198.         InsertIntoDB P_Cnn, TmpName, TRs
  2199.         If TRs.State = adStateOpen Then
  2200.              TRs.Close
  2201.              Set TRs = Nothing
  2202.         End If
  2203.         RsToTmp = TmpName
  2204.         Err.Clear
  2205. End Function
  2206. '
  2207. '//将DBF导入MDB
  2208. Public Function DBFTOMDB(Rs As ADODB.Recordset, _
  2209.                          P_Cnn As ADODB.Connection, _
  2210.                          TabName As String, _
  2211.                          Optional strlen As Integer = 64)
  2212.        
  2213.         Dim FldList As String
  2214.         
  2215.         Dim FldValList As String
  2216.         Dim FldNameList As String
  2217.         
  2218.         Dim StrSql As String
  2219.         Dim TRs As New ADODB.Recordset
  2220.         Dim I As Long
  2221.         
  2222.         On Error Resume Next
  2223.         
  2224.         FldList = ""
  2225.         Set TRs = Rs.Clone
  2226.         For I = 0 To TRs.Fields.Count - 1
  2227.             FldList = FldList & TRs.Fields(I).Name & " VARCHAR(" & strlen & ") NULL,"
  2228.         Next
  2229.         If Len(FldList) > 0 Then
  2230.             FldList = Left$(FldList, Len(FldList) - 1)
  2231.             StrSql = "CREATE TABLE " & TabName & "  (" & FldList & ")"
  2232.             P_Cnn.Execute StrSql
  2233.             TRs.MovePrevious
  2234.             While Not TRs.EOF
  2235.                 
  2236.                 TRs.MoveNext
  2237.                 If Err.Number <> 0 Then
  2238.                     Exit Function
  2239.                 End If
  2240.             Wend
  2241.         End If
  2242. End Function
发布了25 篇原创文章 · 获赞 4 · 访问量 6万+
展开阅读全文

没有更多推荐了,返回首页

©️2019 CSDN 皮肤主题: 大白 设计师: CSDN官方博客

分享到微信朋友圈

×

扫一扫,手机浏览