获得对象名，并将其写入数据表中

时　间:2015-01-13 17:22:53
作　者:月皓星隐   ID：39720  城市：自贡
摘　要:本程序是用来得到对象的名称，并且写入数据表中，本表生成的是系统隐藏表，因为生成的这些名称通常为控制权限所用，如果想直接显示，请把表前的usys去掉即可！
正　文:

点击下载此示例

获得对象名，并将其写入数据表中，在权限分配的时候可能用得着！其实可以用查询来做，几句简单代码就搞定了，这里提供的是另一种思路

Option Compare Database

Option Explicit
Public Const 表 = 1
Public Const 窗 = 2
Public Const 报表 = 3
Public Const 查询 = 4
'************************************************************************
'程序功能：本程序是用来得到对象的名称，并且写入数据表中
'
'程序名称：获得对象
'
'程序参数：输入对象类型（表，窗，查询，报表）后就可以了
'
'使用范围：适合所有access
'
'使用范例：直接在程序中调用即可，比如：‘ 获得对象名 1’ 等效于‘ 获得对象名 表’
'
'程序作者：月皓星隐
'
'编外的话：为了能看得直观，所以变量用中文的，不适合其他程序专用，得经过改写，如果需要的可以自己改写下变量即可
'
'注    意：本表生成的是系统隐藏表，因为生成的这些名称通常为控制权限所用，如果想直接显示，请把表前的usys去掉即可
'           比如 "usys表名称" 改名为  "表名称"就可以了
'编写时间：2015-1-5
'***********************************************************************
 
Function 获得对象名(ByVal 对象类型 As Integer) As String
On Error GoTo 结束
Dim i As Integer, bb As String
Dim rr As Object
Dim objName As String
Dim 存在 As Boolean
Dim ind As DAO.Index
Dim tb As DAO.TableDef
Dim rs As New ADODB.Recordset
Dim x As Integer
Dim Y As Integer
Dim TbName As String
Dim Db As DAO.Database
Set Db = CurrentDb
Select Case 对象类型
    Case 表: Set rr = CurrentDb.TableDefs: objName = "usys表名称"
        Y = CurrentDb.TableDefs.Count
    Case 窗: Y = CurrentDb.Containers("forms").Documents.Count: objName = "usys窗体名称"
        
    Case 报表: Y = CurrentDb.Containers("reports").Documents.Count: objName = "usys报表名称"
        
    Case 查询: Set rr = CurrentDb.QueryDefs: objName = "usys查询名称"
        Y = CurrentDb.QueryDefs.Count
    Case Else: MsgBox "错误的类型": Exit Function
End Select
TbName = Right(objName, Len(objName) - 4)
'先判断表是否存在
If Y < 1 Then Exit Function


For i = 0 To CurrentDb.TableDefs.Count - 1
    If objName = Db.TableDefs(i).Name Then GoTo 100
Next
'不存在就新建一个表，这里我用vb代码直接做而没有用sql代码
Set tb = Db.CreateTableDef(objName)
Set ind = tb.CreateIndex("主键")
tb.Fields.Append tb.CreateField("ID", dbText, 6)
tb.Fields.Append tb.CreateField(TbName, dbText, 50)
tb.Fields.Append tb.CreateField("备注", dbText, 10)


Db.TableDefs.Append tb
ind.Fields.Append ind.CreateField("Id")


'Set tb = CurrentDb.TableDefs(objName)
'创建表过后就添加索引和主键
'Set ind = tb.CreateIndex("主键")
'为索引设置主键字段
'ind.Fields.Append ind.CreateField("Id")
'设置索引的 primary 属性为 true
ind.Primary = True
'将新建的索引添加到索引对象集合中去
tb.Indexes.Append ind


100:


'打开记录集
rs.Open objName, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
''是空集就退出
'If rs.RecordCount < 1 Then Exit Function
x = rs.RecordCount
If Y < 1 Then Exit Function
For i = 0 To Y - 1
   If 对象类型 = 2 Then
      bb = Db.Containers("forms").Documents(i).Name
      '排除子窗体
      If Right(bb, 3) = "子窗体" Then GoTo 200
      rs.Filter = "[" & TbName & "]='" & bb & "'"
        ''如果出现新窗体就增加，没有出现则不管他
        If rs.EOF Then
             rs.AddNew
             rs!Id = 编号("OBF", x, 3)
    '         MsgBox 编号("OBJ", x, 3)
             rs(TbName) = Db.Containers("forms").Documents(i).Name
             rs.Update
             x = x + 1
        End If
        rs.Filter = ""
   ElseIf 对象类型 = 3 Then
      bb = Db.Containers("reports").Documents(i).Name
      rs.Filter = "[" & TbName & "]='" & bb & "'"
        ''如果出现新窗体就增加，没有出现则不管他
        If rs.EOF Then
             rs.AddNew
             rs!Id = 编号("OBR", x, 3)
    '         MsgBox 编号("OBJ", x, 3)
             rs(TbName) = Db.Containers("reports").Documents(i).Name
             rs.Update
             x = x + 1
        End If
        rs.Filter = ""
   ElseIf 对象类型 = 1 Then
   
        bb = rr(i).Name
        '如果没有这句，系统表都写进去了
        If Left(bb, 4) = "~TMP" or Left(bb, 4) = "MSys" Then GoTo 200
    '    MsgBox "对象名称为：" & bb & "，i 的值为：" & i
        rs.Filter = "[" & TbName & "]='" & bb & "'"
        ''如果出现新窗体就增加，没有出现则不管他
        If rs.EOF Then
             rs.AddNew
             rs!Id = 编号("OBT", x, 3)
    '         MsgBox 编号("OBJ", x, 3)
             rs(TbName) = rr(i).Name
             rs.Update
             x = x + 1
        End If
        rs.Filter = ""
   Else
   
        bb = rr(i).Name
        '如果没有这句不知道把那啥米查询都弄出来了
        If Left(bb, 4) = "~sq_" Then GoTo 200
    '    MsgBox "对象名称为：" & bb & "，i 的值为：" & i
        rs.Filter = "[" & TbName & "]='" & bb & "'"
        ''如果出现新窗体就增加，没有出现则不管他
        If rs.EOF Then
             rs.AddNew
             rs!Id = 编号("OBQ", x, 3)
    '         MsgBox 编号("OBJ", x, 3)
             rs(TbName) = rr(i).Name
             rs.Update
             x = x + 1
        End If
        rs.Filter = ""
    End If
200:
Next
 
' MsgBox "建立完毕！！" & vbCrLf & "本次更新了" & rs.RecordCount - x & "条数据！谢谢使用！！"
'这样表也建立了，也得到了窗体名称
结束:
Resume Next
Set tb = Nothing
Set rr = Nothing
Set rs = Nothing
Set ind = Nothing
Set Db = Nothing
End Function

 
Public Function 编号(编号头 As String, 记录数 As Integer, 流水号位数 As Integer)
Dim 流水号, 循环i, 格式 As String
    If 记录数 < 1 Then
        流水号 = 1
    Else
       流水号 = 记录数 + 1
    End If
    
For 循环i = 1 To 流水号位数
 格式 = 格式 & "0"
Next 循环i


 编号 = 编号头 & Format(流水号, 格式) '按格式新建编号（n位流水号）
End Function
 

Access软件网官方交流QQ群 (群号:54525238) 　　　　　　Access源码网店