frmmain.frm

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

   LVVolume.Move 0, 0, PicLV.Width, PicLV.Height * gHeightRate
   HImgDrag.Move 0, LVVolume.Height, LVVolume.Width, gBorderWidth
   LVFile.Move 0, HImgDrag.Top + gBorderWidth, LVVolume.Width, PicLV.Height - LVVolume.Height - gBorderWidth
   HImgDrag.Visible = True
Else
   LVVolume.Move 0, 0, PicLV.Width, PicLV.Height
   HImgDrag.Visible = False
End If

End Sub

'调整PicMain中控件大小与位置
Private Sub PicMain_Resize()
Call SetTVMain(0, 0, False, 0)
End Sub

'水平分割线
Private Sub HImgDrag_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    
    With HImgDrag
        HPicDrag.Move .Left, .Top, .Width, .Height
    End With
    HPicDrag.Visible = True
    HDragFlag = True

End Sub

Private Sub HImgDrag_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim sglPos As Single

If HDragFlag Then
    sglPos = Y + HImgDrag.Top
    If sglPos < sglSplitLimit Then
        HPicDrag.Top = sglSplitLimit
    ElseIf sglPos > Me.Width - sglSplitLimit Then
        HPicDrag.Top = Me.Width - sglSplitLimit
    Else
        HPicDrag.Top = sglPos
    End If
End If

End Sub

Private Sub HImgDrag_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

HImgDrag.Move HPicDrag.Left, HPicDrag.Top, HPicDrag.Width, HPicDrag.Height
HPicDrag.Visible = False
HDragFlag = False
gHeightRate = HPicDrag.Top / PicLV.Height
Call PicLV_Resize

End Sub

Private Sub Tbar_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case LCase(Button.key) '
   Case "btnfile"
      gObjectType = 0
   Case "btnvolume"
      gObjectType = 1
   Case "btnexplore"
      If gObjectType = 0 Then
         Call m_File_Do_Click(0)
      ElseIf gObjectType = 1 Then
         Call m_Volume_Do_Click(0)
      End If
   Case "btnmodify"
      If gObjectType = 0 Then
         Call m_File_Do_Click(1)
      ElseIf gObjectType = 1 Then
         Call m_Volume_Do_Click(1)
      End If
   Case "btndelete"
      If gObjectType = 0 Then
         Call m_File_Do_Click(2)
      ElseIf gObjectType = 1 Then
         Call m_Volume_Do_Click(2)
      End If
   Case "btntran"
      If gObjectType = 0 Then
         Call m_File_Do_Click(9)
      ElseIf gObjectType = 1 Then
         Call m_Volume_Do_Click(9)
      End If
   Case "btndestruct"
      If gObjectType = 0 Then
         Call m_File_Do_Click(10)
      ElseIf gObjectType = 1 Then
         Call m_Volume_Do_Click(10)
      End If
   Case "btnfind"
      FrmFind.Show
   Case "btnuser"
   Case "btnhelp"
      FrmAboutMe.Show 1
   Case "btnexit"
      Unload Me
End Select
End Sub

Private Sub TVMain_DblClick()
On Error GoTo Err

Dim tView_List As String '记录目录树节点对应显示列表的类型0无1卷2文件
Dim tNode As Node
Set tNode = TVMain.SelectedItem
If tNode Is Nothing Then Exit Sub

TVMain.Enabled = False

gErrDescription = ""

LVVolume.ListItems.Clear
LVFile.ListItems.Clear

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

If GetValue(tView_List, "View_List", tNode.key) = True Then
   
   If tView_List = "1" Then '显示卷列表 对应tree_defination
      Call List_View_Volume(tNode, LVVolume)
   ElseIf tView_List = "2" Then '显示文件列表
      Call List_View_File(Nothing, LVFile, tNode, SBar.Panels(2), SBar.Panels(4))
   ElseIf tView_List = "3" Then '显示盒列表
      Call List_View_Volume(tNode, LVVolume)
   Else '清除列表
      Call ClearList
   End If

End If
'Debug.Print Node.key
Me.MousePointer = vbDefault

TVMain.Enabled = True

Exit Sub
Err:
   Me.MousePointer = vbDefault
   TVMain.Enabled = True
End Sub

Private Sub TVMain_NodeClick(ByVal Node As MSComctlLib.Node)
On Error GoTo Err

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

TVMain.Enabled = False

gErrDescription = ""

LVVolume.ListItems.Clear
LVFile.ListItems.Clear
DoEvents

Me.MousePointer = vbHourglass '设置鼠标
'If Node.Child Is Nothing Then gRfshNode = True

If gRfshNode = True Or Node.Child Is Nothing Then '强制刷新节点 'tNode Is Nothing Or
    Node.Selected = True
    Call RfshNode(Node, True)
    Node.Expanded = True
Else
    Node.Expanded = Not (Node.Expanded)
End If

'If GetValue(tView_List, "View_List", Node.key) = True And gRfshNode = True Then
'
'   If tView_List = "1" Then '显示卷列表 对应tree_defination
'      Call List_View_Volume(Node, LVVolume)
'   ElseIf tView_List = "2" Then '显示文件列表
'      Call List_View_File(Nothing, LVFile, Node, SBar.Panels(2), SBar.Panels(4))
'   ElseIf tView_List = "3" Then '显示盒列表
'      Call List_View_Volume(Node, LVVolume)
'   Else '清除列表
'      Call ClearList
'   End If
'
'End If
'Debug.Print Node.key

Me.MousePointer = vbDefault
TVMain.Enabled = True
gRfshNode = False
Exit Sub
Err:
   Me.MousePointer = vbDefault
   TVMain.Enabled = True
   gRfshNode = False
End Sub

'垂直分割线
Private Sub VImgDrag_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    
    With VImgDrag
        VPicDrag.Move .Left, .Top, .Width, .Height
    End With
    VPicDrag.Visible = True
    VDragFlag = True

End Sub

Private Sub VImgDrag_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim sglPos As Single

If VDragFlag Then
    sglPos = X + VImgDrag.Left
    
    If sglPos < sglSplitLimit Then
        VPicDrag.Left = sglSplitLimit
    ElseIf sglPos > Me.Width - sglSplitLimit Then
        VPicDrag.Left = Me.Width - sglSplitLimit
    Else
        VPicDrag.Left = sglPos
    End If

End If

End Sub

Private Sub VImgDrag_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

VImgDrag.Move VPicDrag.Left, VPicDrag.Top, VPicDrag.Width, VPicDrag.Height
VPicDrag.Visible = False
VDragFlag = False
gWidthRate = VPicDrag.Left / Me.ScaleWidth
Call Form_Resize

End Sub

'#########################################################################
'显示目录树根节点信息
'参数：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 tRst '临时结果
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 '临时变量

'清屏
Call ClearAll

'取根节点信息
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
      TVMain.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 tRst = gDbs.OpenRecordset(Replace(tStr, gReplaceChar, "'"))
      
      If Not tRst.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
         TVMain.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 tRst = gDbs.OpenRecordset(Replace(tStr, gReplaceChar, "'"))
      If Not tRst.EOF Then
         tRst.MoveLast
         tRst.MoveFirst
      End If
      If tRst.RecordCount > gMax_Convert_Rec Then gConvert_To_Dict = False '结果集过大，不转换数据字典
      While Not tRst.EOF
         
         '将显示的字段值转换成在查询语句中等号后的字串
         tField_Value = Convert_Value(tRst(0), 0, tRst(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(tRst.Fields(0))) + _
                " @L " + tView_List
         TVMain.Nodes.Add , , tKey, ConvertFieldValue(gRst.Fields(0), tSystem_Dict_Type, tField_Name, 0), "Main", "Selected" '?需做数据转换
         tRst.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 tRst '临时结果
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 '临时字串

If p_Node Is Nothing Then GoTo Err

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

'读取父节点信息
If GetValue(tNodeID, "Node_ID", p_Node.key) = False Then GoTo Err