- '
- '数据库操作(SmDbCtrl)
- '
- Option Explicit
- Public DbStyle As String
- Dim CT As SmDataDiap
- '
- '========================================================================
- '创建一个SQLSERVER定形连接(连接到SQL)
- '函数名:CreateShape
- '参数: P_Cnn ADODB连接,ServerName 服务器名,DBname 数据库名,UserID 登录用户名,UPw 登录密码,Timerout 连接超时
- '返回值:TRUE 连接成功.FALSE 连接失败.
- '例: CreateShape P_Cnn,"CJH","cjherp001","sa","123",15
- '========================================================================
- Public Function CreateShape(ByRef P_Cnn As ADODB.Connection, _
- ServerName As String, _
- DbName As String, _
- UserID As String, _
- UPw As String, _
- Optional Timerout As Long = 15) As Boolean
- Dim ReturnVal As Boolean
- Dim ConnStr As String
- Err.Clear
- On Error Resume Next
- ConnStr = "Provider=MSDataShape;Data Provider=SQLOLEDB.1;Password=" & UPw & ";Persist Security Info=True;User ID=" & UserID & _
- ";Initial Catalog=" & DbName & ";Data Source=" & ServerName
- P_Cnn.ConnectionString = ConnStr
- P_Cnn.ConnectionTimeout = Timerout
- P_Cnn.CommandTimeout = Timerout
- P_Cnn.Open
- DoEvents
- If Err.Number = 0 Then
- DbStyle = "SQL"
- ReturnVal = True
- Else
- Err.Clear
- DbStyle = ""
- ReturnVal = False
- End If
- CreateShape = ReturnVal
- Err.Clear
- End Function
- '========================================================================
- '创建一个连接(连接到SQL)
- '函数名:CreateSqlConn
- '参数: P_Cnn ADODB连接,ServerName 服务器名,DBname 数据库名,UserID 登录用户名,UPw 登录密码,Timerout 连接超时
- '返回值:TRUE 连接成功.FALSE 连接失败.
- '例: CreateSqlConn p_cnn,"CJH","cjherp001","sa","123",15
- '========================================================================
- Public Function CreateSqlConn(ByRef P_Cnn As ADODB.Connection, _
- ServerName As String, _
- DbName As String, _
- UserID As String, _
- UPw As String, _
- Optional Timerout As Long = 15) As Boolean
- Dim ReturnVal As Boolean
- Err.Clear
- On Error Resume Next
- If P_Cnn.State = adStateOpen And Not IsEmpty(adStateOpen) Then
- P_Cnn.Close
- End If
- P_Cnn.Provider = "MSDASQL.1"
- P_Cnn.ConnectionString = "Driver={SQL Server};Server=" & ServerName & ";DataBase=" & DbName & ";Uid=" & UserID & ";Pwd=" & UPw & ";APP=" & App.Path & ";WSID=" & UserID & ";Connect Timeout=" & Timerout & ";"
- P_Cnn.ConnectionTimeout = Timerout
- P_Cnn.CommandTimeout = Timerout
- P_Cnn.Open
- DoEvents
- If Err.Number = 0 Then
- DbStyle = "SQL"
- ReturnVal = True
- Else
- Err.Clear
- DbStyle = ""
- ReturnVal = False
- End If
- CreateSqlConn = ReturnVal
- Err.Clear
- End Function
- '
- '========================================================================
- '创建一个连接(连接到ACCESS)
- '函数名:CreateMdbConn
- '参数: MdbCnn ADODB连接,MdbPath ACCESS数据库路径,Provider JET引擎版本,UserID 登录用户名,UserWord 登录密码
- '返回值:TRUE 连接成功.FALSE 连接失败.
- '例: CreateMdbConn p_cnn,"C:/DEMO.MDB","sa","123"
- '========================================================================
- Public Function CreateMdbConn(ByRef MdbCnn As ADODB.Connection, _
- MdbPath As String, _
- Optional Provider = "Microsoft.Jet.OLEDB.4.0;", _
- Optional UserID As String = "admin", _
- Optional UserWord As String = "") As Boolean
- Dim ConStr As String
- Err.Clear
- On Error Resume Next
- If MdbCnn.State = adStateOpen And Not IsEmpty(adStateOpen) Then
- MdbCnn.Close
- End If
- '/------------------------------------------------------------------
- ConStr = "Provider=" & Provider & _
- "Data Source=" & MdbPath & ";" & _
- "Jet OLEDB:Database Password=" & UserWord & ";" & _
- "User ID=" & UserID & ";"
- MdbCnn.ConnectionString = ConStr
- MdbCnn.Open
- DoEvents
- If Err.Number = 0 Then
- DbStyle = "MDB"
- CreateMdbConn = True
- Else
- Err.Clear
- DbStyle = ""
- CreateMdbConn = False
- End If
- Err.Clear
- End Function
- '=====================================================================
- '创建一个连接(连接到其它数据库类型)
- '函数名:CreateOtherConn
- '参数: OtherCnn ADODB连接,FilePath 数据库路径,UserName 登录用户名,PassWord 登录密码,DbType SmDbType枚举数据库类型
- '返回值:TRUE 连接成功.FALSE 连接失败.
- '例:
- 'CreateOtherConn Cnn, "E:/CjhLx/dbf", , , FoxPro
- 'StrSql = "select * from [employee.dbf]"
- 'Set Rs = RsOpen(Cnn, StrSql)
- 'Set DataGrid1.DataSource = Rs
- '=====================================================================
- Public Function CreateOtherConn(ByRef OtherCnn As ADODB.Connection, _
- FilePath As String, _
- Optional UserName As String = "admin", _
- Optional PassWord As String = "", _
- Optional DbType As SmDbType = Access) As Boolean
- Dim ConnStr As String
- Dim DriveName(5) As String
- Dim tDbType(5) As String
- Dim UserPwd(5) As String
- Err.Clear
- '/驱动程序
- DriveName(1) = "{Microsoft Access Driver (*.mdb)}"
- DriveName(2) = "{Microsoft Excel Driver (*.xls)}"
- DriveName(3) = "{Microsoft Text Driver (*.txt; *.csv)}"
- DriveName(4) = "{Microsoft Visual FoxPro Driver};SourceType=DBF"
- DriveName(5) = "{Microsoft dBase Driver (*.dbf)}"
- '/类型
- tDbType(1) = "MDB"
- tDbType(2) = "XLS"
- tDbType(3) = "TXT"
- tDbType(4) = "FDB"
- tDbType(5) = "DDB"
- '/用户名和密码.
- UserPwd(1) = "Uid=" & UserName & ";Pwd=" & PassWord & ";"
- UserPwd(2) = "Uid=" & UserName & ";Pwd=" & PassWord & ";"
- UserPwd(3) = ""
- UserPwd(4) = "Uid=" & UserName & ";Pwd=" & PassWord & ";"
- UserPwd(5) = "Uid=" & UserName & ";Pwd=" & PassWord & ";"
- On Error Resume Next
- If OtherCnn.State = adStateOpen And Not IsEmpty(adStateOpen) Then
- OtherCnn.Close
- End If
- ConnStr = "Provider=MSDASQL.1;Persist Security Info=False;DRIVER=" & DriveName(DbType) & ";" & UserPwd(DbType) & "DBQ=" & FilePath
- OtherCnn.ConnectionString = ConnStr
- OtherCnn.Open
- DoEvents
- If Err.Number = 0 Then
- DbStyle = tDbType(DbType)
- CreateOtherConn = True
- Else
- Err.Clear
- DbStyle = ""
- CreateOtherConn = False
- End If
- Err.Clear
- End Function
- '=========================================================================
- '打开一个记录集
- '函数名:RsOpen
- '参数: P_Cnn ADODB连接,StrSql SQL查询语句,SetNothing 非连接方式(TRUE默认).连接方式(FALSE)
- '返回值:记录集
- '例: RsOpen P_CNN,"SELECT ACHGOODS.* FROM ACHGOODS WHERE GDSID='001'
- '=========================================================================
- Public Function RsOpen(ByRef P_Cnn As ADODB.Connection, _
- StrSql As String, _
- Optional SetConnect As Boolean = True) As ADODB.Recordset
- Dim Rs As New ADODB.Recordset
- Err.Clear
- On Error Resume Next
- If P_Cnn.State <> 1 Then P_Cnn.Open
- If SetConnect Then '使用非连接
- Rs.CursorLocation = adUseClient '使用客户端游标
- Rs.LockType = adLockBatchOptimistic '开放式批更新
- Rs.CursorType = adOpenKeyset '键集游标
- Else '使用连接(主要用于更新二进制字段)
- Rs.CursorLocation = adUseClient
- Rs.CursorType = adOpenKeyset
- Rs.LockType = adLockOptimistic '记录锁定
- End If
- Rs.Open StrSql, P_Cnn '执行SQL
- If SetConnect Then Set Rs.ActiveConnection = Nothing '设置非连接
- If Err.Number = 0 Then
- Set RsOpen = Rs.Clone
- Else
- Set RsOpen = Nothing
- End If
- Rs.Close
- Set Rs = Nothing
- Err.Clear
- End Function
- '//执行一条SQL语句
- Public Function ExecSql(ByRef P_Cnn As ADODB.Connection, _
- StrSql As String) As Boolean
- Err.Clear
- If P_Cnn.State <> 1 Then P_Cnn.Open
- P_Cnn.Execute StrSql
- ExecSql = (Err.Number = 0)
- Err.Clear
- End Function
- '
- '========================================================================
- '建立数据库
- '函数名:CreateDataBase
- '参数: ServerName 服务器名,UserID 用户名(SA),Pwd 登录密码,DataBasName 建立的数据库名,DataBasPath 库文件目录的绝对路径
- '返回值:无
- '例: CreateDataBase "CJH","SA","123","CJHERP001","C:/DB"
- '========================================================================
- Public Function CreateDataBase(ServerName As String, _
- UserID As String, _
- Pwd As String, _
- DataBasName As String, _
- DataBasPath As String) As Boolean
- Dim A As Long, LeftName As String
- Dim DbC As New ADODB.Connection
- Dim CreateBasSql As String
- Dim BagTrFlag As Boolean
- Err.Clear
- If CreateSqlConn(DbC, ServerName, "Master", UserID, Pwd) Then
- If Right$(DataBasPath, 1) <> "/" Then DataBasPath = DataBasPath & "/"
- On Error GoTo Errhan:
- DataBasPath = Trim$(DataBasPath)
- If Len(DataBasPath) < 2 Then Exit Function
- If Dir$(Left$(DataBasPath, 2), vbDirectory) = "" Then Beep: Exit Function '根目录是否存在
- '/---------------------------------------------------------
- If Right$(DataBasPath, 1) <> "/" Then DataBasPath = DataBasPath & "/"
- For A = 1 To Len(DataBasPath)
- If Mid$(DataBasPath, A, 1) = "/" Then
- LeftName = Left$(DataBasPath, A)
- '/如果目录不存在,则先建立
- If Dir$(LeftName, vbDirectory) = "" Then MkDir LeftName: DoEvents
- End If
- Next
- Err.Clear
- DbC.BeginTrans
- '/---------------------------------------------------------
- CreateBasSql = " CREATE DATABASE " & DataBasName & " ON (NAME=" & DataBasName & ",FILENAME='" & DataBasPath & DataBasName & ".mdf', SIZE=20,FILEGROWTH=4) " & _
- " LOG ON (NAME=" & DataBasName & "Log" & ",FILENAME='" & DataBasPath & DataBasName & "Log.ldf',SIZE=20,FILEGROWTH=0)"
- DbC.Execute CreateBasSql
- DbC.CommitTrans
- End If
- Errhan:
- If Err.Number <> 0 Then DbC.RollbackTrans
- CreateDataBase = (Err.Number = 0)
- DbC.Close
- Set DbC = Nothing
- Err.Clear
- End Function
- '
- '建立数据表
- '函数名:CreageDbTab
- '参数: P_Cnn ADO连接,CreateTableSql 建表字符串
- '返回值:无
- '例: CreateDbTab P_CNN,CreateTabStr
- Public Function CreateDbTab(ByRef P_Cnn As ADODB.Connection, _
- CreateTableSql As String) As Boolean
- Err.Clear
- On Error Resume Next
- If P_Cnn.State <> 1 Then P_Cnn.Open
- P_Cnn.BeginTrans
- P_Cnn.Execute CreateTableSql
- P_Cnn.CommitTrans
- CreateDbTab = (Err.Number = 0)
- Err.Clear
- End Function
- '
- '得到服务器上所有的数据库名
- '函数名:GetAllDatabases
- '参数: ServerName 服务器名,UserID 登录用户名(SA),Pwd 登录密码
- '返回值:数据库名的字符串数组
- '例: GetAllDatabases "CJH","SA","123"
- Public Function GetAllDatabases(ServerName As String, _
- UserID As String, _
- Pwd As String, _
- Optional strDriver As String = "SQL Server") As String()
- Dim PCnn As New ADODB.Connection
- Dim RsSchema As New ADODB.Recordset
- Dim ConnStr As String
- Dim ReturnVal() As String
- Dim ReID As Long
- Err.Clear
- On Error Resume Next
- ConnStr = "Driver={" & strDriver & "};"
- ConnStr = ConnStr & "Server=" & ServerName & ";"
- ConnStr = ConnStr & "uid=" & UserID & ";pwd=" & Pwd & ";"
- PCnn.ConnectionString = ConnStr
- PCnn.Open: ReID = 0
- Set RsSchema = PCnn.OpenSchema(adSchemaCatalogs)
- Do Until RsSchema.EOF
- ReID = ReID + 1
- ReDim Preserve ReturnVal(ReID - 1)
- ReturnVal(ReID - 1) = RsSchema!Catalog_Name
- RsSchema.MoveNext
- Loop
- If PCnn.State = adStateOpen And Not IsEmpty(adStateOpen) Then
- PCnn.Close
- End If
- GetAllDatabases = ReturnVal
- Err.Clear
- End Function
- '
- '取某数据库下的数据表
- '函数名:GetDbTabS
- '参数: P_Cnn ADO连接
- '返回值:包含数据表的字符串数组
- '例: TabArr=GetDbTabS(P_CNN)
- Public Function GetDbTabs(ByRef P_Cnn As ADODB.Connection) As String()
- Dim RstSchema As ADODB.Recordset
- Dim strCnn As String
- Dim ReturnVal() As String
- Dim ReID As Long
- Err.Clear
- On Error Resume Next
- If P_Cnn.State <> 1 Then P_Cnn.Open
- Set RstSchema = P_Cnn.OpenSchema(adSchemaTables)
- ReID = 0
- Do Until RstSchema.EOF
- If UCase$(Left$(RstSchema.Fields("TABLE_TYPE"), 3)) <> "SYS" Then
- ReID = ReID + 1
- ReDim Preserve ReturnVal(ReID - 1)
- ReturnVal(ReID - 1) = RstSchema.Fields("TABLE_NAME") ' & ":" & RstSchema!TABLE_TYPE
- End If
- RstSchema.MoveNext
- Loop
- RstSchema.Close
- Set RstSchema = Nothing
- GetDbTabs = ReturnVal
- Err.Clear
- End Function
- '============================================================================
- '取临时表名
- '函数名:GetTmpName
- '参数:
- '返回值:一个唯一的临时表名
- '例: TmpName=GetTmpName()
- '(注:临时表名="#TmpTal" & 累加数 & 毫秒数)
- '============================================================================
- Public Function GetTmpName(Optional UserName As String = "") As String
- Dim ReturnVal As String
- Dim TimVal As String
- Static K As Long
- Err.Clear
- On Error Resume Next
- K = K + 1
- If K >= 2147483645# Then K = 0 '累加数
- TimVal = timeGetTime() '毫秒数
- ReturnVal = "#" & "TmpTal" & UserName & TimVal & CT.ToStr(K)
- GetTmpName = IIf(Err.Number = 0, ReturnVal, "")
- Err.Clear
- End Function
- '
- '=======================================================================
- '对 表格或记录集以 INSERT INTO 保存.
- '函数名:GetInsertIntoSql
- '参数: P_Cnn ADO连接,mRs 记录集,DateTabName 目标数据表名
- '返回值:SQL语句
- '例: InsertIntoDB P_CNN,RS,"ACHGOODS"
- '=======================================================================
- Public Function InsertIntoDB(ByRef P_Cnn As ADODB.Connection, _
- DateTabName As String, _
- ByRef MRs As ADODB.Recordset) As Boolean
- Dim StrSql As String
- Dim TabFied() As SmFiedArrtr '数据库字段
- Dim SaveFied() As SmFiedArrtr '表格与数据库同时存在的字段
- Dim SaveID As Long
- Dim AddSave As Boolean
- Dim AddFile As SmFiedArrtr
- Dim FileCon As String
- Dim FldVal As String
- Dim TmpVal As Variant
- Dim FldType As Long
- Dim A As Long, B As Long, I As Long
- Dim FldValColl As New Collection
- '/--------------------------------------------------------------------------------------
- Err.Clear
- On Error Resume Next
- If (MRs.EOF And MRs.BOF) Then Exit Function
- Erase TabFied
- If P_Cnn.State <> 1 Then P_Cnn.Open
- TabFied = GetTabFldAttrib(P_Cnn, DateTabName) '取数据库字段
- If UBound(TabFied, 1) > 0 Then
- SaveID = 0: AddSave = False
- For A = 0 To MRs.Fields.Count - 1
- For B = 0 To UBound(TabFied, 1)
- If UCase$(TabFied(B).FieldName) = UCase$(MRs.Fields(A).Name) Then
- '处理重复的字段名.
- Err.Clear
- FldValColl.Add TabFied(B), "_" & UCase$(TabFied(B).FieldName)
- If Err.Number <> 457 Then
- SaveID = SaveID + 1
- ReDim Preserve SaveFied(SaveID - 1)
- SaveFied(SaveID - 1) = TabFied(B)
- End If
- Exit For
- End If
- Next
- Next
- '/---------------------------------------------------------------------------------------
- '/保存字段列表
- For A = 0 To UBound(SaveFied, 1) '字段列表
- If SaveFied(A).FieldType <> 205 Then
- FileCon = FileCon & "[" & SaveFied(A).FieldName & "],"
- End If
- Next A
- FileCon = Left$(FileCon, Len(FileCon) - 1)
- MRs.MoveFirst
- While Not MRs.EOF
- FldVal = ""
- For I = 0 To UBound(SaveFied, 1)
- FldType = SaveFied(I).FieldType '字段类型
- If FldType <> 205 Then '将IMAGE字段排除
- TmpVal = CT.ToStr(MRs.Fields(SaveFied(I).FieldName)) '字段值
- If Len(TmpVal) = 0 Then '对空或NULL的处理
- Select Case FldType
- Case 2, 3, 4, 5, 6, 17, 131 '数值类型
- If SaveFied(I).FieldIsNull <> 0 Then '可接受NULL
- FldVal = FldVal & "NULL,"
- Else
- FldVal = FldVal & "0,"
- End If
- Case 135 '日期
- If SaveFied(I).FieldIsNull <> 0 Then '可接受NULL
- FldVal = FldVal & "NULL,"
- Else
- If DbStyle = "MDB" Then
- FldVal = FldVal & "#" & Now() & "#,"
- Else
- FldVal = FldVal & "'" & Now() & "',"
- End If
- End If
- Case Else '其它类型
- If SaveFied(I).FieldIsNull <> 0 Then
- FldVal = FldVal & "NULL,"
- Else
- FldVal = FldVal & "'',"
- End If
- End Select
- Else
- Select Case FldType
- Case 2, 3, 4, 5, 6, 17, 131 '数值类型
- FldVal = FldVal & "" & TmpVal & ","
- Case 135
- If DbStyle = "MDB" Then
- FldVal = FldVal & "#" & TmpVal & "#,"
- Else
- FldVal = FldVal & "'" & TmpVal & "',"
- End If
- Case Else '其它类型
- FldVal = FldVal & "'" & Replace(TmpVal, "'", "''") & "',"
- End Select
- End If
- End If
- Next
- FldVal = Left$(FldVal, Len(FldVal) - 1)
- StrSql = "INSERT INTO [" & DateTabName & "] (" & FileCon & ") VALUES (" & FldVal & ")"
- P_Cnn.Execute StrSql
- MRs.MoveNext
- Wend
- End If
- Set FldValColl = Nothing
- InsertIntoDB = (Err.Number = 0)
- Err.Clear
- End Function
- '
- '对表格或记录集以 UPDATE 保存.
- '函数名:GetUpdataSql
- '参数: P_Cnn ADO连接,mRs 记录集,DateTabName 目标数据表名,WhereStr 更新条件
- '返回值:SQL语句
- '例: UpdataDB P_CNN,RS,"ACHGOODS","WHERE GDSID='001'"
- Public Function UpdataDB(ByRef P_Cnn As ADODB.Connection, _
- DateTabName As String, _
- ByRef MRs As ADODB.Recordset, _
- WhereStr As String) As Boolean
- Dim StrSql As String
- Dim TabFied() As SmFiedArrtr '数据库字段
- Dim SaveFied() As SmFiedArrtr '表格与数据库同时存在的字段
- Dim SaveID As Long
- Dim AddSave As Boolean
- Dim AddFile As SmFiedArrtr
- Dim FileCon As String
- Dim FldVal As String
- Dim TmpVal As Variant
- Dim FldType As Long
- Dim A As Long, B As Long, I As Long
- '/----------------------------------------------------------------------------------------
- Err.Clear
- On Error Resume Next
- '
- If MRs.EOF And MRs.BOF Then Exit Function
- Erase TabFied
- If P_Cnn.State <> 1 Then P_Cnn.Open
- TabFied = GetTabFldAttrib(P_Cnn, DateTabName) '取数据库字段
- If UBound(TabFied, 1) > 0 Then
- SaveID = 0
- For A = 0 To MRs.Fields.Count - 1
- For B = 0 To UBound(TabFied, 1)
- If UCase$(TabFied(B).FieldName) = UCase$(MRs.Fields(A).Name) Then
- SaveID = SaveID + 1
- ReDim Preserve SaveFied(SaveID - 1)
- SaveFied(SaveID - 1) = TabFied(B)
- Exit For '找到数据库与记录集中相同的值,跳出循环.
- End If
- Next
- Next
- '/--------------------------------------------------------------------------------------
- MRs.MoveFirst
- While Not MRs.EOF
- FldVal = ""
- For I = 0 To UBound(SaveFied, 1)
- FldType = SaveFied(I).FieldType '字段类型
- If FldType <> 205 Then '将IMAGE字段排除
- TmpVal = CT.ToStr(MRs.Fields(SaveFied(I).FieldName)) '字段值
- If Len(TmpVal) = 0 Then '对空或NULL的处理
- Select Case FldType
- Case 2, 3, 4, 5, 6, 17, 131 '数值类型
- If SaveFied(I).FieldIsNull <> 0 Then '可按受NULL
- FldVal = FldVal & ",[" & SaveFied(I).FieldName & "]=NULL"
- Else
- FldVal = FldVal & ",[" & SaveFied(I).FieldName & "]=0"
- End If
- Case 135 '日期时间
- If SaveFied(I).FieldIsNull <> 0 Then '可接受NULL
- FldVal = FldVal & ",[" & SaveFied(I).FieldName & "]=NULL"
- Else
- If DbStyle = "MDB" Then
- FldVal = FldVal & ",[" & SaveFied(I).FieldName & "]=#" & Now() & "#"
- Else
- FldVal = FldVal & ",[" & SaveFied(I).FieldName & "]='" & Now() & "'"
- End If
- End If
- Case Else '其它类型
- If SaveFied(I).FieldIsNull <> 0 Then
- FldVal = FldVal & ",[" & SaveFied(I).FieldName & "]=NULL"
- Else
- FldVal = FldVal & ",[" & SaveFied(I).FieldName & "]=''"
- End If
- End Select
- Else
- Select Case FldType
- Case 2, 3, 4, 5, 6, 17, 131 '数值类型
- FldVal = FldVal & ",[" & SaveFied(I).FieldName & "]=" & TmpVal
- Case 135
- If DbStyle = "MDB" Then
- FldVal = FldVal & ",[" & SaveFied(I).FieldName & "]=#" & TmpVal & "#"
- Else
- FldVal = FldVal & ",[" & SaveFied(I).FieldName & "]='" & TmpVal & "'"
- End If
- Case Else '其它类型
- FldVal = FldVal & ",[" & SaveFied(I).FieldName & "]='" & Replace(TmpVal, "'", "''") & "'"
- End Select
- End If
- End If
- Next
- FldVal = " Set " & Right$(FldVal, Len(FldVal) - 1) & " " & WhereStr
- StrSql = "UpDate [" & DateTabName & "]" & FldVal
- P_Cnn.Execute StrSql
- MRs.MoveNext
- Wend
- End If
- UpdataDB = (Err.Number = 0)
- Err.Clear
- End Function
- '
- '取某 数据表 下所有的字段及其属性
- '函数名:GetTabFldAttrib
- '参数: P_Cnn ADO连接,DateTabName 目标数据表名
- '返回值:SmFiedArrtr 类型数组
- '例: FiedAtrrib=GetTabFldAttrib(P_CNN,"ACHGOODS")
- Public Function GetTabFldAttrib(ByRef P_Cnn As ADODB.Connection, _
- DbTableName As String) As SmFiedArrtr()
- Dim A As Long
- Dim StrSql As String
- Dim Rs As New ADODB.Recordset
- Dim ReturnVal() As SmFiedArrtr
- Dim ReID As Long
- Err.Clear
- On Error Resume Next
- If P_Cnn.State <> 1 Then P_Cnn.Open
- StrSql = "Select Top 1 * From [" & DbTableName & "]" '取字段名
- Set Rs = RsOpen(P_Cnn, StrSql)
- Set Rs.ActiveConnection = Nothing
- Erase ReturnVal: ReID = 0
- For A = 0 To Rs.Fields.Count - 1
- ReID = ReID + 1
- ReDim Preserve ReturnVal(ReID - 1)
- ReturnVal(ReID - 1).FieldType = Rs.Fields(A).Type '数据类型
- ReturnVal(ReID - 1).FieldName = Rs.Fields(A).Name '字段名
- ReturnVal(ReID - 1).FieldIsNull = Rs.Fields(A).Attributes And adFldIsNullable '是否可接受NULL
- ReturnVal(ReID - 1).FieldDefSize = Rs.Fields(A).DefinedSize '定义的数据长度
- ReturnVal(ReID - 1).FieldActSize = 0 '实际数据长度(因只有字段名),故此值是0
- Next
- Set Rs = Nothing
- GetTabFldAttrib = ReturnVal
- Err.Clear
- End Function
- '
- '取某 数据表 下除IMAGE字段名的所有字段名
- '函数名:GetTabFldName
- '参数: P_Cnn ADO连接,DateTabName 目标数据表名
- '返回值:String 类型数组
- '例: StrFld=GetTabFldName(P_CNN,"ACHGOODS")
- Public Function GetTabFldName(ByRef P_Cnn As ADODB.Connection, _
- DbTabname As String) As String
- Dim N As Long
- Dim ReturnVal As String
- Dim FltArt() As SmFiedArrtr
- Err.Clear
- On Error Resume Next
- If P_Cnn.State <> 1 Then P_Cnn.Open
- ReturnVal = ""
- FltArt() = GetTabFldAttrib(P_Cnn, DbTabname)
- For N = 0 To UBound(FltArt)
- If FltArt(N).FieldType <> 205 Then
- ReturnVal = ReturnVal & DbTabname & "." & FltArt(N).FieldName & ","
- End If
- Next
- ReturnVal = Left$(ReturnVal, Len(ReturnVal) - 1)
- GetTabFldName = IIf(Err.Number = 0, ReturnVal, "")
- Err.Clear
- End Function
- '
- '取 记录集 下所有的字段及其属性
- '函数名:GetRsAttrib
- '参数: mRs 记录集
- '返回值:FiedArrtr类型数组
- '例: RsAtrrib=GetRsAttrib(Rs)
- Public Function GetRsAttrib(ByRef MRs As ADODB.Recordset) As SmFiedArrtr()
- Dim A As Long
- Dim ReturnVal() As SmFiedArrtr
- Dim Rs As New ADODB.Recordset
- Dim ReID As Long
- Err.Clear
- Set Rs = MRs.Clone
- Erase ReturnVal
- For A = 0 To Rs.Fields.Count - 1
- ReID = ReID + 1
- ReDim Preserve ReturnVal(ReID - 1)
- ReturnVal(ReID - 1).FieldType = Rs.Fields(A).Type '数据类型
- ReturnVal(ReID - 1).FieldName = Rs.Fields(A).Name '字段名
- ReturnVal(ReID - 1).FieldIsNull = Rs.Fields(A).Attributes And adFldIsNullable '是否可接受NULL
- ReturnVal(ReID - 1).FieldDefSize = Rs.Fields(A).DefinedSize '定义的数据长度
- ReturnVal(ReID - 1).FieldActSize = Rs.Fields(A).ActualSize '数据的实际长度
- Next
- Set Rs = Nothing
- GetRsAttrib = ReturnVal
- Err.Clear
- End Function
- '
- '取[窗体控件]与[字段]的对应关系
- '函数名:GetConToFld
- '参数: P_Cnn ADODB.Connection,SelectStr SQL语句.
- '返回值:SmCtrlCorRs 类型数组
- '例: FrmAndFied=GetConToFld(P_Cnn,Me)
- '*窗体控件命名规则:1-3 控件类型,4 W读写标志,R只读标志,其它,不作处理, 5 数据类型,6----最后.相对的字段名
- '*关于数据类型:C -字符 I 整数 F 浮点数 A 金额 U 单价 D 日期 T 时间
- Public Function GetConToFld(ByRef P_Cnn As ADODB.Connection, ByRef Frm As Object, SelectStr As String) As SmCtrlCorRs()
- Dim RevArr() As SmCtrlCorRs
- Dim StrSql As String
- Dim Rs As New ADODB.Recordset
- Err.Clear
- On Error Resume Next
- ' If (Frm Is Nothing) Or (P_Cnn Is Nothing) Then Exit Function
- ' If Len(Trim$(DbTabname)) = 0 Then DbTabname = Frm.Name
- '
- ' StrSql = "SELECT TOP 1 * FROM [" & DbTabname & "]"
- StrSql = SelectStr
- If P_Cnn.State <> 1 Then P_Cnn.Open
- Set Rs = RsOpen(P_Cnn, StrSql)
- RevArr = GetConToRs(Frm, Rs)
- GetConToFld = RevArr
- Set Rs = Nothing
- Erase RevArr
- Err.Clear
- End Function
- '
- '取[窗体控件]与[记录集]的对应关系
- '函数名:GetConToRs
- '参数: Frm 源窗体名,mRs 源记录集
- '返回值:SmCtrlCorRs 类型数组
- '例: FrmAndFied=GetConToRs(Me,Rs)
- '*窗体控件命名规则:1-3 控件类型,4 W读写标志,R只读标志,其它,不作处理, 5 数据类型,6----最后.相对的字段名
- '*关于数据类型:C -字符 I 整数 F 浮点数 A 金额 U 单价 D 日期 T 时间
- Public Function GetConToRs(ByRef m_Frm As Object, _
- ByRef MRs As ADODB.Recordset) As SmCtrlCorRs()
- Dim A As Long, B As Long
- Dim SaveID As Long
- Dim AddSave As Boolean
- Dim ArrayCon() As Control '控件
- Dim TabFied() As SmFiedArrtr '数据库字段
- Dim SetFied() As String '同时存在的字段
- Dim ReturnVal() As SmCtrlCorRs '定义一个结构数组,用于返回
- Dim AddFile As SmCtrlCorRs
- Dim Rs As New ADODB.Recordset
- Dim SId As Long
- Dim FrmCon As Control
- Dim ConName As String
- Dim ConID As Long
- Dim Frm As Form
- Err.Clear
- On Error Resume Next
- Erase ArrayCon: ConID = 0
- Set Frm = m_Frm
- For Each FrmCon In Frm.Controls '取控件,放入一个数组中
- ConName = FrmCon.Name
- '/将图片框控件排除
- If UCase$(TypeName(FrmCon)) = UCase$("PictureBox") Or UCase$(TypeName(FrmCon)) = UCase$("Image") Or UCase$(TypeName(FrmCon)) = UCase$("SMPICBOX") Then
- Else
- If Len(ConName) > 5 Then
- If UCase$(Mid$(ConName, 4, 1)) = "W" Or UCase$(Mid$(ConName, 4, 1)) = "R" Then
- ConID = ConID + 1
- ReDim Preserve ArrayCon(ConID - 1)
- Set ArrayCon(ConID - 1) = FrmCon
- End If
- End If
- End If
- Next
- '/---------------------------------------------------------------------------------------------
- Erase TabFied
- Set Rs = MRs.Clone
- If Rs.EOF And Rs.BOF Then
- Rs.AddNew
- End If
- TabFied = GetRsAttrib(MRs) '取字段属性
- If UBound(TabFied, 1) > 0 Then
- SaveID = 0: AddSave = False
- For A = 0 To UBound(TabFied, 1)
- For B = 0 To UBound(ArrayCon, 1)
- ConName = UCase$(Right$(ArrayCon(B).Name, Len(ArrayCon(B).Name) - 5))
- If UCase$(TabFied(A).FieldName) = ConName Then
- SId = SId + 1
- ReDim Preserve ReturnVal(SId - 1)
- ReturnVal(SId - 1).FieldName = TabFied(A).FieldName
- ReturnVal(SId - 1).FieldActSize = TabFied(A).FieldActSize
- ReturnVal(SId - 1).FieldDefSize = TabFied(A).FieldDefSize
- ReturnVal(SId - 1).FieldIsNull = TabFied(A).FieldIsNull
- ReturnVal(SId - 1).FieldName = TabFied(A).FieldName
- ReturnVal(SId - 1).FieldType = TabFied(A).FieldType
- Set ReturnVal(SId - 1).FrmCon = ArrayCon(B) '对应的控件
- '/设置字符型的数据长度.
- If UCase$(TypeName(ReturnVal(SId - 1).FrmCon)) = UCase$("TextBox") Then
- Select Case ReturnVal(SId - 1).FieldType
- Case Is = 200 'VARCHAR
- ReturnVal(SId - 1).FrmCon.MaxLength = (ReturnVal(SId - 1).FieldDefSize) / 2
- Case Is = 202 'NVARCHAR
- ReturnVal(SId - 1).FrmCon.MaxLength = (ReturnVal(SId - 1).FieldDefSize)
- Case Is = 129 'CHAR
- ReturnVal(SId - 1).FrmCon.MaxLength = (ReturnVal(SId - 1).FieldDefSize) / 2
- Case Is = 130 'NCHAR
- ReturnVal(SId - 1).FrmCon.MaxLength = (ReturnVal(SId - 1).FieldDefSize)
- Case Is = 201 'TEXT
- ReturnVal(SId - 1).FrmCon.MaxLength = (ReturnVal(SId - 1).FieldDefSize) / 2
- Case Is = 203 'NTEXT
- ReturnVal(SId - 1).FrmCon.MaxLength = (ReturnVal(SId - 1).FieldDefSize)
- End Select
- End If
- End If
- Next
- Next
- End If
- Set Rs = Nothing
- GetConToRs = ReturnVal
- Erase ArrayCon: Erase ReturnVal
- Err.Clear
- End Function
- '
- '返回窗体中除IMAGE字段外的所有字段名
- '函数名:GetFrmFld
- '参数: ArrCon SmCtrlCorRs数组,TlbName 数据表名
- '返回值:一个以","分隔的字段列表.
- '例:
- Public Function GetFrmFld(ByRef ArrCon() As SmCtrlCorRs, TlbName As String) As String
- Dim ReturnVal As String
- Dim N As Long
- Dim ConName As String
- Err.Clear
- On Error Resume Next
- For N = 0 To UBound(ArrCon, 1)
- ConName = ArrCon(N).FrmCon.Name
- If ArrCon(N).FieldType <> 205 And UCase$(Mid$(ConName, 4, 1)) = "W" Then
- ReturnVal = ReturnVal & TlbName & "." & ArrCon(N).FieldName & ","
- End If
- Next
- If Len(ReturnVal) > 0 Then ReturnVal = Left$(ReturnVal, Len(ReturnVal) - 1)
- GetFrmFld = IIf(Err.Number = 0, ReturnVal, "")
- Err.Clear
- End Function
- '
- '从窗体的控件中生成 SQL (INSERT INTO)
- '函数名:GetFrmIntoSql
- '参数: tArrCon() DATAFRM类型数组,DateTabName 目标数据表名.Reorder 重新定位.
- '返回值:Insert Inot Sql 语句
- '例: FrmSql=GetFrmIntoSql(MeArrCon,"AchGoods")
- Function GetFrmIntoSql(P_Cnn As ADODB.Connection, ByRef ArrCon() As SmCtrlCorRs, DateTabName As String, Optional Reorder As Boolean = False) As String
- Dim I As Long
- Dim StrSql As String
- Dim TmpVal As Variant
- Dim FldVal As String
- Dim FileSum As String
- Dim ReID As Long
- Dim M As Long
- Dim N As Long
- Dim TArrCon() As SmCtrlCorRs
- Dim TabFldAtt() As SmFiedArrtr
- Dim TmpFldAtt As SmCtrlCorRs
- Err.Clear
- On Error Resume Next
- If P_Cnn.State <> 1 Then P_Cnn.Open
- If Reorder Then '//重新定位.
- TabFldAtt = GetTabFldAttrib(P_Cnn, DateTabName)
- For N = 0 To UBound(ArrCon)
- For M = 0 To UBound(TabFldAtt)
- If UCase$(ArrCon(N).FieldName) = UCase$(TabFldAtt(M).FieldName) Then
- ReID = ReID + 1
- ReDim Preserve TArrCon(ReID - 1)
- TArrCon(ReID - 1) = ArrCon(N)
- End If
- Next
- Next
- Else
- TArrCon = ArrCon
- End If
- '***********************************************************************
- For I = 0 To UBound(TArrCon, 1)
- If UCase$(Mid$(TArrCon(I).FrmCon.Name, 4, 1)) = "W" Then '将具有写标志的控件组合成SQL语句
- If TArrCon(I).FieldType = 205 Or UCase$(TypeName(TArrCon(I).FrmCon)) = UCase$("PictureBox") _
- Or UCase$(TypeName(TArrCon(I).FrmCon)) = UCase$("Image") Or UCase$(TypeName(TArrCon(I).FrmCon)) = UCase$("SMPICBOX") Then '排除IMAGE字段
- '/If tArrCon(I).FieldType <> 205 Then '排除IMAGE字段
- Else
- TmpVal = Trim$(CT.ToStr(TArrCon(I).FrmCon)) '取值
- FileSum = FileSum & "[" & TArrCon(I).FieldName & "],"
- If Len(TmpVal) = 0 Then '对空或NULL的处理
- Select Case TArrCon(I).FieldType '数据类型
- Case 2, 3, 4, 5, 6, 17, 131 '数值类型
- If TArrCon(I).FieldIsNull <> 0 Then '可接受NULL
- FldVal = FldVal & "NULL,"
- Else
- FldVal = FldVal & "0,"
- End If
- Case 135 '日期时间
- If TArrCon(I).FieldIsNull <> 0 Then '可接受NULL
- FldVal = FldVal & "NULL,"
- Else
- If DbStyle = "MDB" Then
- FldVal = FldVal & "#" & Now() & "#,"
- Else
- FldVal = FldVal & "'" & Now() & "',"
- End If
- End If
- Case Else '其它类型
- If TArrCon(I).FieldIsNull <> 0 Then
- FldVal = FldVal & "NULL,"
- Else
- FldVal = FldVal & "'',"
- End If
- End Select
- Else
- Select Case TArrCon(I).FieldType
- Case 2, 3, 4, 5, 6, 17, 131 '数值类型
- FldVal = FldVal & "" & TmpVal & ","
- Case 135
- If DbStyle = "MDB" Then
- FldVal = FldVal & "#" & TmpVal & "#,"
- Else
- FldVal = FldVal & "'" & TmpVal & "',"
- End If
- Case Else '其它类型
- FldVal = FldVal & "'" & CT.DetSem(TmpVal) & "',"
- End Select
- End If
- End If
- End If
- Next I
- FldVal = Left$(FldVal, Len(FldVal) - 1)
- FileSum = Left$(FileSum, Len(FileSum) - 1)
- StrSql = "INSERT INTO [" & DateTabName & "] (" & FileSum & ") VALUES (" & FldVal & ")"
- FldVal = ""
- GetFrmIntoSql = IIf(Err.Number = 0, StrSql, "")
- Err.Clear
- End Function
- '
- '从窗体的控件中生成 SQL (UPDATE)
- '函数名:GetFrmUpSql
- '参数: ArrCon() DATAFRM类型数组,DateTabName 目标数据表名,WhereStr 更新条件
- '返回值:UPDATA Sql 语句
- '例: FrmSql=GetFrmUpSql(MeArrCon,"AchGoods","Where gdsid='001'")
- Public Function GetFrmUpSql(ByRef ArrCon() As SmCtrlCorRs, _
- DateTabName As String, _
- WhereStr As String) As String
- Dim I As Long, StrSql As String
- Dim TmpVal As Variant
- Dim FldVal As String
- Dim FileSum As String
- Err.Clear
- On Error Resume Next
- For I = 0 To UBound(ArrCon, 1)
- If UCase$(Mid$(ArrCon(I).FrmCon.Name, 4, 1)) = "W" Then '将具有写标志的控件组合成SQL语句
- If ArrCon(I).FieldType = 205 Or UCase$(TypeName(ArrCon(I).FrmCon)) = UCase$("PictureBox") _
- Or UCase$(TypeName(ArrCon(I).FrmCon)) = UCase$("Image") Or UCase$(TypeName(ArrCon(I).FrmCon)) = UCase$("SMPICBOX") Then '排除IMAGE字段
- '/If ArrCon(I).FieldType <> 205 Then '排除IMAGE字段
- Else
- TmpVal = Trim$(CT.ToStr(ArrCon(I).FrmCon))
- If Len(TmpVal) = 0 Then '对空或NULL的处理
- Select Case ArrCon(I).FieldType
- Case 2, 3, 4, 5, 6, 17, 131 '数值类型
- If ArrCon(I).FieldIsNull <> 0 Then '可按受NULL
- FldVal = FldVal & ",[" & ArrCon(I).FieldName & "]=NULL"
- Else
- FldVal = FldVal & ",[" & ArrCon(I).FieldName & "]=0"
- End If
- Case 135 '日期
- If ArrCon(I).FieldIsNull <> 0 Then '可接受NULL
- FldVal = FldVal & ",[" & ArrCon(I).FieldName & "]=NULL"
- Else
- If DbStyle = "MDB" Then
- FldVal = FldVal & ",[" & ArrCon(I).FieldName & "]=#" & Now() & "#"
- Else
- FldVal = FldVal & ",[" & ArrCon(I).FieldName & "]='" & Now() & "'"
- End If
- End If
- Case Else '其它类型
- If ArrCon(I).FieldIsNull <> 0 Then
- FldVal = FldVal & ",[" & ArrCon(I).FieldName & "]=NULL"
- Else
- FldVal = FldVal & ",[" & ArrCon(I).FieldName & "]=''"
- End If
- End Select
- Else
- Select Case ArrCon(I).FieldType
- Case 2, 3, 4, 5, 6, 17, 131 '数值类型
- FldVal = FldVal & ",[" & ArrCon(I).FieldName & "]=" & TmpVal
- Case 135
- If DbStyle = "MDB" Then
- FldVal = FldVal & ",[" & ArrCon(I).FieldName & "]=#" & TmpVal & "#"
- Else
- FldVal = FldVal & ",[" & ArrCon(I).FieldName & "]='" & TmpVal & "'"
- End If
- Case Else '其它类型
- FldVal = FldVal & ",[" & ArrCon(I).FieldName & "]='" & CT.DetSem(TmpVal) & "'"
- End Select
- End If
- End If
- End If
- Next
- FldVal = " Set " & Right$(FldVal, Len(FldVal) - 1) & " " & WhereStr
- StrSql = "UpDate [" & DateTabName & "]" & FldVal
- GetFrmUpSql = IIf(Err.Number = 0, StrSql, "")
- FldVal = "": StrSql = ""
- Err.Clear
- End Function
- '
- '对窗体的所有控件赋值
- '函数名:SetFrmCtrlValue
- '参数: MRs 源记录集,SetConArr DATAFRM类型数组
- '返回值:
- '例: CALL SetFrmCtrlValue(RS,MEARRCON)
- Public Function SetFrmCtrlValue(ByRef Rs As ADODB.Recordset, _
- ByRef SetConArr() As SmCtrlCorRs) As Boolean
- Dim N As Long
- Dim MRs As New ADODB.Recordset
- Dim ConTmp As Control
- Dim TmpVal As String
- Dim TmpFldName As String
- Dim TP As Picture
- Err.Clear
- On Error Resume Next
- Set TP = Nothing
- Set MRs = Rs.Clone
- If MRs.EOF And MRs.BOF Then
- MRs.AddNew
- End If
- For N = 0 To UBound(SetConArr, 1)
- Set ConTmp = SetConArr(N).FrmCon
- TmpFldName = SetConArr(N).FieldName
- If UCase$(TypeName(ConTmp)) = UCase$("OptionButton") Then
- ConTmp = CT.ToBol(MRs.Fields(TmpFldName))
- ElseIf UCase$(TypeName(ConTmp)) = UCase$("CheckBox") Then
- ConTmp = CT.ToLng(MRs.Fields(TmpFldName))
- ElseIf SetConArr(N).FieldType = 205 Or UCase$(TypeName(ConTmp)) = UCase$("PictureBox") Or UCase$(TypeName(ConTmp)) = UCase$("Image") Or UCase$(TypeName(ConTmp)) = UCase$("SMPICBOX") Then
- '/IMAGE字段要另行处理.在这里先清除原先图片
- ConTmp.Picture = TP: Set ConTmp.Picture = Nothing
- ElseIf SetConArr(N).FieldType = 135 Then '日期
- TmpVal = CT.ToStr(MRs.Fields(TmpFldName))
- If Len(TmpVal) > 0 And IsDate(TmpVal) Then
- If UCase$(Mid$(ConTmp.Name, 5, 1)) = "T" Then '时间
- ConTmp = Format$(TmpVal, P_UserDataFmt.TimeFmt)
- Else '日期
- ConTmp = Format$(TmpVal, P_UserDataFmt.DateFmt)
- End If
- Else
- Err.Clear: ConTmp = ""
- If Err.Number <> 0 Then '如果不能为NULL
- If UCase$(Mid$(ConTmp.Name, 5, 1)) = "T" Then '时间
- ConTmp = Format$(Now(), P_UserDataFmt.TimeFmt)
- Else '日期
- ConTmp = Format$(Now(), P_UserDataFmt.DateFmt)
- End If
- End If
- End If
- Else
- If UCase$(Mid$(ConTmp.Name, 5, 1)) = "F" Then '如果是浮点数.
- ConTmp = Format$(Val(CT.ToStr(MRs.Fields(TmpFldName))), "0.############")
- Else
- ConTmp = CT.ToStr(MRs.Fields(TmpFldName))
- End If
- End If
- Next
- SetFrmCtrlValue = (Err.Number = 0)
- If MRs.State = adStateOpen Then
- MRs.Close
- Set MRs = Nothing
- End If
- Err.Clear
- Set ConTmp = Nothing
- 'Errhan:
- ' If Err.Number <> 0 Then
- ' MsgBox Error(Err.Number) & ":" & TmpFldName
- ' End If
- End Function
- '
- '对窗体所有控件值之和
- '函数名:GetAddStr
- '参数: SetConArr DATAFRM类型数组
- '返回值:字符串
- '例: CALL GetAddStr(MEARRCON)
- '注:主要用来判断值是否改变.
- Public Function GetAddStr(ByRef SetConArr() As SmCtrlCorRs) As String
- Dim N As Long
- Dim ConTmp As Control
- Dim ReturnVal As String
- Err.Clear
- On Error Resume Next
- For N = 0 To UBound(SetConArr, 1)
- Set ConTmp = SetConArr(N).FrmCon
- If UCase$(TypeName(ConTmp)) = UCase$("PictureBox") Or UCase$(TypeName(ConTmp)) = UCase$("Image") Or UCase$(TypeName(ConTmp)) = UCase$("SMPICBOX") Then
- ReturnVal = ReturnVal & ConTmp.Tag
- Else
- ReturnVal = ReturnVal & CT.ToStr(ConTmp)
- End If
- Next
- GetAddStr = IIf(Err.Number = 0, ReturnVal, "")
- Set ConTmp = Nothing
- Err.Clear
- End Function
- '
- '清空窗体中所有与数据库相关控件的数据
- '函数名:ClearFrmCtrlValue
- '参数: SetConArr DATAFRM类型数组
- '返回值:
- '例: CALL ClearFrmCtrlValue(MEARRCON)
- Public Function ClearFrmCtrlValue(ByRef SetConArr() As SmCtrlCorRs) As Boolean
- Dim N As Long
- Dim ConTmp As Control
- Dim TP As Picture '清除图片框用.
- Err.Clear
- On Error Resume Next
- Set TP = Nothing
- For N = 0 To UBound(SetConArr, 1)
- Set ConTmp = SetConArr(N).FrmCon
- If UCase$(TypeName(ConTmp)) = UCase$("OptionButton") Then
- ConTmp = False
- ElseIf UCase$(TypeName(ConTmp)) = UCase$("CheckBox") Then
- ConTmp = 0
- ElseIf UCase$(TypeName(ConTmp)) = UCase$("PictureBox") Or UCase$(TypeName(ConTmp)) = UCase$("Image") Or UCase$(TypeName(ConTmp)) = UCase$("SMPICBOX") Then
- ConTmp.Picture = TP: Set ConTmp.Picture = Nothing
- ElseIf UCase$(TypeName(ConTmp)) = UCase$("DTPicker") Or UCase$(TypeName(ConTmp)) = UCase$("MonthView") Then
- Err.Clear: ConTmp = ""
- If Err.Number <> 0 Then
- ConTmp = Now()
- End If
- Else
- ConTmp = ""
- End If
- Next
- ClearFrmCtrlValue = (Err.Number = 0)
- Set ConTmp = Nothing
- Err.Clear
- End Function
- '
- '读写二进制数据(流)
- '函数名:AdoStream
- '参数: P_Cnn ADODB连接,TabName 目标数据表,FldName 目标字段,WhereStr 更新条件,
- ' FileName 源文件名或由流生成的文件名,RsStyle 记录集的操作类型.W:File to Recode,R:Recode to File
- '返回值:
- '例: CALL AdoStream(P_Cnn,"AchGoods","GdsPhoto","Where gdsid='001'","C:/Tmp.Bmp","W")
- Public Function AdoStream(P_Cnn As ADODB.Connection, _
- TabName As String, _
- FldName As String, _
- Optional WhereStr As String = "", _
- Optional Filename As String, _
- Optional RsStyle As SmRsType = RsWrite) As String
- Dim StrSql As String
- Dim TmpFileName As String
- Dim Rs As New ADODB.Recordset
- Dim AdoSem As New ADODB.Stream
- Dim ReturnVal As String
- Dim WorkPath As String
- Dim RsType As Long
- Dim RsStyleStr As String
- Err.Clear
- On Error Resume Next
- WorkPath = App.Path
- If P_Cnn.State <> 1 Then P_Cnn.Open
- If Right$(WorkPath, 1) <> "/" Then WorkPath = WorkPath & "/"
- ReturnVal = ""
- AdoSem.Type = adTypeBinary '流数据类型
- AdoSem.Open '打开流
- '/-----------------------------------------------------------
- '将流写入记录集
- RsType = RsStyle
- RsStyleStr = Choose(RsType, "W", "R")
- If RsStyleStr = "W" Then
- If Left$(Trim$(UCase$(WhereStr)), Len("where")) <> UCase$("where") Then WhereStr = " Where " & Trim$(WhereStr)
- StrSql = "Select Top 1 [" & TabName & "].[" & FldName & "] From [" & TabName & "] " & WhereStr
- Set Rs = RsOpen(P_Cnn, StrSql, False) '连接式记录集
- If Not (Rs.EOF And Rs.BOF) Then
- Rs.MoveFirst
- AdoSem.LoadFromFile Filename '将文件LOAD到流
- DoEvents
- Rs.Fields(FldName).AppendChunk AdoSem.Read
- Rs.Update
- End If
- AdoStream = ""
- ElseIf RsStyle = "R" Then
- '/将流从记录集中取出
- If Len(Trim$(Filename)) = 0 Then Filename = "TmpFile.Bmp"
- If Len(Trim$(Dir$(TmpFileName, vbNormal + vbHidden))) > 0 Then Kill Filename
- If Left$(Trim$(UCase$(WhereStr)), Len("where")) <> UCase$("where") Then WhereStr = " Where " & Trim$(WhereStr)
- StrSql = "Select Top 1 [" & TabName & "].[" & FldName & "] From [" & TabName & "] " & WhereStr
- Set Rs = RsOpen(P_Cnn, StrSql)
- If Not (Rs.EOF And Rs.BOF) Then
- Rs.MoveFirst
- If Not (IsNull(Rs.Fields(FldName))) Then
- TmpFileName = WorkPath & Filename
- AdoSem.Write Rs.Fields(FldName).GetChunk(Rs.Fields(FldName).ActualSize)
- DoEvents
- AdoSem.SaveToFile TmpFileName, IIf(Len(Trim$(Dir$(TmpFileName, vbNormal + vbHidden))) > 0, adSaveCreateOverWrite, adSaveCreateNotExist)
- AdoStream = TmpFileName
- Else
- AdoStream = ""
- End If
- Else
- AdoStream = ""
- End If
- End If
- If AdoSem.State = adStateOpen Then
- AdoSem.Close
- Set AdoSem = Nothing
- End If
- If Rs.State = adStateOpen Then
- Rs.Close
- Set Rs = Nothing
- End If
- Err.Clear
- End Function
- '将二进制文件添加到数据库中(该记录必须在存在)
- '函数名:FileToRecode
- '参数: P_Cnn ADODB连接,TabName 目标数据表,FldName 目标字段,WhereStr 更新条件,FileName 源文件名
- '返回值:
- '例: CALL FileToRecode(P_Cnn,"AchGoods","GdsPhoto","Where gdsid='001'","C:/Tmp.Bmp")
- Public Function FileToRecode(ByRef P_Cnn As ADODB.Connection, _
- TabName As String, _
- FldName As String, _
- WhereStr As String, _
- Filename As String) As Boolean
- Dim RsB As New ADODB.Recordset
- Dim Person_name As String
- Dim StrSql As String
- Dim File_Num As String
- Dim File_Length As String
- Dim Bytes() As Byte
- Dim Num_Blocks As Long
- Dim Left_Over As Long
- Dim Block_Num As Long
- Err.Clear
- On Error Resume Next
- File_Num = FreeFile
- Filename = Trim$(Filename)
- If P_Cnn.State <> 1 Then P_Cnn.Open
- If Len(Dir$(Filename)) = 0 Or Len(Filename) = 0 Then FileToRecode = False: Exit Function
- Open Filename For Binary Access Read As #File_Num
- File_Length = LOF(File_Num) '取文件大小
- If File_Length > 0 Then
- Num_Blocks = File_Length / Block_Size
- Left_Over = File_Length Mod Block_Size
- If Left$(Trim$(UCase$(WhereStr)), Len("where")) <> UCase$("where") Then WhereStr = "Where " & Trim$(WhereStr)
- StrSql = "Select Top 1 [" & TabName & "].[" & FldName & "] From [" & TabName & "] " & WhereStr
- Set RsB = RsOpen(P_Cnn, StrSql, False) '连接式记录集
- If Not (RsB.EOF And RsB.BOF) Then
- '/ '不分块写
- '/ ReDim Bytes(File_Length)
- '/ Get #File_Num, , Bytes()
- '/ DoEvents
- '/ RsB.Fields(FldName).AppendChunk Bytes()
- '/分块写
- ReDim Bytes(Block_Size)
- For Block_Num = 1 To Num_Blocks
- Get #File_Num, , Bytes()
- RsB.Fields(FldName).AppendChunk Bytes()
- Next
- If Left_Over > 0 Then
- ReDim Bytes(Left_Over)
- Get #File_Num, , Bytes()
- RsB.Fields(FldName).AppendChunk Bytes()
- End If
- RsB.Update
- DoEvents
- End If
- If RsB.State = adStateOpen Then
- RsB.Close
- Set RsB = Nothing
- End If
- End If
- Close #File_Num
- Erase Bytes
- FileToRecode = (Err.Number = 0)
- Err.Clear
- End Function
- '
- '将二进制数据从记录中取出
- '函数名:RecodeToFile
- '参数: P_Cnn ADODB连接,TabName 源数据表,FldName 源字段名, WhereStr 取字段条件,FileType 生成临时文件的类型
- '返回值:'一个临时文件名
- '例: GetTmpFile=RecodeToFile(P_Conn,"achgoods","achphoto","where gdsid='001',"bmp")
- Public Function RecodeToFile(ByRef P_Cnn As ADODB.Connection, _
- TabName As String, _
- FldName As String, _
- WhereStr As String, _
- Optional FileType As String = "Bmp") As String
- Dim Rs As New ADODB.Recordset
- Dim StrSql As String
- Dim Bytes() As Byte
- Dim File_Name As String
- Dim File_Num As Integer
- Dim File_Length As Long
- Dim Num_Blocks As Long
- Dim Left_Over As Long
- Dim Block_Num As Long
- Dim WorkPath As String
- Dim TmpDir As New SmSysCls
- Err.Clear
- On Error Resume Next
- WorkPath = TmpDir.GetFolder(SmWinTempDirectory)
- If Dir$(WorkPath, vbDirectory) = "" Then WorkPath = App.Path
- If Right$(WorkPath, 1) <> "/" Then WorkPath = WorkPath & "/"
- If Left$(Trim$(UCase$(WhereStr)), Len("where")) <> UCase$("where") Then WhereStr = "Where " & Trim$(WhereStr)
- StrSql = "Select Top 1 [" & TabName & "].[" & FldName & "] From [" & TabName & "] " & WhereStr
- Set Rs = RsOpen(P_Cnn, StrSql)
- If Rs.BOF And Rs.EOF Then Exit Function
- If P_Cnn.State <> 1 Then P_Cnn.Open
- If Not IsNull(Rs.Fields(FldName)) Then
- File_Name = WorkPath & "TmpFile." & FileType
- If Len(Dir(File_Name)) <> 0 Then Kill File_Name
- File_Num = FreeFile
- Open File_Name For Binary As #File_Num
- File_Length = CT.ToLng(Rs.Fields(FldName).ActualSize) '取字段的实际大小
- '/不分块读写
- '/ If File_Length > 0 Then
- '/ Bytes() = Rs.Fields(FldName).GetChunk(File_Length)
- '/ Put #File_Num, , Bytes()
- '/ Else
- '/ Err = -1
- '/ End If
- '/分块读写
- Num_Blocks = File_Length / Block_Size
- Left_Over = File_Length Mod Block_Size
- For Block_Num = 1 To Num_Blocks
- Bytes() = Rs.Fields(FldName).GetChunk(Block_Size)
- Put #File_Num, , Bytes()
- Next
- If Left_Over > 0 Then
- Bytes() = Rs.Fields(FldName).GetChunk(Left_Over)
- Put #File_Num, , Bytes()
- End If
- Erase Bytes
- Close #File_Num
- If Rs.State = adStateOpen Then
- Rs.Close
- Set Rs = Nothing
- End If
- Erase Bytes
- End If
- RecodeToFile = IIf(Err.Number = 0, File_Name, "")
- Set TmpDir = Nothing
- Err.Clear
- End Function
- '
- '对组合框赋值(直接从数据库取值,如果有多个值,则只取第一个值.)
- '函数名:SetFrmCtrlValue
- '参数: P_Cnn ADODB连接,StrSql 取值SQL语句,CtrFiedList 动态参数列表
- '返回值:
- '例: CALL SetGroupVal(P_Cnn,"Select AchGds.* From AchGds Where GdsID='001'",TxtWNGdsID,"GdsID",TxtWNGdsName,"GdsName")
- '*注:动态参数列表(CtrFiedList)的奇数位是 目标名,偶数位 是对应字段名.
- Public Function SetGroupVal(ByRef P_Cnn As ADODB.Connection, _
- StrSql As String, _
- ParamArray CtrFiedList() As Variant) As Boolean
- Dim Rs As New ADODB.Recordset
- Dim N As Long
- Dim id As Long
- Dim ConFiedArr() As SmPutGroup
- Dim ReturnVal As Boolean
- Err.Clear
- On Error Resume Next
- ReturnVal = False
- If P_Cnn.State <> 1 Then P_Cnn.Open
- Set Rs = RsOpen(P_Cnn, StrSql)
- If Not (Rs.EOF And Rs.BOF) Then
- Rs.MoveFirst
- id = 0
- '/分解控件与字段名
- For N = 0 To UBound(CtrFiedList, 1)
- If N Mod 2 = 0 Then
- id = id + 1
- ReDim Preserve ConFiedArr(id - 1)
- '/控件
- Set ConFiedArr(id - 1).FrmControl = CtrFiedList(N)
- Else
- '/字段名
- ConFiedArr(id - 1).FldName = CtrFiedList(N)
- End If
- Next
- '/对控件赋值
- For N = 0 To UBound(ConFiedArr, 1)
- ConFiedArr(N).FrmControl = CStr("" & (Rs.Fields(ConFiedArr(N).FldName)))
- Next
- ReturnVal = True
- Else
- ReturnVal = False
- End If
- SetGroupVal = ReturnVal
- If Rs.State = adStateOpen Then
- Rs.Close
- Set Rs = Nothing
- End If
- Err.Clear
- End Function
- '
- '返回单个数据字段值.
- '函数名:SetFrmCtrlValue
- '参数: P_Cnn ADODB连接,DbTabName 源数据表名,FldName 源数据字段名,WhereStr 取值的条件语句
- '返回值:相对应的字段值
- '例: GdsNameVal=GetOneValue(P_CNN,"ACHGOODS","GDSNAME","WHERE GDSID='001'")
- Public Function GetOneValue(ByRef P_Cnn As ADODB.Connection, _
- DbTabname As String, _
- FldName As String, _
- WhereStr As String) As String
- Dim StrSql As String
- Dim Rs As New ADODB.Recordset
- Err.Clear
- On Error Resume Next
- If P_Cnn.State <> 1 Then P_Cnn.Open
- If Left$(Trim$(UCase$(WhereStr)), Len("where")) <> UCase$("where") Then WhereStr = "Where " & Trim$(WhereStr)
- StrSql = "Select Top 1 [" & DbTabname & "].[" & FldName & "] From [" & DbTabname & "] " & WhereStr
- Set Rs = RsOpen(P_Cnn, StrSql)
- If Not (Rs.EOF And Rs.BOF) Then
- Rs.MoveFirst
- GetOneValue = CT.ToStr(Rs.Fields(FldName))
- Else
- GetOneValue = ""
- End If
- If Rs.State = adStateOpen Then
- Rs.Close
- Set Rs = Nothing
- End If
- Err.Clear
- End Function
- '
- '删除记录
- '函数:KillRecode
- '参数:FldName 字段名,FldVal 字段值,TabName 表名
- '
- Function KillRecode(ByRef P_Cnn As ADODB.Connection, _
- TabName As String, _
- FldName As String, _
- FldVal As String)
- Dim StrSql As String
- If P_Cnn.State <> 1 Then P_Cnn.Open
- StrSql = "Delete " & TabName & " From " & TabName & " Where " & FldName & "='" & FldVal & "'"
- P_Cnn.Execute StrSql
- Err.Clear
- End Function
- '
- '取最大单号
- '前二位.单据类型.+四位年+二位月+二位日+4位单据流水号
- '函数:GetMaxBillID
- '参数:FldName 字段名(BillID),BillStyle 单据类型,TabName 表名
- '返回值:可用最大单号
- Function GetMaxBillID(ByRef P_Cnn As ADODB.Connection, _
- TabName As String, _
- FldName As String, _
- BillStyle As String) As String
- Dim BillSD As String
- Dim StrSql As String
- Dim Rs As New ADODB.Recordset
- Dim BillNo As Long
- Dim NewBillID As Long
- Dim lLen As Long
- Dim ReturnVal As String
- Dim RNum As Long
- Dim RLen As Long
- Dim FmtStr As String
- Dim N As Long
- Err.Clear
- On Error Resume Next
- If P_Cnn.State <> 1 Then P_Cnn.Open
- BillSD = BillStyle & Format$(Date, "YYYYMMDD")
- '/--------------------------------------------------
- lLen = Len(BillSD): RLen = 4 '单据流水号位数
- '/--------------------------------------------------
- For N = 1 To RLen
- FmtStr = FmtStr & "0"
- Next
- '/--------------------------------------------------
- StrSql = "Select (Max(" & FldName & ")) AS MaxID From " & TabName & " Where LEFT(" & FldName & "," & lLen & ")='" & BillSD & "'"
- Set Rs = RsOpen(P_Cnn, StrSql)
- If Not (Rs.EOF And Rs.BOF) Then
- If Len(CT.ToStr(Rs.Fields("MaxID"))) > 0 Then
- RNum = Right$(CT.ToStr(Rs.Fields("MaxID")), RLen)
- Else
- RNum = 0
- End If
- NewBillID = CT.ToLng(RNum) + 1
- Else
- NewBillID = 1
- End If
- If Rs.State = adStateOpen Then
- Rs.Close
- Set Rs = Nothing
- End If
- ReturnVal = BillSD & "-" & Format$(NewBillID, FmtStr)
- GetMaxBillID = IIf(Err.Number = 0, ReturnVal, "")
- Err.Clear
- End Function
- '
- '压缩MDB数据库
- '函数名:ZipMdb
- '参数:P_Cnn ADODB连接,SourFileName 源文件名,ObjFileName 目标文件名,
- ' Provider Provider参数(视JET版而定,默认是4.0),UserID 用户名,
- ' UserPwd 密码
- '返回值:TRUE 成功,FALSE 失败.
- Public Function ZipMdb(P_Cnn As ADODB.Connection, _
- MdbFileName As String, _
- Optional Provider As String = "Microsoft.Jet.OLEDB.4.0", _
- Optional UserID As String = "admin", _
- Optional UserPwd As String = "") As Boolean
- Dim Yjro As New JRO.JetEngine
- Dim WorkPath As String
- Dim TmpName As String
- Dim FileCon As SmFileCls
- Err.Clear
- On Error Resume Next
- '/关闭连接
- P_Cnn.Close: Set P_Cnn = Nothing
- DoEvents
- WorkPath = FileCon.FilePath(MdbFileName)
- TmpName = WorkPath & "mdbTmp.bak"
- '/-------------------------------
- DoEvents
- '/压缩
- Yjro.CompactDatabase "Provider=" & Provider & ";Data Source=" & MdbFileName & ";" & _
- "Jet OLEDB:Database Password=" & UserPwd & ";" & _
- "User ID=" & UserID & ";", _
- "Provider=" & Provider & ";Data Source=" & TmpName & ";" & _
- "Jet OLEDB:Database Password=" & UserPwd & ";" & _
- "User ID=" & UserID & ";"
- DoEvents
- '/删除旧文件,将压缩后的文件COPY到旧位置
- If FileCon.FileCheck(MdbFileName) And FileCon.FileCheck(TmpName) Then
- Kill MdbFileName
- DoEvents
- Call FileCopy(TmpName, MdbFileName)
- DoEvents
- Kill TmpName
- DoEvents
- '/重新连接
- Call CreateMdbConn(P_Cnn, MdbFileName, , UserID, UserPwd)
- Else
- Err.Number = -1
- End If
- Set Yjro = Nothing
- Set FileCon = Nothing
- Err.Clear
- ZipMdb = (Err.Number = 0)
- Err.Clear
- End Function
- '
- '恢复和备份MDB数据库
- '函数名:BakResumeMdb
- '参数:P_Cnn ADODB连接,SourFileName 源文件名,ObjFileName 目标文件名,
- ' Provider Provider参数(视JET版而定,默认是4.0),UserID 用户名,
- ' UserPwd 密码,WorkType 操作类型(0 备份,1 恢复)
- '返回值:TRUE 成功,FALSE 失败.
- '注:当WorkType=0时,源文件名是要备份文件,目标文件名是备份文件.
- ' 当WorkType=1时,源文件名是备份文件,目标文件名要恢复的文件.
- Public Function BakResumeMDB(P_Cnn As ADODB.Connection, _
- SourFileName As String, _
- ObjFileName As String, _
- Optional Provider As String = "Microsoft.Jet.OLEDB.4.0", _
- Optional UserID As String = "admin", _
- Optional UserPwd As String = "", _
- Optional WorkType As Long = 0) As Boolean
- Dim Yjro As New JRO.JetEngine
- Dim WorkPath As String
- Dim FileCon As New SmFileCls
- Err.Clear
- On Error Resume Next
- '/关闭连接
- P_Cnn.Close: Set P_Cnn = Nothing
- DoEvents
- '/-------------------------------
- '/压缩
- Yjro.CompactDatabase "Provider=" & Provider & SourFileName & ";" & _
- "Jet OLEDB:Database Password=" & UserPwd & ";" & _
- "User ID=" & UserID & ";", _
- "Provider=" & Provider & ";Data Source=" & ObjFileName & ";" & _
- "Jet OLEDB:Database Password=" & UserPwd & ";" & _
- "User ID=" & UserID & ";"
- DoEvents
- '/删除旧文件,将压缩后的文件COPY到旧位置
- If Not (FileCon.FileCheck(SourFileName) And FileCon.FileCheck(ObjFileName)) Then
- If WorkType = 0 Then
- '/备份。
- Call CreateMdbConn(P_Cnn, SourFileName, , UserID, UserPwd)
- Else
- '/恢复
- Call CreateMdbConn(P_Cnn, ObjFileName, , UserID, UserPwd)
- End If
- Err.Number = -1
- End If
- Set FileCon = Nothing
- Set Yjro = Nothing: Err.Clear
- BakResumeMDB = (Err.Number = 0)
- Err.Clear
- End Function
- '
- '解读身份证信息
- '函数名:GetIDCard
- '参数:P_Cnn ADODB连接,IDCode 身份证编号,RevCodeInfo EmpCodeInfo(用于返回),
- '返回值:无
- Public Function GetIDCard(ByRef P_Cnn As ADODB.Connection, IDCode As String, ByRef RevCodeInfo As EmpCodeInfo)
- Dim Rs As New ADODB.Recordset
- Dim StrSql As String
- Dim I As Long
- Dim TAdd(6) As String
- Dim AddStr(6) As String
- Dim UserAdd As String
- Dim BirthStr As String
- Dim SexStr As String
- Err.Clear
- On Error Resume Next
- AddStr(0) = Left$(IDCode, 2) & "0000" '省
- AddStr(1) = Left$(IDCode, 4) & "00" '市
- AddStr(2) = Left$(IDCode, 6) '县及县级市
- UserAdd = ""
- If P_Cnn.State <> 1 Then P_Cnn.Open
- '取籍贯
- For I = 0 To UBound(AddStr)
- If Len(AddStr(I)) > 0 Then
- StrSql = "SELECT * FROM [Reglism] Where Code='" & AddStr(I) & "'"
- Set Rs = Nothing
- Rs.Open StrSql, P_Cnn, adOpenStatic, adLockReadOnly
- If Not (Rs.EOF And Rs.BOF) Then
- TAdd(I) = "" & Rs.Fields("Name")
- UserAdd = UserAdd & Rs.Fields("Name")
- End If
- End If
- Next
- RevCodeInfo.NativePlace = UserAdd
- '取电话区号
- For I = UBound(TAdd) To 0 Step -1
- If Len(TAdd(I)) > 1 Then
- TAdd(I) = Left$(TAdd(I), 2)
- StrSql = "SELECT * FROM [PhoCode] WHERE [Name] like '" & TAdd(I) & "%'"
- Set Rs = Nothing
- Rs.Open StrSql, P_Cnn, adOpenStatic, adLockReadOnly
- If Not (Rs.EOF And Rs.BOF) Then
- Rs.MoveFirst
- RevCodeInfo.PhoCode = Format$(Rs.Fields("Code"), "0000")
- Exit For
- End If
- End If
- Next
- '取邮政编码
- For I = UBound(TAdd) To 0 Step -1
- If Len(TAdd(I)) > 1 Then
- TAdd(I) = Left$(TAdd(I), 2)
- StrSql = "SELECT * FROM [MailCode] WHERE [Name] Like '" & TAdd(I) & "%'"
- Set Rs = Nothing
- Rs.Open StrSql, P_Cnn, adOpenStatic, adLockReadOnly
- If Not (Rs.EOF And Rs.BOF) Then
- Rs.MoveFirst
- RevCodeInfo.MailCode = Format$(Rs.Fields("Code"), "0000")
- Exit For
- End If
- End If
- Next
- '生日/性别
- If Len(IDCode) = 15 Then '旧身份证号码.
- BirthStr = Mid$(IDCode, 7, Len(IDCode) - 6 - 3) '出生日期
- BirthStr = "19" & BirthStr
- SexStr = CLng(Right$(IDCode, 1)) Mod 2 '顺序码奇数是男.偶数是女
- Else '新身份证号码.
- BirthStr = Mid$(IDCode, 7, Len(IDCode) - 6 - 4) '出生日期
- SexStr = CLng(Mid$(IDCode, Len(IDCode) - 3, 3)) Mod 2 '顺序码奇数是男.偶数是女
- End If
- BirthStr = Left$(BirthStr, 4) & "/" & Mid$(BirthStr, 5, 2) & "/" & Right$(BirthStr, 2)
- RevCodeInfo.Birthday = BirthStr
- RevCodeInfo.Sex = SexStr
- If Rs.State = adStateOpen Then
- Rs.Close
- Set Rs = Nothing
- End If
- Err.Clear
- End Function
- Private Sub Class_Initialize()
- Dim T As New ClsRev
- Set CT = New SmDataDiap
- Call T.GetIniVal
- Set T = Nothing
- End Sub
- Private Sub Class_Terminate()
- On Error Resume Next
- Set CT = Nothing
- End Sub
- '
- '取局域网中所有SQL SERVER 服务器名称
- '函数名:AddSqlServer
- '参数:
- '返回值:字符串数组
- '引用SQLDMO LIB
- Public Function AddSqlServer() As String()
- ' Dim Server As SQLDMO.NameList
- ' Dim appDMO As New SQLDMO.Application
- ' Dim I As Long
- ' Dim StrRev() As String
- '
- ' On Error Resume Next
- '
- ' Set Server = appDMO.ListAvailableSQLServers
- ' For I = 1 To Server.Count
- ' ComNNServerName.AddItem Server(I)
- ' ReDim Preserve StrRev(I)
- ' StrRev(I) = Server(I)
- ' Next
- ' Set Server = Nothing
- ' Set appDMO = Nothing
- Dim oSQLServerDMOApp As Object
- Dim I As Integer
- Dim namX As Object
- Dim StrRev() As String
- Err.Clear
- On Error Resume Next
- Set oSQLServerDMOApp = CreateObject("SQLDMO.Application")
- If oSQLServerDMOApp Is Nothing Then Exit Function
- Set namX = oSQLServerDMOApp.ListAvailableSQLServers
- For I = 1 To namX.Count
- ReDim Preserve StrRev(I - 1)
- StrRev(I - 1) = namX.Item(I)
- Next
- AddSqlServer = StrRev
- Set namX = Nothing
- End Function
- '
- '对TDBGRID表格赋值.
- Public Function SetGrdGroupVal(ByRef P_Cnn As ADODB.Connection, _
- ByRef MRs As ADODB.Recordset, _
- RepeaFldList As String, _
- StrSql As String, _
- ConAndFiedList As Variant) As Boolean
- Dim Rs As New ADODB.Recordset
- Dim N As Long
- Dim id As Long
- Dim ConFiedArr() As SmPutGroup
- Dim ReturnVal As Boolean
- Dim TRs As New ADODB.Recordset
- Dim RepFld() As String
- On Error Resume Next
- If P_Cnn.State <> 1 Then P_Cnn.Open
- ReturnVal = False
- Set Rs = RsOpen(P_Cnn, StrSql)
- If Not (Rs.EOF And Rs.BOF) Then
- Rs.MoveFirst
- id = 0
- '/分解控件与字段名.
- For N = 0 To UBound(ConAndFiedList, 1)
- If N Mod 2 = 0 Then
- id = id + 1
- ReDim Preserve ConFiedArr(id - 1)
- '/控件.
- Set ConFiedArr(id - 1).FrmControl = ConAndFiedList(N)
- Else
- '/字段名.
- ConFiedArr(id - 1).FldName = ConAndFiedList(N)
- End If
- Next
- '/对控件赋值.
- MRs.AddNew: MRs.MoveLast
- For N = 0 To UBound(ConFiedArr, 1)
- ConFiedArr(N).FrmControl = CStr("" & Rs.Fields(ConFiedArr(N).FldName))
- Next
- ReturnVal = True
- Else
- ReturnVal = False
- End If
- SetGrdGroupVal = ReturnVal
- If Rs.State = adStateOpen Then
- Rs.Close
- Set Rs = Nothing
- End If
- Err.Clear
- End Function
- '从RS到RS赋值.
- Public Function SetRsToRs(ByRef SourRs As ADODB.Recordset, _
- ByRef ObjRs As ADODB.Recordset, _
- FldList As String, _
- Optional BlnAddNew As Boolean = False) As Boolean
- Dim RsB As New ADODB.Recordset
- Dim N As Long
- Dim id As Long
- Dim SpArr() As String
- Dim EvaArr() As String
- Dim FldArr() As SmGrdGroup
- Dim ReturnVal As Boolean
- Dim TmpStr() As String
- Err.Clear
- On Error Resume Next
- ReturnVal = False
- If Not (SourRs.EOF And SourRs.BOF) Then
- id = 0
- SpArr = Split(FldList, ",")
- For N = 0 To UBound(SpArr)
- If Len(SpArr(N)) > 0 And InStr(SpArr(N), "=") > 0 Then
- Erase TmpStr
- TmpStr = Split(SpArr(N), "=")
- If Len(TmpStr(0)) > 0 And Len(TmpStr(1)) > 0 Then
- id = id + 1
- ReDim Preserve FldArr(id - 1)
- FldArr(id - 1).ObjFldName = Trim$(TmpStr(0))
- FldArr(id - 1).SourFldName = Trim$((TmpStr(1)))
- End If
- End If
- Next
- If UBound(FldArr, 1) > 0 Then
- If BlnAddNew Then ObjRs.AddNew '新增
- For N = 0 To UBound(FldArr, 1)
- ObjRs.Fields(FldArr(N).ObjFldName) = SourRs.Fields(FldArr(N).SourFldName)
- Next
- ReturnVal = True
- Else
- ReturnVal = False
- End If
- Else
- ReturnVal = False
- End If
- SetRsToRs = ReturnVal
- Err.Clear
- End Function
- '
- '对组合框赋值(直接从数据库取值,如果有多个值,则只取第一个值.)
- '函数名:SetFrmCtrlValue
- '参数: P_Cnn ADODB连接,StrSql 取值SQL语句,ConAndFiedList 动态参数列表(注意,这里的列表是作为一个数组)
- '返回值:
- '例: CALL SetGroupValB(P_Cnn,"Select AchGds.* From AchGds Where GdsID='001'",TxtWNGdsID,"GdsID",TxtWNGdsName,"GdsName")
- '*注:动态参数列表(CtrFiedList)的奇数位是 目标名,偶数位 是对应字段名.
- '组合框赋值
- Public Function SetGroupValB(ByRef P_Cnn As ADODB.Connection, _
- StrSql As String, _
- ConAndFiedList As Variant) As Boolean
- Dim Rs As New ADODB.Recordset
- Dim N As Long
- Dim id As Long
- Dim ConFiedArr() As SmPutGroup
- Dim ReturnVal As Boolean
- Err.Clear
- On Error Resume Next
- ReturnVal = False
- If P_Cnn.State <> 1 Then P_Cnn.Open
- Set Rs = RsOpen(P_Cnn, StrSql)
- If Not (Rs.EOF And Rs.BOF) Then
- Rs.MoveFirst
- id = 0
- '/分解控件与字段名.
- For N = 0 To UBound(ConAndFiedList, 1)
- If N Mod 2 = 0 Then
- id = id + 1
- ReDim Preserve ConFiedArr(id - 1)
- '/控件
- Set ConFiedArr(id - 1).FrmControl = ConAndFiedList(N)
- Else
- '/字段名
- ConFiedArr(id - 1).FldName = ConAndFiedList(N)
- End If
- Next
- '/对控件赋值
- For N = 0 To UBound(ConFiedArr, 1)
- ConFiedArr(N).FrmControl = CStr("" & Rs.Fields(ConFiedArr(N).FldName))
- Next
- ReturnVal = True
- Else
- ReturnVal = False
- End If
- SetGroupValB = ReturnVal
- If Rs.State = adStateOpen Then
- Rs.Close
- Set Rs = Nothing
- End If
- Err.Clear
- End Function
- '//数据库排序
- Public Function DbSort(Rs As ADODB.Recordset, SortFld As String, MdbPath As String) As Recordset
- Dim StrSql As String
- Dim I As Long
- Dim TmpName As String
- Dim TRs As New ADODB.Recordset
- Dim P_MdbCnn As New ADODB.Connection
- Err.Clear
- On Error Resume Next
- Set TRs = Rs.Clone
- TmpName = GetTmpName("S")
- TmpName = Right$(TmpName, Len(TmpName) - 1)
- If P_MdbCnn.State = adStateClosed Or P_MdbCnn Is Nothing Then
- CreateMdbConn P_MdbCnn, MdbPath, , "", ""
- End If
- StrSql = "DROP TABLE " & TmpName
- P_MdbCnn.Execute StrSql
- With TRs
- StrSql = ""
- For I = 0 To .Fields.Count - 1
- Select Case .Fields(I).Type
- Case Is = 6 '货币 6
- StrSql = StrSql & .Fields(I).Name & " Money NULL,"
- Case Is = 11 'ACCESS 是/否 11
- StrSql = StrSql & .Fields(I).Name & " VARCHAR(" & .Fields(I).DefinedSize & ") NULL,"
- Case Is = 129 'CHAR
- StrSql = StrSql & .Fields(I).Name & " VARCHAR(" & .Fields(I).DefinedSize & ") NULL,"
- Case Is = 130 'NCHAR
- StrSql = StrSql & .Fields(I).Name & " VARCHAR(" & .Fields(I).DefinedSize & ") NULL,"
- Case Is = 202 'NVARCHAR
- StrSql = StrSql & .Fields(I).Name & " VARCHAR(" & .Fields(I).DefinedSize & ") NULL,"
- Case Is = 200 'VARCHAR
- StrSql = StrSql & .Fields(I).Name & " VARCHAR(" & .Fields(I).DefinedSize & ") NULL,"
- Case Is = 3 'INT
- StrSql = StrSql & .Fields(I).Name & " LONG NULL,"
- Case Is = 17 'TINYINT 字节 Access 17
- StrSql = StrSql & .Fields(I).Name & " LONG NULL,"
- Case Is = 2 'SMALLINT
- StrSql = StrSql & .Fields(I).Name & " LONG NULL,"
- Case Is = 20, 72 'BIGINT 同步复制 ID 72
- StrSql = StrSql & .Fields(I).Name & " LONG NULL,"
- Case Is = 201 'TEXT
- StrSql = StrSql & .Fields(I).Name & " Memo NULL,"
- Case Is = 203 'NTEXT
- StrSql = StrSql & .Fields(I).Name & " Memo NULL,"
- Case Is = 131, 4, 5 'NUMERIC|4,5 单精度型 4双精度型 5
- StrSql = StrSql & .Fields(I).Name & " Numeric NULL,"
- Case Is = 135, 7 'DATETIME 日期/时间 7
- StrSql = StrSql & .Fields(I).Name & " DATETIME NULL,"
- Case Is = 205 'IMAGE
- StrSql = StrSql & .Fields(I).Name & " Image NULL,"
- Case Is = 128 'BINARY
- StrSql = StrSql & .Fields(I).Name & " Memo NULL,"
- Case Is = 204 'VARBINARY
- StrSql = StrSql & .Fields(I).Name & " Memo NULL,"
- End Select
- Next
- End With
- StrSql = Left$(StrSql, Len(StrSql) - 1)
- StrSql = "CREATE TABLE " & TmpName & " (" & StrSql & ")"
- P_MdbCnn.Execute StrSql
- InsertIntoDB P_MdbCnn, TmpName, TRs
- StrSql = "SELECT * FROM " & TmpName & " ORDER BY " & SortFld
- Set TRs = RsOpen(P_MdbCnn, StrSql)
- Set DbSort = TRs.Clone
- StrSql = "DROP TABLE " & TmpName
- P_MdbCnn.Execute StrSql
- If TRs.State = adStateOpen Then
- TRs.Close
- Set TRs = Nothing
- End If
- If P_MdbCnn.State = adStateOpen Then
- P_MdbCnn.Close
- Set P_MdbCnn = Nothing
- End If
- DbStyle = "SQL"
- Err.Clear
- End Function
- '//将一个RS保存到一个临时的ACCESS数据库...
- Public Function SqlToMdb(Rs As ADODB.Recordset, MdbCnn As ADODB.Connection, Optional TabName As String = "") As String
- Dim StrSql As String
- Dim I As Long
- Dim TmpName As String
- Dim TRs As New ADODB.Recordset
- Err.Clear
- On Error Resume Next
- Set TRs = Rs.Clone
- If MdbCnn.State <> 1 Then MdbCnn.Open
- TabName = Trim$(TabName)
- If Len(TabName) > 0 Then
- TmpName = TabName
- Else
- TmpName = GetTmpName("S")
- TmpName = Right$(TmpName, Len(TmpName) - 1)
- End If
- StrSql = "DROP TABLE " & TmpName
- MdbCnn.Execute StrSql
- With TRs
- StrSql = ""
- For I = 0 To .Fields.Count - 1
- Select Case .Fields(I).Type
- Case Is = 6 '货币 6
- StrSql = StrSql & .Fields(I).Name & " Money NULL,"
- Case Is = 11 'ACCESS 是/否 11
- StrSql = StrSql & .Fields(I).Name & " VARCHAR(" & .Fields(I).DefinedSize & ") NULL,"
- Case Is = 129 'CHAR
- StrSql = StrSql & .Fields(I).Name & " VARCHAR(" & .Fields(I).DefinedSize & ") NULL,"
- Case Is = 130 'NCHAR
- StrSql = StrSql & .Fields(I).Name & " VARCHAR(" & .Fields(I).DefinedSize & ") NULL,"
- Case Is = 202 'NVARCHAR
- StrSql = StrSql & .Fields(I).Name & " VARCHAR(" & .Fields(I).DefinedSize & ") NULL,"
- Case Is = 200 'VARCHAR
- StrSql = StrSql & .Fields(I).Name & " VARCHAR(" & .Fields(I).DefinedSize & ") NULL,"
- Case Is = 3 'INT
- StrSql = StrSql & .Fields(I).Name & " LONG NULL,"
- Case Is = 17 'TINYINT 字节 Access 17
- StrSql = StrSql & .Fields(I).Name & " LONG NULL,"
- Case Is = 2 'SMALLINT
- StrSql = StrSql & .Fields(I).Name & " LONG NULL,"
- Case Is = 20, 72 'BIGINT 同步复制 ID 72
- StrSql = StrSql & .Fields(I).Name & " LONG NULL,"
- Case Is = 201 'TEXT
- StrSql = StrSql & .Fields(I).Name & " Memo NULL,"
- Case Is = 203 'NTEXT
- StrSql = StrSql & .Fields(I).Name & " Memo NULL,"
- Case Is = 131, 4, 5 'NUMERIC|4,5 单精度型 4双精度型 5
- StrSql = StrSql & .Fields(I).Name & " Numeric NULL,"
- Case Is = 135, 7 'DATETIME 日期/时间 7
- StrSql = StrSql & .Fields(I).Name & " DATETIME NULL,"
- Case Is = 205 'IMAGE
- StrSql = StrSql & .Fields(I).Name & " Image NULL,"
- Case Is = 128 'BINARY
- StrSql = StrSql & .Fields(I).Name & " Memo NULL,"
- Case Is = 204 'VARBINARY
- StrSql = StrSql & .Fields(I).Name & " Memo NULL,"
- End Select
- Next
- End With
- StrSql = Left$(StrSql, Len(StrSql) - 1)
- StrSql = "CREATE TABLE " & TmpName & " (" & StrSql & ")"
- MdbCnn.Execute StrSql
- InsertIntoDB MdbCnn, TmpName, TRs
- If TRs.State = adStateOpen Then
- TRs.Close
- Set TRs = Nothing
- End If
- SqlToMdb = TmpName
- Err.Clear
- End Function
- '//将一个RS保存到一个临时的表...
- Public Function RsToTmp(Rs As ADODB.Recordset, P_Cnn As ADODB.Connection, Optional TabName As String = "") As String
- Dim StrSql As String
- Dim I As Long
- Dim TmpName As String
- Dim TRs As New ADODB.Recordset
- Err.Clear
- On Error Resume Next
- If P_Cnn.State <> 1 Then P_Cnn.Open
- Set TRs = Rs.Clone
- TabName = Trim$(TabName)
- If Len(TabName) > 0 Then
- TmpName = TabName
- Else
- TmpName = GetTmpName("S")
- StrSql = "DROP TABLE " & TmpName
- End If
- P_Cnn.Execute StrSql
- With TRs
- StrSql = ""
- For I = 0 To .Fields.Count - 1
- Select Case .Fields(I).Type
- Case Is = 6 '货币 6
- StrSql = StrSql & .Fields(I).Name & " Money NULL,"
- Case Is = 11 'ACCESS 是/否 11
- StrSql = StrSql & .Fields(I).Name & " VARCHAR(" & .Fields(I).DefinedSize & ") NULL,"
- Case Is = 129 'CHAR
- StrSql = StrSql & .Fields(I).Name & " VARCHAR(" & .Fields(I).DefinedSize & ") NULL,"
- Case Is = 130 'NCHAR
- StrSql = StrSql & .Fields(I).Name & " VARCHAR(" & .Fields(I).DefinedSize & ") NULL,"
- Case Is = 202 'NVARCHAR
- StrSql = StrSql & .Fields(I).Name & " VARCHAR(" & .Fields(I).DefinedSize & ") NULL,"
- Case Is = 200 'VARCHAR
- StrSql = StrSql & .Fields(I).Name & " VARCHAR(" & .Fields(I).DefinedSize & ") NULL,"
- Case Is = 3 'INT
- StrSql = StrSql & .Fields(I).Name & " INT NULL,"
- Case Is = 17 'TINYINT 字节 Access 17
- StrSql = StrSql & .Fields(I).Name & " INT NULL,"
- Case Is = 2 'SMALLINT
- StrSql = StrSql & .Fields(I).Name & " INT NULL,"
- Case Is = 20, 72 'BIGINT 同步复制 ID 72
- StrSql = StrSql & .Fields(I).Name & " INT NULL,"
- Case Is = 201 'TEXT
- StrSql = StrSql & .Fields(I).Name & " TEXT NULL,"
- Case Is = 203 'NTEXT
- StrSql = StrSql & .Fields(I).Name & " TEXT NULL,"
- Case Is = 131, 4, 5 'NUMERIC|4,5 单精度型 4双精度型 5
- StrSql = StrSql & .Fields(I).Name & " Numeric NULL,"
- Case Is = 135, 7 'DATETIME 日期/时间 7
- StrSql = StrSql & .Fields(I).Name & " DATETIME NULL,"
- Case Is = 205 'IMAGE
- StrSql = StrSql & .Fields(I).Name & " Image NULL,"
- Case Is = 128 'BINARY
- StrSql = StrSql & .Fields(I).Name & " TEXT NULL,"
- Case Is = 204 'VARBINARY
- StrSql = StrSql & .Fields(I).Name & " TEXT NULL,"
- End Select
- Next
- End With
- StrSql = Left$(StrSql, Len(StrSql) - 1)
- StrSql = "CREATE TABLE " & TmpName & " (" & StrSql & ")"
- P_Cnn.Execute StrSql
- InsertIntoDB P_Cnn, TmpName, TRs
- If TRs.State = adStateOpen Then
- TRs.Close
- Set TRs = Nothing
- End If
- RsToTmp = TmpName
- Err.Clear
- End Function
- '
- '//将DBF导入MDB
- Public Function DBFTOMDB(Rs As ADODB.Recordset, _
- P_Cnn As ADODB.Connection, _
- TabName As String, _
- Optional strlen As Integer = 64)
- Dim FldList As String
- Dim FldValList As String
- Dim FldNameList As String
- Dim StrSql As String
- Dim TRs As New ADODB.Recordset
- Dim I As Long
- On Error Resume Next
- FldList = ""
- Set TRs = Rs.Clone
- For I = 0 To TRs.Fields.Count - 1
- FldList = FldList & TRs.Fields(I).Name & " VARCHAR(" & strlen & ") NULL,"
- Next
- If Len(FldList) > 0 Then
- FldList = Left$(FldList, Len(FldList) - 1)
- StrSql = "CREATE TABLE " & TabName & " (" & FldList & ")"
- P_Cnn.Execute StrSql
- TRs.MovePrevious
- While Not TRs.EOF
- TRs.MoveNext
- If Err.Number <> 0 Then
- Exit Function
- End If
- Wend
- End If
- End Function
VB中对数据库的各种操作.
最新推荐文章于 2020-11-29 12:38:14 发布