frmtree.frm

一个把自己的东西刻成光盘后自动查询和启动的原代码

VERSION 5.00
Begin VB.Form FrmTree 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "目录树定义"
   ClientHeight    =   3945
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   5055
   Icon            =   "FrmTree.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   3945
   ScaleWidth      =   5055
   StartUpPosition =   2  'CenterScreen
   Begin VB.PictureBox Picture1 
      BorderStyle     =   0  'None
      Height          =   615
      Left            =   0
      Picture         =   "FrmTree.frx":030A
      ScaleHeight     =   615
      ScaleWidth      =   5295
      TabIndex        =   22
      Top             =   0
      Width           =   5295
      Begin VB.Timer Timer1 
         Interval        =   50
         Left            =   0
         Top             =   0
      End
   End
   Begin VB.PictureBox Picture2 
      BorderStyle     =   0  'None
      Height          =   135
      Left            =   0
      Picture         =   "FrmTree.frx":A6AC
      ScaleHeight     =   135
      ScaleWidth      =   5295
      TabIndex        =   20
      Top             =   600
      Width           =   5295
      Begin VB.PictureBox Picture3 
         BorderStyle     =   0  'None
         Height          =   135
         Left            =   0
         Picture         =   "FrmTree.frx":BF12
         ScaleHeight     =   135
         ScaleWidth      =   5055
         TabIndex        =   21
         Top             =   0
         Width           =   5055
      End
   End
   Begin VB.Frame Frame2 
      Caption         =   "目录树信息"
      Height          =   1575
      Left            =   120
      TabIndex        =   13
      Top             =   750
      Width           =   2415
      Begin VB.TextBox TxtTableName 
         Height          =   360
         Left            =   960
         TabIndex        =   17
         Top             =   1050
         Width           =   1335
      End
      Begin VB.TextBox TxtTypeCode 
         Height          =   360
         Left            =   960
         TabIndex        =   16
         Top             =   652
         Width           =   1335
      End
      Begin VB.TextBox TxtTreeName 
         Height          =   375
         Left            =   960
         TabIndex        =   14
         Top             =   240
         Width           =   1335
      End
      Begin VB.Label Label5 
         Caption         =   "表    名"
         Height          =   255
         Left            =   120
         TabIndex        =   19
         Top             =   1160
         Width           =   975
      End
      Begin VB.Label Label8 
         Caption         =   "档案类型"
         Height          =   255
         Left            =   120
         TabIndex        =   18
         Top             =   760
         Width           =   975
      End
      Begin VB.Label Label7 
         Caption         =   "树名称"
         Height          =   255
         Left            =   120
         TabIndex        =   15
         Top             =   360
         Width           =   975
      End
   End
   Begin VB.TextBox TxtTreeType 
      Height          =   285
      Left            =   3960
      TabIndex        =   9
      Top             =   600
      Visible         =   0   'False
      Width           =   975
   End
   Begin VB.Frame Frame1 
      Height          =   135
      Left            =   0
      TabIndex        =   8
      Top             =   3240
      Width           =   5535
   End
   Begin VB.CommandButton CmdCancel 
      Caption         =   "返回(&R)"
      Height          =   375
      Left            =   3840
      TabIndex        =   7
      Top             =   3480
      Width           =   1095
   End
   Begin VB.CommandButton CmdDelete 
      Caption         =   "删除(&D)"
      Height          =   375
      Left            =   2600
      TabIndex        =   6
      Top             =   3480
      Width           =   1095
   End
   Begin VB.CommandButton CmdModify 
      Caption         =   "修改(&M)"
      Height          =   375
      Left            =   1360
      TabIndex        =   5
      Top             =   3480
      Width           =   1095
   End
   Begin VB.CommandButton CmdInsert 
      Caption         =   "增加(&I)"
      Height          =   375
      Left            =   120
      TabIndex        =   4
      Top             =   3480
      Width           =   1095
   End
   Begin VB.ListBox ListTreeType 
      Height          =   2400
      Left            =   2640
      TabIndex        =   3
      Top             =   840
      Width           =   2295
   End
   Begin VB.Frame Frame3 
      Caption         =   "使用者"
      Height          =   855
      Left            =   120
      TabIndex        =   0
      Top             =   2400
      Width           =   2415
      Begin VB.TextBox TxtUserName 
         Height          =   285
         Left            =   240
         TabIndex        =   10
         Top             =   500
         Width           =   1935
      End
      Begin VB.TextBox Text1 
         Height          =   375
         Left            =   1440
         TabIndex        =   1
         Text            =   "Text1"
         Top             =   2040
         Width           =   1215
      End
      Begin VB.OptionButton Opt 
         Caption         =   "自定义"
         Height          =   375
         Index           =   1
         Left            =   1080
         TabIndex        =   11
         Top             =   180
         Width           =   975
      End
      Begin VB.OptionButton Opt 
         Caption         =   "公用"
         Height          =   375
         Index           =   0
         Left            =   240
         TabIndex        =   12
         Top             =   180
         Value           =   -1  'True
         Width           =   975
      End
      Begin VB.Label Label1 
         Caption         =   "目录树类型"
         Height          =   375
         Left            =   360
         TabIndex        =   2
         Top             =   2160
         Width           =   1095
      End
   End
End
Attribute VB_Name = "FrmTree"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit '错误代码从2901开始编制
Public gChanged As Boolean '是否改动过

Private Sub CmdCancel_Click()
Unload Me
End Sub

Private Sub CmdDelete_Click()
On Error GoTo Err
Dim i As Integer

gErrDescription = ""

If IsNumeric(TxtTreeType) = False Then GoTo Err
Set gRst = gDbs.OpenRecordset("select * from TREE_DEFINATION where tree_type=" + CStr(CInt(TxtTreeType)))
If Not gRst.EOF Then
   gRst.MoveLast
   gRst.MoveFirst
End If
If gRst.RecordCount >= 1 Then
   If MsgBox("您真的要删除" + gRst.Fields("tree_name") + "目录树?", vbYesNo, XTTS) = vbYes Then
      gDbs.Execute "delete from list_defination where node_id in (select node_id from TREE_DEFINATION where tree_type=" + CStr(CInt(TxtTreeType)) + ")"
      gDbs.Execute "delete from TREE_DEFINATION where tree_type=" + CStr(CInt(TxtTreeType))
      For i = 0 To ListTreeType.ListCount - 1
         If ListTreeType.ItemData(i) = CInt(TxtTreeType) Then
            ListTreeType.RemoveItem (i)
            Exit For
         End If
      Next i
      MsgBox "删除成功！", vbExclamation, XTTS
      Call FrmClear
   Else
      Exit Sub
   End If
End If
Exit Sub
Err:
   
End Sub

'###################################################################################
'窗体初始化 pNodeID
'###################################################################################
Public Sub FrmInit()
On Error GoTo Err
gErrDescription = ""

gChanged = False
Set gRst = gDbs.OpenRecordset("select tree_type,tree_name from TREE_DEFINATION where is_root=1 order by tree_type")
While Not gRst.EOF
   ListTreeType.AddItem gRst.Fields("tree_name")
   ListTreeType.ItemData(ListTreeType.ListCount - 1) = gRst.Fields("tree_type")
   gRst.MoveNext
Wend
FrmTree.Show
Err:
End Sub

Private Sub CmdInsert_Click()
On Error GoTo Err

Dim tUserName As String
Dim tTreeType As String
Dim tNodeID As String

gErrDescription = ""

If TxtTreeName = "" Then
   MsgBox "目录树名称不能为空，请重新输入", vbExclamation, XTTS
   TxtTreeName.SetFocus
   Exit Sub
End If
If TxtUserName = "" Or Opt(0).Value = True Then
   tUserName = "null"
Else
   tUserName = "'" + TxtUserName + "'"
End If

Set gRst = gDbs.OpenRecordset("select distinct tree_type from TREE_DEFINATION order by tree_type desc")
If gRst.EOF Then
   tTreeType = "1"
Else
   tTreeType = ConvertNull(gRst.Fields("tree_type") + 1)
End If

Set gRst = gDbs.OpenRecordset("select * from TREE_DEFINATION where tree_name='" + TxtTreeName + "'")
If Not gRst.EOF Then
   MsgBox "您输入的目录树名称已经存在，请重新输入", vbExclamation, XTTS
   TxtTreeName.SetFocus
   Exit Sub
End If

Set gRst = gDbs.OpenRecordset("select max(node_id) as a from TREE_DEFINATION ")
If gRst.EOF Then
   tNodeID = "1"
Else
   tNodeID = CStr(gRst.Fields("a") + 1)
End If

gDbs.Execute "insert into tree_defination (node_id,tree_type,tree_name,tree_user_name,parent_node_id,node_level_index,is_root,table_name,type_code) values(" & _
                                               tNodeID + "," + tTreeType + ",'" + TxtTreeName + "'," + tUserName + ",0,1,1,'" + TxtTableName + "','" + TxtTypeCode + "')"
                                                
Set gRst = gDbs.OpenRecordset("select * from TREE_DEFINATION where tree_name='" + TxtTreeName + "' and is_root=1")
Call Clear_Tree_Node(g_Parent_Tree_Node)
With g_Parent_Tree_Node
  .Tree_Name = TxtTreeName
  .Tree_Type = CInt(tTreeType)
  .Tree_User_Name = TxtUserName
  .Node_ID = ConvertNull(gRst.Fields("node_id"))
  .Is_Init = True
End With

Call SaveEventLog("6099", 0, "", "", "增加目录树:" + TxtTreeName)

Unload Me
Call FrmTreeDef.FrmInit
                                               
Exit Sub
Err:
End Sub

Private Sub CmdModify_Click()
On Error GoTo Err

gErrDescription = ""

If IsNumeric(TxtTreeType) = False Then GoTo Err
Set gRst = gDbs.OpenRecordset("select * from TREE_DEFINATION where tree_type=" + CStr(CInt(TxtTreeType)))
If gRst.EOF Then GoTo Err

If gChanged = False Then '未修改过
   
Else '修改过
    
    If Opt(0).Value = True Then '无使用者
       gDbs.Execute "update tree_defination set tree_name='" + TxtTreeName.Text + "',tree_user_name=null where tree_type=" + TxtTreeType
    Else '有使用者
       If TxtUserName = "" Then
          MsgBox "目录树使用者不能为空，请重新输入", vbExclamation, XTTS
          TxtUserName.SetFocus
          Exit Sub
       End If
       gDbs.Execute "update tree_defination set tree_name='" + TxtTreeName.Text + "',tree_user_name='" + TxtUserName + "' where tree_type=" + TxtTreeType
       Call SaveEventLog("6099", 0, "", "", "修改目录树:" + TxtTreeName + "用户" + TxtUserName)
       
    End If
    If MsgBox("目录树类型修改成功，是否继续", vbQuestion + vbYesNo, XTTS) = vbNo Then
       Unload Me
    End If
End If
Set gRst = gDbs.OpenRecordset("select * from TREE_DEFINATION where tree_type=" + CStr(CInt(TxtTreeType)) + " and is_root=1")
Call Clear_Tree_Node(g_Parent_Tree_Node)
With g_Parent_Tree_Node
  .Tree_Name = gRst.Fields("tree_name")
  .Tree_Type = gRst.Fields("tree_type")
  .Tree_User_Name = ConvertNull(gRst.Fields("tree_user_name"))
  .Node_ID = ConvertNull(gRst.Fields("node_id"))
  .Is_Init = True
End With
Unload Me
Call FrmTreeDef.FrmInit
Err:
End Sub

Private Sub ListTreeType_Click()
Set gRst = gDbs.OpenRecordset("select * from TREE_DEFINATION where is_root=1 and tree_name='" + ListTreeType.List(ListTreeType.ListIndex) + "' and tree_type=" + CStr(ListTreeType.ItemData(ListTreeType.ListIndex)))
If gRst.EOF Then Exit Sub
TxtTreeName = gRst.Fields("tree_name")
TxtTreeType = ConvertNull(gRst.Fields("tree_type"))
TxtTableName = ConvertNull(gRst.Fields("table_name"))
TxtTypeCode = ConvertNull(gRst.Fields("type_code"))

If IsNull(gRst.Fields("tree_user_name")) Then
   TxtUserName = ""
Else
   TxtUserName = gRst.Fields("tree_user_name")
End If
If TxtUserName <> "" Then
   Opt(1).Value = True
Else
   Opt(0).Value = True
End If
gChanged = False
End Sub

Private Sub Opt_Click(Index As Integer)
If Opt(0).Value = True Then
   TxtUserName = ""
   TxtUserName.Enabled = False
Else
   TxtUserName.Enabled = True
End If
End Sub

Private Sub Opt_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
gChanged = True
End Sub

Private Sub Timer1_Timer()
   Picture3.Left = Picture3.Left + 50
   If Picture3.Left > Picture2.Left + Picture2.Width Then
      Picture3.Left = Picture2.Left - Picture3.Width
   End If
End Sub

Private Sub TxtTableName_LostFocus()
On Error GoTo Err
Dim tTypeCode As String

gErrDescription = ""

If InStr(1, UCase(TxtTableName), "FILE") <> 0 Then
   If InStr(1, TxtTableName, "_") <> 0 Then
      TxtTypeCode = UCase(Mid(TxtTableName, InStr(1, TxtTableName, "_") + 1))
   End If
ElseIf InStr(1, UCase(TxtTableName), "VOLUME") <> 0 Then
   If InStr(1, TxtTableName, "_") <> 0 Then
      TxtTypeCode = UCase(Mid(TxtTableName, InStr(1, TxtTableName, "_") + 1))
   End If
ElseIf TxtTableName <> "" Then
   MsgBox "您输入的表不是文件或案卷表，请重新输入", vbExclamation, XTTS
   TxtTableName.SetFocus
   Exit Sub

End If

Set gRst = gDbs.OpenRecordset("select * from " + TxtTableName)

Exit Sub
Err:
   MsgBox "您输入的表名不存在，请重新输入", vbExclamation, XTTS
   TxtTableName.SetFocus
End Sub

Private Sub TxtTreeName_Change()
gChanged = True
End Sub

Private Sub TxtTypeCode_LostFocus()
On Error GoTo Err

gErrDescription = ""

If TxtTypeCode <> "" Then
   
   If LCase(TxtTableName.Text) = "volume" Or LCase(TxtTableName.Text) = "file" Then
      TxtTableName = UCase(TxtTableName + "_" + TxtTypeCode)
      Set gRst = gDbs.OpenRecordset("select * from " + TxtTableName)
   End If
End If

Exit Sub
Err:
   MsgBox "您输入的档案类型不存在，请重新输入", vbExclamation, XTTS
   TxtTypeCode.SetFocus
End Sub

Private Sub TxtUserName_Change()
gChanged = True
End Sub

'###################################################################################
'清除界面
'###################################################################################
Public Sub FrmClear()
TxtTreeName = ""
TxtTypeCode = ""
TxtTableName = ""
Opt(0).Value = True
TxtUserName = ""
TxtTreeType = ""
End Sub