form1.frm

二叉树的遍历、线索化、遍历线索化二叉树等算法；深度搜索优先、广度搜索优先算法

        Text3(txtNum).SetFocus
    End If
End Sub
Sub LoadArc(ByVal sID As String)
sSql = "select * from arctable where PID=" + sID
RS.Open sSql, cn, adOpenKeyset, adLockPessimistic
n = rsLen(RS)
ReDim MyArc(n)
iArcNum = n
For i = 1 To n
    MyArc(i).iStartNode = RS("sNode").Value
    MyArc(i).iEndNode = RS("eNode").Value
    MyArc(i).iLink = RS("iLink").Value
    RS.MoveNext
Next i
RS.Close
RefreshArc
End Sub
Sub LoadVert(ByVal sID As String)
sSql = "select * from Vertex where PID=" + sID
RS.Open sSql, cn, adOpenKeyset, adLockPessimistic
n = rsLen(RS)
If n = 0 Then
    RS.Close
    Exit Sub
End If
ReDim MyVer(n)

For i = 1 To iVertexNum
    Unload Text3(i)
Next i
iVertexNum = n
For i = 1 To n
    MyVer(i).sVerName = RS("sName").Value
    MyVer(i).vID = RS("vID").Value
    MyVer(i).fPosX = RS("PosX").Value
    MyVer(i).fPosY = RS("Posy").Value
    RS.MoveNext
Next i
RS.Close
RefreshVert
End Sub
Sub LoadAndDraw()
Dim sID As String
P2.Cls
If iProjectType = 0 Then
    sSql = "select * from Project where PID=" + sCurNode + " and iFlag=1"
    RS.Open sSql, cn, adOpenKeyset, adLockPessimistic
    n = rsLen(RS)
    If n = 0 Then
        RS.Close
        Exit Sub
    End If
    sID = Str(RS("ID").Value)
    RS.Close
    LoadVert sID
    
    sSql = "select * from Project where PID=" + sCurNode + " and iFlag=2"
    RS.Open sSql, cn, adOpenKeyset, adLockPessimistic
    n = rsLen(RS)
    If n = 0 Then
        RS.Close
        Exit Sub
    End If
    sID = Str(RS("ID").Value)
    RS.Close
    LoadArc sID
End If
If iProjectType = 1 Then LoadVert sCurNode
If iProjectType = 2 Then LoadArc sCurNode
End Sub
Sub SaveAllData()
Dim sPID As String
If iProjectType <> 0 Then
    i = MsgBox("这个项目类型下，不允许保存顶点数据", vbOKOnly + vbInformation, "警告")
    Exit Sub
End If
sqls = "select * from Project where PID=" + sCurNode + " and iFlag=1"
RS.Open sqls, cn, adOpenKeyset, adLockPessimistic
n = rsLen(RS)
If n = 0 Or n > 1 Then
    RS.Close
    i = MsgBox("这个项目下没有顶点数据集，无法保存！", vbOKOnly + vbInformation, "警告")
    Exit Sub
End If
sPID = RS("ID").Value
RS.Close

sqls = "delete from Vertex where PID=" + sPID
cn.Execute sqls
For i = 1 To iVertexNum
    If MyVer(i).iFlag >= 0 Then
        sqls = "insert into Vertex (PID,vID,sName,PosX,PosY) values (" + sPID + "," + Str(MyVer(i).vID) + ",'" + MyVer(i).sVerName + "'," + Str(MyVer(i).fPosX) + "," + Str(MyVer(i).fPosY) + ")"
        cn.Execute sqls
    End If
Next i


sqls = "select * from Project where PID=" + sCurNode + " and iFlag=2"
RS.Open sqls, cn, adOpenKeyset, adLockPessimistic
n = rsLen(RS)
If n = 0 Or n > 1 Then
    RS.Close
    i = MsgBox("这个项目下没有弧数据集，无法保存！", vbOKOnly + vbInformation, "警告")
    Exit Sub
End If
sPID = RS("ID").Value
RS.Close

sqls = "delete from ArcTable where PID=" + sPID
cn.Execute sqls
For i = 1 To iArcNum
    If MyArc(i).iLink >= 0 Then
        sqls = "insert into ArcTable (PID,sNode,eNode,iLink) values (" + sPID + "," + Str(MyArc(i).iStartNode) + "," + Str(MyArc(i).iEndNode) + "," + Str(MyArc(i).iLink) + ")"
        cn.Execute sqls
    End If
Next i
End Sub
Sub RefreshVert()
Dim iFlag As Integer
Dim Txt As TextBox
P2.Cls
For i = 1 To iVertexNum
    x0 = MyVer(i).fPosX
    y0 = MyVer(i).fPosY
    iFlag = MyVer(i).iFlag
    Load Text3(i)
    Text3(i).Visible = False
    If iFlag >= 0 Then
        P2.Circle (x0, y0), R, &H0
        Text3(i).Top = y0 - R
        Text3(i).Left = x0 + R
        Text3(i).Visible = True
        Text3(i).Text = MyVer(i).sVerName
        Text3(i).Visible = True
    End If
Next i
End Sub
Sub RefreshArc()
For i = 1 To iArcNum
   n = MyArc(i).iStartNode
   If MyArc(i).iLink >= 0 Then
        x0 = MyVer(n).fPosX
        y0 = MyVer(n).fPosY
        m = MyArc(i).iEndNode
        X1 = MyVer(m).fPosX
        Y1 = MyVer(m).fPosY
        P2.Line (x0, y0)-(X1, Y1), &H0
    End If
    If MyArc(i).iLink < 0 Then
        x0 = MyVer(n).fPosX
        y0 = MyVer(n).fPosY
        m = MyArc(i).iEndNode
        X1 = MyVer(m).fPosX
        Y1 = MyVer(m).fPosY
        P2.Line (x0, y0)-(X1, Y1), P2.BackColor
    End If
Next i
End Sub
Function SelArc(ByVal X As Single, ByVal Y As Single) As Integer
Dim a As Single
Dim b As Single
Dim c As Single
Dim S As Single
Dim D As Single
Dim Area As Single

SelArc = -1
For i = 1 To iArcNum
    n = MyArc(i).iStartNode
    x0 = MyVer(n).fPosX
    y0 = MyVer(n).fPosY
    m = MyArc(i).iEndNode
    X1 = MyVer(m).fPosX
    Y1 = MyVer(m).fPosY
    a = Sqr((x0 - X1) ^ 2 + (y0 - Y1) ^ 2)
    b = Sqr((x0 - X) ^ 2 + (y0 - Y) ^ 2)
    c = Sqr((X1 - X) ^ 2 + (Y1 - Y) ^ 2)
    S = (a + b + c) / 2
    Area = Sqr(S * (S - a) * (S - b) * (S - c))
    D = (2 * Area) / a
    If D <= 20 Then iSelArc = i: SelArc = i: Exit For
Next i
End Function
Function Max(ByVal a As Single, ByVal b As Single) As Single
Max = a
If a < b Then Max = b
End Function
Function Min(ByVal a As Single, ByVal b As Single) As Single
Min = a
If a > b Then Min = b
End Function
Function SelVertex(ByVal X As Single, ByVal Y As Single) As Integer
Dim t0 As Boolean
Dim t1 As Boolean

SelVertex = -1
For i = 1 To iVertexNum
        t0 = (X <= MyVer(i).fPosX + R) And (X >= MyVer(i).fPosX - R)
        t1 = (Y <= MyVer(i).fPosY + R) And (Y >= MyVer(i).fPosY - R)
        If t0 And t1 Then SelVertex = i: iSelNode = i: Exit Function
Next i
End Function
Function GetCurNode(ByVal sps As String) As String
n = Len(Trim(LTrim(sps)))
ss = ""
For i = 1 To n
    sc = Mid$(sps, i, 1)
    If sc = ":" Then Exit For
    If sc >= "0" And sc <= "9" Then ss = ss + sc
Next i
GetCurNode = ss
End Function
Sub formInit()
Picture1.Top = TreeView1.Top

TreeView1.Left = Toolbar1.Left
TreeView1.Top = Toolbar1.Top + Toolbar1.Height
TreeView1.Height = Form1.Height - Toolbar1.Height - StatusBar1.Height - 750
TreeView1.Width = Picture1.Left + 10
Picture1.Height = TreeView1.Height
P1.Top = TreeView1.Top
P1.Left = TreeView1.Width + Picture1.Width - 40
D = Form1.Width - TreeView1.Width - Picture1.Width - VScroll1.Width - 120
If D > 0 Then P1.Width = D
D = TreeView1.Height - HScroll1.Height
If D > 0 Then P1.Height = D
HScroll1.Top = P1.Top + P1.Height
VScroll1.Left = TreeView1.Width + Picture1.Width + P1.Width - 40
VScroll1.Height = P1.Height + HScroll1.Height
HScroll1.Left = P1.Left + 20
HScroll1.Width = P1.Width
P2.Top = 0
P2.Left = 0
P2.Width = P1.Width
P2.Height = P1.Height
HScroll1.Max = 0
VScroll1.Max = 0
D = Form1.Width - (StatusBar1.Panels(1).Width + StatusBar1.Panels(2).Width + StatusBar1.Panels(4).Width) - 600
If D > 0 Then StatusBar1.Panels(3).Width = D
End Sub

Private Sub Att_Click()
If iProjectType = 0 Then Form3.Show
If iProjectType = 1 Then Form2.Show
If iProjectType = 2 Then Form4.Show

End Sub

Private Sub DelArc_Click()
If iSelArc < 0 Then Exit Sub
MyArc(iSelArc).iLink = -1
RefreshArc
End Sub
Private Sub DrawVer_Click()
If iStartNode < 0 Then
    i = MsgBox("请设置起点", vbOKOnly + vbInformation, "警告")
    Exit Sub
End If
If iEndNode < 0 Then
    i = MsgBox("请设置终点", vbOKOnly + vbInformation, "警告")
    Exit Sub
End If

iArcNum = iArcNum + 1
ReDim Preserve MyArc(iArcNum)
P2.Line (MyVer(iStartNode).fPosX, MyVer(iStartNode).fPosY)-(MyVer(iEndNode).fPosX, MyVer(iEndNode).fPosY), &H0
MyArc(iArcNum).iStartNode = iStartNode
MyArc(iArcNum).iEndNode = iEndNode
MyArc(iArcNum).iLink = 1
RefreshArc
iStartNode = -1
iEndNode = -1
End Sub

Private Sub Fin_Click()
If cn.State = 1 Then cn.Close
End
End Sub

Private Sub Form_Load()
Text1.Text = "UMA"

DbStatus = False
iVertexNum = 0
iArcNum = 0
iSelText = -1
SaveVert.Enabled = False
SaveArc.Enabled = False
SaveAll.Enabled = False
Att.Enabled = False
hDt = 1: vDt = 1
End Sub

Private Sub Form_Resize()
formInit

End Sub

Private Sub HScroll1_Change()
P2.Left = -HScroll1.Value
End Sub
Private Sub lDg_Click()
Dim sps As String
Dim sSql As String
n = TreeView1.Nodes.Count
If n = 0 Then Exit Sub
sps = Trim(LTrim(TreeView1.SelectedItem.Key))
sps = GetCurNode(sps)
sCurNode = sps
sSql = "select * from Project where ID=" + sps
RS.Open sSql, cn, adOpenKeyset, adLockPessimistic
If RS.EOF And RS.BOF Then
    RS.Close
    Exit Sub
End If
iProjectType = RS("iFlag").Value
sCurPNode = Trim(LTrim(Str(RS("PID").Value)))
SaveVert.Enabled = True
SaveArc.Enabled = True
NewProject.Enabled = True
NewSubProject.Enabled = True
If iProjectType = 1 Then SaveArc.Enabled = False: NewProject.Enabled = False: NewSubProject.Enabled = False
If iProjectType = 2 Then SaveVert.Enabled = False: NewProject.Enabled = False: NewSubProject.Enabled = False
StatusBar1.Panels(1).Text = "项目：" + Trim(LTrim(RS("名称")))
StatusBar1.Panels(2).Text = "日期：" + Trim(LTrim(RS("建立日期")))
StatusBar1.Panels(3).Text = "备注：" + Trim(LTrim(RS("备注")))
RS.Close
LoadAndDraw
End Sub

Private Sub NewProject_Click()
Dim sPNode As String
Dim iSRoot As Boolean
If Not DbStatus Then Exit Sub
n = TreeView1.Nodes.Count
If n = 0 Then Exit Sub
sPNode = TreeView1.SelectedItem.Key
st = GetCurNode(sPNode)
If iProjectType <> 0 Then
    i = MsgBox("数据集项目后不能加项目名称！", vbOKOnly + vbInformation, "警告")
    Exit Sub
End If
iProjectType = 0
sts = "添加" + st + sUserName + "