frmtreedef.frm

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

If .Is_Init = False Then GoTo Err
TxtUserName = .Tree_User_Name
TxtTreeType = CStr(.Tree_Type)
TxtTreeName = .Tree_Name
TxtRootNodeID = .Node_ID
End With

Call ViewTreeRoot(CInt(TxtTreeType), "")
FrmTreeDef.Show
TabMain.Tab = 0
Call CbxViewList_Change
Err:
End Function

'#########################################################################
'显示目录树根节点信息
'参数：Tree_Type 目录树类型 Tree_Name 返回目录树名称
'返回：Boolean
'#########################################################################
Public Function ViewTreeRoot(pTree_Type As Integer, pTree_Name As String) As Boolean
On Error GoTo Err
Dim tField_Value As String '节点字段在数据库中的值
Dim tRdoRes   '临时结果
Dim tField_Name As String '节点显示的数据库字段名
Dim tTable_Name As String '节点显示的数据库表名
Dim tNodeID As String '节点的ID号
Dim tSystem_Dict_Type As Integer '数据字典类型
Dim tWhere As String '节点的Where字段
Dim tView_List As String '是否显示列表
Dim tStr As String '临时字串
Dim tKey As String '节点的Key
Dim tBool As Boolean '临时变量

gErrDescription = ""

'清屏
TVTreeNode.Nodes.Clear

'取根节点信息
Set gRst = gDbs.OpenRecordset("select * from TREE_DEFINATION where " & _
               "tree_type=" + CStr(pTree_Type) + " and is_root=1")
If gRst.EOF Then GoTo Err

'返回树名
pTree_Name = Trim(gRst.Fields("tree_name"))

'读取节点信息
Set gRst = gDbs.OpenRecordset("select * from TREE_DEFINATION where tree_type=" + CStr(pTree_Type) + " and Parent_Node_ID=" + CStr(Trim(gRst.Fields("node_id"))) + " order by Node_Level_Index")
If gRst.EOF Then GoTo Err

While Not gRst.EOF
      
   '设定节点参数，convert_value用来去除Null值
   tTable_Name = Convert_Value(gRst.Fields("Table_Name"), _
                 0, gRst.Fields("Table_Name").Type, False, False) '表名称
   tNodeID = Convert_Value(ConvertNull(gRst.Fields("Node_ID")), _
                 0, gRst.Fields("Node_ID").Type, False, False) '节点ID号
   tWhere = Convert_Value(gRst.Fields("where_string"), _
                 0, gRst.Fields("where_string").Type, False, False) 'Where子句
   tField_Name = Convert_Value(gRst.Fields("field_en_name"), _
                 0, gRst.Fields("field_en_name").Type, False, False) '字段名
   tSystem_Dict_Type = Convert_Value(gRst.Fields("System_Dict_Type"), _
                 0, gRst.Fields("System_Dict_Type").Type, False, False) '字段对应的数据库字典类型
   tView_List = Convert_Value(gRst.Fields("View_List"), _
                 0, gRst.Fields("View_List").Type, False, False) '显示列表类型
   
   '添加节点
   If gRst.Fields("node_type") = 0 Then '无条件，仅显示
      
      tKey = "N @T " + tTable_Name + " @F @I " + tNodeID + " @O @W" + tWhere + " @V @L " + tView_List
      TVTreeNode.Nodes.Add , , tKey, Trim(gRst.Fields("Field_Cn_Name")), "Main", "Selected"
   
   ElseIf gRst.Fields("node_type") = 1 Then '特殊条件
      
      tStr = "select " + tField_Name + "  from " + tTable_Name
      If tWhere <> "" Then tStr = tStr + " where " + Replace(tWhere, gReplaceChar, "'")
      tStr = tStr + " order by " + tField_Name + " "
      '选取结果集
      Set tRdoRes = gDbs.OpenRecordset(Replace(tStr, gReplaceChar, "'"))
      
      If Not tRdoRes.EOF Then
         tKey = "N@T " + Trim(tTable_Name) + _
                " @F " + Trim(tField_Name) + _
                " @I " + tNodeID + _
                " @O " + tField_Name + _
                " @W " + Replace(tWhere, gReplaceChar, "'") + _
                " @V " + Trim(ConvertNull(gRst.Fields("Field_Value"))) + _
                " @L " + tView_List
         TVTreeNode.Nodes.Add , , tKey, Trim(gRst.Fields("field_cn_name")), "Main", "Selected"
      End If
   
   ElseIf gRst.Fields("node_type") = 2 Then 'group by
      
      tStr = "select distinct " + tField_Name + "  from " + tTable_Name
      If tWhere <> "" Then tStr = tStr + " where " + Replace(tWhere, gReplaceChar, "'") + " "
      tStr = tStr + " order by " + tField_Name + " "
      
      '选取结果集
      Set tRdoRes = gDbs.OpenRecordset(Replace(tStr, gReplaceChar, "'"))
      If Not tRdoRes.EOF Then
         tRdoRes.MoveLast
         tRdoRes.MoveFirst
      End If
      If tRdoRes.RecordCount > gMax_Convert_Rec Then gConvert_To_Dict = False '结果集过大，不转换数据字典
      While Not tRdoRes.EOF
         
         '将显示的字段值转换成在查询语句中等号后的字串
         tField_Value = Convert_Value(tRdoRes.Fields(0), 0, tRdoRes.Fields(0).Type, True, True)
         '添加到节点Key中@W中
         If UCase(tField_Value) = "NULL" Then
            Call AddWhereStr(tWhere, tField_Name + " is NULL ")
         Else
            Call AddWhereStr(tWhere, tField_Name + "=" + tField_Value)
         End If
      
         tKey = "N@T " + Trim(tTable_Name) + _
                " @F " + Trim(tField_Name) + _
                " @I " + tNodeID + _
                " @O " + tField_Name + _
                " @W " + Replace(tWhere, gReplaceChar, "'") + _
                " @V " + Trim(CStr(tRdoRes.Fields(0))) + _
                " @L " + tView_List
         TVTreeNode.Nodes.Add , , tKey, Trim(ConvertFieldValue(gRst.Fields(0), tSystem_Dict_Type, tField_Name, 0)), "Main", "Selected" '?需做数据转换
         tRdoRes.MoveNext
      Wend
      gConvert_To_Dict = True
   End If
   
   gRst.MoveNext

Wend

ViewTreeRoot = True
Exit Function
Err:
   ViewTreeRoot = False
End Function

'#########################################################################
'刷新节点信息
'参数：p_Node要刷新的节点,pExpand_Node是否展开节点
'返回：Boolean
'#########################################################################
Public Function RfshNode(p_Node As Node, pExpand_Node As Boolean) As Boolean
On Error GoTo Err

Dim tRdoRes   '临时结果
Dim tField_Name As String '节点显示的数据库字段名
Dim tTable_Name As String '节点显示的数据库表名
Dim tNodeID As String '节点的ID号
Dim tSystem_Dict_Type As Integer '数据字典类型
Dim tOrder As String '节点的Order字段
Dim tWhere As String '节点的Where字段
Dim tView_List As String '节点显示列表的类型
Dim tStr As String '临时字串
Dim tKey As String '节点的Key
Dim tParent_Where As String '父节点Where字 串
Dim tField_Value As String '节点字段在数据库中的值
Dim tTempStr As String '临时字串

gErrDescription = ""

If p_Node Is Nothing Then GoTo Err

'清除节点下所有子节点
Call ClearNode(p_Node)

'读取父节点信息
If GetValue(tNodeID, "Node_ID", p_Node.key) = False Then GoTo Err
Call GetValue(tParent_Where, "Where", p_Node.key)
   
'读取节点信息
Set gRst = gDbs.OpenRecordset("select * from TREE_DEFINATION where Parent_Node_ID=" + tNodeID + " order by Node_Level_Index ")
If gRst.EOF Then GoTo Err

While Not gRst.EOF
   
   '设定节点参数，convert_value用来去除Null值
   tTable_Name = Convert_Value(gRst.Fields("Table_Name"), _
                 0, gRst.Fields("Table_Name").Type, False, False) '表名称
   tNodeID = Convert_Value(ConvertNull(gRst.Fields("Node_ID")), _
                 0, gRst.Fields("Node_ID").Type, False, False) '节点ID号
   tWhere = Convert_Value(gRst.Fields("where_string"), _
                 0, gRst.Fields("where_string").Type, False, False) 'Where子句
   tField_Name = Convert_Value(gRst.Fields("field_en_name"), _
                 0, gRst.Fields("field_en_name").Type, False, False) '字段名
   tSystem_Dict_Type = Convert_Value(gRst.Fields("System_Dict_Type"), _
                 0, gRst.Fields("System_Dict_Type").Type, False, False) '字段对应的数据库字典类型
   tView_List = Convert_Value(gRst.Fields("View_List"), _
                 0, gRst.Fields("View_List").Type, False, False) '显示列表类型

   '添加子节点
   If gRst.Fields("node_type") = 0 Then '无条件，仅显示
      
      tKey = "N@T " + tTable_Name + "@F @I " + tNodeID + "@O @W " + _
             Replace(tParent_Where, gReplaceChar, "'") + "@V @L " + tView_List
      TVTreeNode.Nodes.Add p_Node.Index, tvwChild, tKey, Trim(gRst.Fields("field_cn_name")), "Main", "Selected"
   
   ElseIf gRst.Fields("node_type") = 1 Then '特殊条件
      
      '设定查询子句
      tStr = "select " + tField_Name + "  from " + tTable_Name
      Call AddWhereStr(tWhere, tParent_Where)
      If tWhere <> "" Then tStr = tStr + " where " + Replace(tWhere, gReplaceChar, "'")
      tStr = tStr + " order by " + tField_Name + " "
      
      '选取结果集
      Set tRdoRes = gDbs.OpenRecordset(Replace(tStr, gReplaceChar, "'"))
      
      If Not tRdoRes.EOF Then
         tKey = "N@T" + Trim(tTable_Name) + _
                " @F " + Trim(tField_Name) + _
                " @I " + tNodeID + _
                " @O " + tField_Name + _
                " @W " + Replace(tWhere, gReplaceChar, "'") + _
                " @V " + Trim(ConvertNull(gRst.Fields("Field_Value"))) + _
                " @L " + tView_List
         TVTreeNode.Nodes.Add p_Node.Index, tvwChild, tKey, Trim(gRst.Fields("field_cn_name")), "Main", "Selected"
      Else
         tKey = "N@T " + Trim(tTable_Name) + _
                " @F " + Trim(tField_Name) + _
                " @I " + tNodeID + _
                " @O " + tField_Name + _
                " @W " + Replace(tWhere, gReplaceChar, "'") + _
                " @V " + " " + _
                " @L " + tView_List

         TVTreeNode.Nodes.Add p_Node.Index, tvwChild, tKey, Trim(gRst.Fields("field_cn_name")), "Main", "Selected" '?需做数据转换
      
      End If
      
   ElseIf gRst.Fields("node_type") = 2 Then 'group by
      
      '设定查询子句
      tStr = "select distinct " + tField_Name + "  from " + tTable_Name
      Call AddWhereStr(tWhere, tParent_Where)
      If tWhere <> "" Then tStr = tStr + " where " + Replace(tWhere, gReplaceChar, "'")
      tStr = tStr + " order by " + tField_Name + " "

      '选取结果集
      Set tRdoRes = gDbs.OpenRecordset(Replace(tStr, gReplaceChar, "'"))
      tTempStr = tWhere
      If Not tRdoRes.EOF Then
         tRdoRes.MoveLast
         tRdoRes.MoveFirst
      End If
      If tRdoRes.RecordCount > gMax_Convert_Rec Then gConvert_To_Dict = False '结果集过大，不转换数据字典
      
      If tRdoRes.EOF Then
         
         tKey = "N@T " + Trim(tTable_Name) + _
                " @F " + Trim(tField_Name) + _
                " @I " + tNodeID + _
                " @O " + tField_Name + _
                " @W " + Replace(tWhere, gReplaceChar, "'") + _
                " @V " + " " + _
                " @L " + tView_List + " " + CStr(TVTreeNode.Nodes.Count + 1)

         TVTreeNode.Nodes.Add p_Node.Index, tvwChild, tKey, Trim(ConvertNull(gRst.Fields("field_cn_name"))), "Main", "Selected" '?需做数据转换
      
      Else
          While Not tRdoRes.EOF
    
             '将显示的字段值转换成在查询语句中等号后的字串
             tField_Value = Convert_Value(tRdoRes.Fields(0), 0, tRdoRes.Fields(0).Type, True, True)
             tWhere = tTempStr
    
             '添加到节点Key中@W中
             If UCase(tField_Value) = "NULL" Then
                Call AddWhereStr(tWhere, tField_Name + " is NULL")
             Else
                Call AddWhereStr(tWhere, tField_Name + "=" + tField_Value)
             End If
             tKey = "N@T " + Trim(tTable_Name) + _
                    " @F " + Trim(tField_Name) + _
                    " @I " + tNodeID + _
                    " @O " + tField_Name + _
                    " @W " + Replace(tWhere, gReplaceChar, "'") + _
                    " @V " + Trim(ConvertNull(tRdoRes.Fields(0))) + _
                    " @L " + tView_List
    
             TVTreeNode.Nodes.Add p_Node.Index, tvwChild, tKey, Trim(ConvertFieldValue(ConvertNull(tRdoRes.Fields(0)), tSystem_Dict_Type, tField_Name, 0)), "Main", "Selected"  '?需做数据转换
             tRdoRes.MoveNext
    
          Wend
      
      End If
      gConvert_To_Dict = True

   End If
   
   gRst.MoveNext

Wend

'展开节点
p_Node.Expanded = pExpand_Node
RfshNode = True
DoEvents
Exit Function
Err:
   RfshNode = False
End Function

Private Sub TVTreeNode_NodeClick(ByVal Node As MSComctlLib.Node)

On Error GoTo Err

Dim tView_List As String '记录目录树节点对应显示列表的类型0无1卷2文件
Dim tNode As Node '临时节点

gErrDescription = ""

Me.MousePointer = vbHourglass '设置鼠标
Set tNode = Node.Child
If tNode Is Nothing Or gRfshNode = True Then '强制刷新节点
    
    Node.Selected = True
    Node.Expanded = False
    Call RfshNode(Node, True)
Else
    Node.Expanded = Not (Node.Expanded)
End If



Me.MousePointer = vbDefault
Exit Sub
Err:
   Me.MousePointer = vbDefault
End Sub

'###################################################################################
'清除子节点 p_Node 为父节点
'###################################################################################
Public Function ClearNode(p_Node As Node) As Boolean
On Error GoTo Err
Dim tNode As Node

gErrDescription = ""

If p_Node Is Nothing Then GoTo Err
Set tNode = p_Node.Child
While Not (tNode Is Nothing)
   TVTreeNode.Nodes.Remove tNode.Index
   Set tNode = p_Node.Child
Wend
ClearNode = True

Exit Function
Err:
   ClearNode = False
End Function


Private Sub TxtTableName_Change()
If TxtTypeCode = "" Then Exit Sub
If InStr(1, LCase(TxtTableName), "volume") <> 0 Then
   TxtTableName = UCase("volume_" + Trim(TxtTypeCode))
ElseIf InStr(1, LCase(TxtTableName), "file") <> 0 Then
   TxtTableName = UCase("file_" + Trim(TxtTypeCode))
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
   TabMain.Tab = 1
   Exit Sub
End If

Set gRst = gDbs.OpenRecordset("select * from " + TxtTableName)
Dim i As Integer
CbxFieldEnName.Clear
For i = 1 To gRst.Fields.Count
   CbxFieldEnName.AddItem gRst.Fields(i - 1).Name
   CbxFieldEnName.ItemData(CbxFieldEnName.ListCount - 1) = gRst.Fields(i - 1).Type
Next i

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

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)
      Dim i As Integer
      CbxFieldEnName.Clear
      For i = 1 To gRst.Fields.Count
          CbxFieldEnName.AddItem gRst.Fields(i - 1).Name
          CbxFieldEnName.ItemData(CbxFieldEnName.ListCount - 1) = gRst.Fields(i - 1).Type
      Next i
   End If
End If

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