frmtriangle.frm

这是基于MapX4.0的房屋测绘管理信息系统

   End
End
Attribute VB_Name = "frmTriangle"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Const PI_IN_MATH As Double = 3.1415926
Dim OPts(1 To 3) As UPoint
Private Sub cmdCalc_Click()
    Dim L1 As Double
    Dim L2 As Double
    Dim L3 As Double
    Dim a1 As Double
    Dim a2 As Double
    Dim a3 As Double
    
    
    If (Not IsNumeric(txtL1)) Or (Not IsNumeric(txtL2)) Or (Not IsNumeric(txtL3)) Then
        MsgBox "请输入数据!", vbOKOnly + vbInformation, Me.Caption
        txtL1.SetFocus
        Exit Sub
    End If
    '---------------------------------
    L1 = CDbl(txtL1.Text)
    L2 = CDbl(txtL2.Text)
    L3 = CDbl(txtL3.Text)
    '-----------------
    If Not IsTriangle(L1, L2, L3) Then
        MsgBox "请确认输入的数据是正确的。" & vbCrLf & "因为所输入的数据无法构成三角形！", vbOKOnly + vbInformation, Me.Caption
        txtL1.SetFocus
        Exit Sub
    End If
    '-------------------------------------
    a1 = Acos((L2 * L2 + L3 * L3 - L1 * L1) / (2 * L2 * L3))
    a2 = Acos((L1 * L1 + L3 * L3 - L2 * L2) / (2 * L1 * L3))
    a3 = Acos((L1 * L1 + L2 * L2 - L3 * L3) / (2 * L1 * L2))
    
    LabelA1.Caption = Format(CStr(Round(a1 * 180 / PI_IN_MATH, 2)), "##0.00°")
    LabelA2.Caption = Format(CStr(Round(a2 * 180 / PI_IN_MATH, 2)), "##0.00°")
    LabelA3.Caption = Format(CStr(Round(a3 * 180 / PI_IN_MATH, 2)), "##0.00°")
    '---------------------------------------------
    lblL1.Caption = CStr(L1)
    lblL2.Caption = CStr(L2)
    lblL3.Caption = CStr(L3)
    
    lblA1.Caption = LabelA1.Caption
    lblA2.Caption = LabelA2.Caption
    lblA3.Caption = LabelA3.Caption

    '显示图形
    Call DrawTriangle(L1, L2, L3, a1, a2, a3)
    '---------------------
    txtL1.SetFocus
    txtL1.SelStart = 0
    txtL1.SelLength = Len(txtL1)
End Sub
Private Sub cmdCalc_GotFocus()
    cmdCalc.Default = True
End Sub

Private Sub cmdCalc_LostFocus()
    cmdCalc.Default = False
End Sub
Private Sub Command2_Click()
    Unload Me
End Sub
Private Sub Form_Load()
    
    LabelA1.Caption = ""
    LabelA2.Caption = ""
    LabelA3.Caption = ""
    '---------------------
    OPts(1).X = Line1.x1
    OPts(1).Y = Line1.y1
    OPts(2).X = Line1.x2
    OPts(2).Y = Line1.y2
    OPts(3).X = Line2.x2
    OPts(3).Y = Line2.y2
End Sub
Private Function Max(ByVal num1 As Double, ByVal num2 As Double) As Double
    If num1 > num2 Then
        Max = num1
    Else
        Max = num2
    End If
End Function
Private Function Min(ByVal num1 As Double, ByVal num2 As Double) As Double
    If num1 < num2 Then
        Min = num1
    Else
        Min = num2
    End If
End Function
Private Function IsTriangle(ByVal L1 As Double, ByVal L2 As Double, ByVal L3 As Double) As Boolean
    Dim a As Double
    Dim b As Double
    Dim c As Double
    Dim tmp As Double
    
    IsTriangle = False
    
    '将L1,L2,L3排序a>b>c
    If L1 > L2 Then
        a = L1
        b = L2
    Else
        a = L2
        b = L1
    End If
    
    If b > L3 Then
        c = L3
    Else
        c = b
        If a > L3 Then
            b = L3
        Else
            b = a
            a = L3
        End If
    End If
    '-----------------------------------
    If (b + c) > a Then
        IsTriangle = True
    Else
        IsTriangle = False
    End If
End Function
Private Function Acos(ByVal X As Double) As Double
    Select Case X
        Case 1
            Acos = 0
        Case -1
            Acos = PI_IN_MATH
        Case Else
            Acos = Atn(-X / Sqr(-X * X + 1)) + 2 * Atn(1)
    End Select
End Function
'保持最大边长度不变
Private Sub DrawTriangle(ByVal L1 As Double, ByVal L2 As Double, ByVal L3 As Double, _
                         ByVal a1 As Double, ByVal a2 As Double, ByVal a3 As Double)
    Dim MaxLine As Double
    Dim L(1 To 3) As Double
    Dim i As Long
    Dim sc As Double '比例
    Dim NewPts(1 To 3) As UPoint '新的三个点
    
    Dim P1 As UPoint
    Dim P2 As UPoint
    Dim bb As Double 'degree
    Dim aa As Double
    
    MaxLine = Max(L1, Max(L2, L3))
    Select Case MaxLine
        Case L1
            i = 1
            L(1) = GetDistance(OPts(1).X, OPts(1).Y, OPts(2).X, OPts(2).Y)
            L(2) = L2 * L(i) / MaxLine
            L(3) = L3 * L(i) / MaxLine
            NewPts(1).X = OPts(1).X
            NewPts(1).Y = OPts(1).Y
            NewPts(2).X = OPts(2).X
            NewPts(2).Y = OPts(2).Y
            
            P1.X = NewPts(2).X - NewPts(1).X
            P1.Y = -(NewPts(2).Y - NewPts(1).Y)
            
            aa = Acos(P1.X / L(1))
            bb = aa - a2
            
            NewPts(3).X = L(3) * Cos(bb) + NewPts(1).X
            NewPts(3).Y = -L(3) * Sin(bb) + NewPts(1).Y
        Case L2
            i = 2
            L(2) = GetDistance(OPts(2).X, OPts(2).Y, OPts(3).X, OPts(3).Y)
            L(1) = L1 * L(i) / MaxLine
            L(3) = L3 * L(i) / MaxLine
            NewPts(2).X = OPts(2).X
            NewPts(2).Y = OPts(2).Y
            NewPts(3).X = OPts(3).X
            NewPts(3).Y = OPts(3).Y
            
            P1.X = NewPts(2).X - NewPts(3).X
            P1.Y = -(NewPts(2).Y - NewPts(3).Y)
            
            aa = Acos(P1.X / L(2))
            bb = aa + a1
            
            NewPts(1).X = L(3) * Cos(bb) + NewPts(3).X
            NewPts(1).Y = -L(3) * Sin(bb) + NewPts(3).Y
        Case L3
            i = 3
            L(3) = GetDistance(OPts(1).X, OPts(1).Y, OPts(3).X, OPts(3).Y)
            L(1) = L1 * L(i) / MaxLine
            L(2) = L2 * L(i) / MaxLine
            NewPts(1).X = OPts(1).X
            NewPts(1).Y = OPts(1).Y
            NewPts(3).X = OPts(3).X
            NewPts(3).Y = OPts(3).Y
            
            P1.X = NewPts(3).X - NewPts(1).X
            P1.Y = -(NewPts(3).Y - NewPts(1).Y)
            
            aa = Acos(P1.X / L(3))
            bb = aa + a2
            
            NewPts(2).X = L(1) * Cos(bb) + NewPts(1).X
            NewPts(2).Y = -L(1) * Sin(bb) + NewPts(1).Y
        Case Else
            Exit Sub
    End Select
    
    '-------------------------------------------------
    Line1.x1 = NewPts(1).X
    Line1.y1 = NewPts(1).Y
    Line1.x2 = NewPts(2).X
    Line1.y2 = NewPts(2).Y
    
    Line2.x1 = NewPts(2).X
    Line2.y1 = NewPts(2).Y
    Line2.x2 = NewPts(3).X
    Line2.y2 = NewPts(3).Y
    
    Line3.x1 = NewPts(1).X
    Line3.y1 = NewPts(1).Y
    Line3.x2 = NewPts(3).X
    Line3.y2 = NewPts(3).Y
    '-------------------------------------------------
    lblL1.Left = (NewPts(1).X + NewPts(2).X) / 2 - 100 * (Len(lblL1.Caption) + 1)
    lblL1.Top = (NewPts(1).Y + NewPts(2).Y) / 2 - 200
    lblL2.Left = (NewPts(2).X + NewPts(3).X) / 2 + 50
    lblL2.Top = (NewPts(2).Y + NewPts(3).Y) / 2 - 200
    lblL3.Left = (NewPts(1).X + NewPts(3).X) / 2
    lblL3.Top = (NewPts(1).Y + NewPts(3).Y) / 2 + 50
    
    lblA1.Left = NewPts(3).X - 600
    lblA1.Top = NewPts(3).Y - 100
    lblA2.Left = NewPts(1).X
    lblA2.Top = NewPts(1).Y
    lblA3.Left = NewPts(2).X - 200
    lblA3.Top = NewPts(2).Y - 200
End Sub
Private Sub txtL1_GotFocus()
    txtL1.SelStart = 0
    txtL1.SelLength = Len(txtL1)
End Sub
Private Sub txtL2_GotFocus()
    txtL2.SelStart = 0
    txtL2.SelLength = Len(txtL2)
End Sub
Private Sub txtL3_GotFocus()
    txtL3.SelStart = 0
    txtL3.SelLength = Len(txtL3)
End Sub
Private Sub txtL1_KeyPress(KeyAscii As Integer)
    If KeyAscii = vbKeyReturn Then
        txtL2.SetFocus
    End If
End Sub
Private Sub txtL2_KeyPress(KeyAscii As Integer)
    If KeyAscii = vbKeyReturn Then
        txtL3.SetFocus
    End If
End Sub
Private Sub txtL3_KeyPress(KeyAscii As Integer)
    If KeyAscii = vbKeyReturn Then
        cmdCalc.SetFocus
    End If
End Sub