sjw.frm

VB建立三角形网

   Tb = Val(Left(Twb, K - 1))
   Wb = Val(Right(Twb, Len(Twb) - K))
  Con = Tb / Wb
   
   Range1 = MinHeight
   Range2 = MaxHeight
   Do While Abs(Range1 - Range2) > 0.001
     Range0 = (Range1 + Range2) / 2#
     Call Rate(Range0, Volb)
     If Volb > Con Then
       Range2 = Range0
       Else
       Range1 = Range0
      End If
    Loop
  Call JsTwL((Range1 + Range2) / 2#)
  DeHe = (Range1 + Range2) / 2#
 Text8.Text = Format((Range1 + Range2) / 2#, "0.00")
End Sub
Private Sub Rate(height As Double, ra As Double)
 Dim i%, Fill#, Dig#
 Fill = 0
 Dig = 0
 For i = 1 To Cc
   If height > Av(i) Then
        Fill = Fill + Pl(i) * (height - Av(i))
    Else
         Dig = Dig + Pl(i) * (Av(i) - height)
    End If
 Next i
 ra = Fill / Dig
End Sub

Private Sub Command6_Click()
 'CAD接口
Dim FileName8$, FileName9$, i%
FileName8 = InputBox("请输入命令组文件名：", "提示", "d:\CAD1.scr")
If FileName8 <> "" Then
 Open FileName8 For Output As #8
Else
 MsgBox "文件未打开", vbOKOnly, "提示"
 Exit Sub
End If
 Print #8, "limits" & Chr(32) & minX & "," & minY & Chr(32) & maxX & "," & maxY
 For i = 0 To LeNum
  Print #8, "line" & Chr(32) & Myd(Le(i).Start).X & "," & Myd(Le(i).Start).Y & Chr(32) & Myd(Le(i).Last).X & "," & Myd(Le(i).Last).Y & Chr(32)
 Next i
 Print #8, "zoom" & Chr(32) & "all"
 Close (8)
 Open Mid$(FileName8, 1, Len(FileName8) - 4) & "1" & ".scr" For Output As #9
  For i = 1 To Cc
   If Av(i) < Val(DeHe) Then
    Print #9, "-bhatch" & Chr(32) & CStr(CenterX(i)) & "," & CStr(CenterY(i)) & _
               Chr(32) & "p" & Chr(32) & "u" & Chr(32) & "0" & Chr(32) & "10" & Chr(32) _
               & "Y" & Chr(32)
    End If
    Next i
   Close (9)
  Open Mid$(FileName8, 1, Len(FileName8) - 4) & "2" & ".scr" For Output As #9
    Print #9, "color" & Chr(32) & "1"
    For i = 1 To Zn
    Print #9, "pline" & Chr(32) & ZeroStartX(i) & "," & ZeroStartY(i) & Chr(32) & "w" & Chr(32) & "0.4" & Chr(32) & "0.4" & Chr(32) & ZeroLastX(i) & "," & ZerolastY(i) & Chr(32)
    Next i
   Close (9)
 
 
End Sub

Private Sub Command7_Click()
 My_Command = "pan"
 My_Count = 1
End Sub

Private Sub Command8_Click()
My_Command = "fd"
End Sub

Private Sub Command9_Click()
  Picture1.Picture = LoadPicture()
  Picture1.Cls
  Picture2.Picture = LoadPicture()
  Picture2.Cls
  Call mnuredraw_Click
End Sub

Private Sub Form_Load()
Dim samelenum0%, u%
Dim i%, j%, n%, K%, Code1%, Code2%, Code3%
Rad = True
Wing = True
Call readfile
Call Screen1_Intilize
Call Screen2_Intilize
For i = 0 To Net_num - 1
For j = 0 To Net_num - 1
n = 0
For K = 1 To FileLength
  If Myd(K).X >= Net(i, j).minXX And Myd(K).X < Net(i, j).maxXX And Myd(K).Y >= Net(i, j).minYY And Myd(K).Y < Net(i, j).maxYY Then
     Net(i, j).Mm(n) = Myd(K).No
     n = n + 1
  End If
Next K
Aa(i, j) = n
Next j
Next i
For i = 1 To FileLength
Picture1.Circle (Myd(i).X, Myd(i).Y), 2, RGB(255, 0, 0)
Picture2.Circle (Myd(i).X, Myd(i).Y), 2, RGB(255, 0, 0)
Next i
 MaxHeight = Myd(1).Z
   MinHeight = Myd(1).Z
  For i = 1 To FileLength
    If MaxHeight < Myd(i).Z Then
       MaxHeight = Myd(i).Z
    End If
    If MinHeight > Myd(i).Z Then
       MinHeight = Myd(i).Z
    End If
  Next i
 'Debug.Print maxX - minX, maxY - minY
 MaxGc = MaxHeight - MinHeight
Le(0).Start = 3
Le(0).Last = 4
Le(0).Lef = 0
Le(0).Rig = 0
samelenum0 = 0
Call Trinet(Le(), samelenum0)
 'For i = 1 To Cc
 '  If Le(i).Lef = -1 Or Le(i).Rig = -1 Then
 '  Picture1.Line (Myd(Le(i).Start).X, Myd(Le(i).Start).Y)-(Myd(Le(i).Last).X, Myd(Le(i).Last).Y), RGB(255, 0, 0)
 '  End If
 'Next i
For i = 2 To Cc
      If Adjust_Same_tri(Triangle(), i) Then
        u = u + 1
         For j = i To Cc
         Triangle(j).B1 = Triangle(j + 1).B1
         Triangle(j).B2 = Triangle(j + 1).B2
         Triangle(j).B3 = Triangle(j + 1).B3
         Next j
      End If
    Next i
       Cc = Cc - u
      ' frmSplash.Label3.Visible = False
       
       For i = 1 To Cc
        Code1 = Le(Triangle(i).B1).Start
        Code2 = Le(Triangle(i).B1).Last
     If (Le(Triangle(i).B2).Start = Code1) Then
        Code3 = Le(Triangle(i).B2).Last
     ElseIf (Le(Triangle(i).B2).Start = Code2) Then
        Code3 = Le(Triangle(i).B2).Last
     ElseIf (Le(Triangle(i).B2).Last = Code1) Then
        Code3 = Le(Triangle(i).B2).Start
     ElseIf (Le(Triangle(i).B2).Last = Code2) Then
        Code3 = Le(Triangle(i).B2).Start
     Else
       'MsgBox "a"
     End If
     CenterX(i) = (Myd(Code1).X + Myd(Code2).X + Myd(Code3).X) / 3#
     CenterY(i) = (Myd(Code1).Y + Myd(Code2).Y + Myd(Code3).Y) / 3#
     'Debug.Print Code1, Code2, Code3
        Pl(i) = Areas(Code1, Code2, Code3)
        Av(i) = (Myd(Code1).Z + Myd(Code2).Z + Myd(Code3).Z) / 3#
   Next i
    MsgBox "三角网已形成"
End Sub
Private Sub Trinet(Le() As Length, SameLenum As Integer)
Dim Angleft(80, 1) As Double, Angright(80, 1) As Double, E%, F%, i%, j%, cx#, cy#
Dim Angleftmax#, Angleftmaxcode%, Angrightmax#, Angrightmaxcode%, cm%, Cn%, K%, Alf#, Bat#
Dim kk%, qq%, ww%, rr%, SameLenum1%, SameLenum2%, SameLenum3%, SameLenum4%, SjxCode1%, SjxCode2%
Dim LastLenum%, sv1%, sv2%
 For i = 0 To LeNum - 1
  If (Le(LeNum).Start = Le(i).Last And Le(LeNum).Last = Le(i).Start) Then
      If Le(i).Lef = 0 Then
        Le(i).Lef = Le(LeNum).Rig
      End If
      If Le(i).Rig = 0 Then
         Le(i).Rig = Le(LeNum).Lef
      End If
      SameLenum = i
      LeNum = LeNum - 1
      Exit Sub
  End If
  If (Le(LeNum).Start = Le(i).Start And Le(LeNum).Last = Le(i).Last) Then
      If Le(i).Lef = 0 Then
        Le(i).Lef = Le(LeNum).Lef
      End If
      If Le(i).Rig = 0 Then
         Le(i).Rig = Le(LeNum).Rig
      End If
      SameLenum = i
      LeNum = LeNum - 1
     Exit Sub
  End If
Next i
If Le(LeNum).Lef = 0 Or Le(LeNum).Rig = 0 Then
  cx = (Myd(Le(LeNum).Start).X + Myd(Le(LeNum).Last).X) / 2#
  cy = (Myd(Le(LeNum).Start).Y + Myd(Le(LeNum).Last).Y) / 2#
  For i = 0 To Net_num - 1
  For j = 0 To Net_num - 1
   If cx >= Net(i, j).minXX And cx < Net(i, j).maxXX And cy >= Net(i, j).minYY And cy < Net(i, j).maxYY Then
     cm = i
     Cn = j
   End If
     Next j
     Next i
     E = 0
     F = 0
   For i = cm - 1 To cm + 1
    For j = Cn - 1 To Cn + 1
      For K = 0 To Aa(i, j) - 1
       'If Myd(Net(i, j).Mm(k)).Code = 0 Then
       Alf = Fzt(Myd(Le(LeNum).Start).X, Myd(Le(LeNum).Start).Y, Myd(Le(LeNum).Last).X, Myd(Le(LeNum).Last).Y)
       Bat = Fzt(Myd(Le(LeNum).Start).X, Myd(Le(LeNum).Start).Y, Myd(Net(i, j).Mm(K)).X, Myd(Net(i, j).Mm(K)).Y)
       If Le(LeNum).Lef = 0 Then
       If (Bat - Alf < Pai And Bat - Alf > 0#) Or (Bat - Alf > -2# * Pai And Bat - Alf < -Pai) Then
          Angleft(E, 0) = Funcos(Myd(Le(LeNum).Start).X, Myd(Le(LeNum).Start).Y, Myd(Le(LeNum).Last).X, Myd(Le(LeNum).Last).Y, Myd(Net(i, j).Mm(K)).X, Myd(Net(i, j).Mm(K)).Y)
          Angleft(E, 1) = Net(i, j).Mm(K)
          E = E + 1
        End If
        End If
       If Le(LeNum).Rig = 0 Then
        If (Bat - Alf < 0# And Bat - Alf > -Pai) Or (Bat - Alf > Pai And Bat - Alf < 2# * Pai) Then
          Angright(F, 0) = Funcos(Myd(Le(LeNum).Start).X, Myd(Le(LeNum).Start).Y, Myd(Le(LeNum).Last).X, Myd(Le(LeNum).Last).Y, Myd(Net(i, j).Mm(K)).X, Myd(Net(i, j).Mm(K)).Y)
          Angright(F, 1) = Net(i, j).Mm(K)
          F = F + 1
          End If
       End If
     ' End If
      Next K
     Next j
    Next i
    If E = 0 And Le(LeNum).Lef = 0 Then
      Le(LeNum).Lef = -1
    End If
    If F = 0 And Le(LeNum).Rig = 0 Then
      Le(LeNum).Rig = -1
    End If
    LastLenum = LeNum
   If E > 0 Then
       Angleftmax = Angleft(0, 0)
       Angleftmaxcode = Angleft(0, 1)
       For i = 0 To E - 1
         If Angleftmax < Angleft(i, 0) Then
            Angleftmax = Angleft(i, 0)
            Angleftmaxcode = Angleft(i, 1)
         End If
       Next i
       If Angleftmax < Micro# Then  '''kldfs;adk
         Le(LeNum).Lef = -1
         Exit Sub
       End If
        Cc = Cc + 1
        SjxCode1 = Cc
        Le(LastLenum).Lef = SjxCode1
        Le(LeNum + 1).Start = Le(LastLenum).Start
        Le(LeNum + 1).Last = Angleftmaxcode
        Le(LeNum + 1).Rig = SjxCode1
        Le(LeNum + 1).Lef = 0
        ww = LastLenum
        SameLenum1 = LeNum + 1
        rr = Angleftmaxcode
        LeNum = LeNum + 1
        'Picture1.Line (Myd(Le(LeNum).Start).X, Myd(Le(LeNum).Start).Y)-(Myd(Le(LeNum).Last).X, Myd(Le(LeNum).Last).Y)
        Call Trinet(Le(), SameLenum1)
        Le(LeNum + 1).Start = Le(ww).Last
        Le(LeNum + 1).Last = rr
        Le(LeNum + 1).Rig = 0
        Le(LeNum + 1).Lef = SjxCode1
        LeNum = LeNum + 1
       ' Picture1.Line (Myd(Le(LeNum).Start).X, Myd(Le(LeNum).Start).Y)-(Myd(Le(LeNum).Last).X, Myd(Le(LeNum).Last).Y)
         SameLenum2 = LeNum
        Call Trinet(Le(), SameLenum2)
        Triangle(SjxCode1).B1 = ww
        Triangle(SjxCode1).B2 = SameLenum1
        Triangle(SjxCode1).B3 = SameLenum2
    End If
     
    If F > 0 Then
       Angrightmax = Angright(0, 0)
       Angrightmaxcode = Angright(0, 1)
       For i = 0 To F - 1
         If Angrightmax < Angright(i, 0) Then
          Angrightmax = Angright(i, 0)
           Angrightmaxcode = Angright(i, 1)
        End If
       Next i
       If Angrightmax < Micro# Then 'fdghdfhgfh
         Le(LeNum).Rig = -1
         Exit Sub
       End If
       Cc = Cc + 1
       SjxCode2 = Cc
        Le(LastLenum).Rig = SjxCode2
        Le(LeNum + 1).Start = Le(LeNum).Start
        Le(LeNum + 1).Last = Angrightmaxcode
        Le(LeNum + 1).Lef = SjxCode2
        Le(LeNum + 1).Rig = 0
          kk = LastLenum
          SameLenum3 = LeNum + 1
          qq = Angrightmaxcode
          LeNum = LeNum + 1
                   ' Picture1.Line (Myd(Le(LeNum).Start).X, Myd(Le(LeNum).Start).Y)-(Myd(Le(LeNum).Last).X, Myd(Le(LeNum).Last).Y)

        Call Trinet(Le(), SameLenum3)
        Le(LeNum + 1).Start = Le(kk).Last
        Le(LeNum + 1).Last = qq
        Le(LeNum + 1).Rig = SjxCode2
        Le(LeNum + 1).Lef = 0
        LeNum = LeNum + 1
        SameLenum4 = LeNum
               ' Picture1.Line (Myd(Le(LeNum).Start).X, Myd(Le(LeNum).Start).Y)-(Myd(Le(LeNum).Last).X, Myd(Le(LeNum).Last).Y)

        Call Trinet(Le(), SameLenum4)
        Triangle(SjxCode2).B1 = kk
        Triangle(SjxCode2).B2 = SameLenum3
        Triangle(SjxCode2).B3 = SameLenum4
     End If
    Else
    Exit Sub
    End If
End Sub
Public Function Fzt(x1#, y1#, x2#, y2#) As Double
Dim dtx#, dty#
dtx = x2 - x1
dty = y2 - y1
If dtx <> 0 And dty <> 0 Then
     Fzt = Atn(Abs(dty / dtx))
     If dtx > 0# And dty > 0# Then
       Fzt = Atn(dty / dtx)
      End If
     If dty > 0# And dtx < 0# Then
       Fzt = Pai - Fzt
     End If
     If dty < 0# And dtx < 0# Then
       Fzt = Pai + Fzt
     End If
     If dty < 0# And dtx > 0# Then
       Fzt = 2# * Pai - Fzt
      End If
ElseIf dty = 0# And dtx > 0# Then
       Fzt = 0#
ElseIf dty = 0# And dtx < 0# Then
         Fzt = Pai
ElseIf dty < 0# And dtx = 0# Then
        Fzt = 3# * Pai / 2#
ElseIf dty > 0# And dtx = 0# Then
      Fzt = Pai / 2#
Else
Exit Function
End If
End Function

 Public Function Arccos(p As Double) As Double
 If p <> 1# Then
  Arccos = Atn(-p / Sqr(-p * p + 1#)) + Pai / 2#
  End If
End Function


'求三角形夹角

Public Function Funcos(x1#, y1#, x2#, y2#, x3#, y3#) As Double
Dim BC1#, BC2, BC3#
    BC1 = Sqr((x1 - x3) ^ 2# + (y1 - y3) ^ 2#)
    BC2 = Sqr((x2 - x3) ^ 2# + (y2 - y3) ^ 2#)
    BC3 = Sqr((x1 - x2) ^ 2# + (y1 - y2) ^ 2#)
     If BC1 <> 0# And BC2 <> 0# And BC3 <> 0# Then
      Funcos = Arccos((BC1 ^ 2# + BC2 ^ 2# - BC3 ^ 2#) / (2# * BC1 * BC2))
     Else
    Exit Function
    End If
End Function
Private Function Adjust_Same_tri(Triangle() As sjx, tri_num As Integer) As Boolean
Dim i%, a0%, b0%, c0%, an%, bn%, Cn%
  Adjust_Same_tri = False
  a0 = Triangle(tri_num).B1
  b0 = Triangle(tri_num).B2
  c0 = Triangle(tri_num).B3
  For i = 1 To tri_num - 1
    an = Triangle(i).B1
    bn = Triangle(i).B2
    Cn = Triangle(i).B3
   If a0 <> 0 Or b0 <> 0 Or c0 <> 0 Then
   If an = a0 Or an = b0 Or an = c0 Then
      If bn = a0 Or bn = b0 Or bn = c0 Then
        If Cn = a0 Or Cn = b0 Or Cn = c0 Then
         Adjust_Same_tri = True
        End If
      End If
   End If
   End If
Next i
End Function

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
 If Bzz = 2 Then
   DrawMode = 6
   Picture2.Circle (x00, y00), 60, QBColor(4)
   DrawMode = 13
 End If
   Bzz = 0
End Sub

Private Sub Menman_Click()
 Man = "manyou"
End Sub

Private Sub meuback_Click()
Picture1.Cls
Call Screen1_Intilize
      If Ddf = "sjw" Then
       Call Command1_Click
      ElseIf Ddf = "dgx" Then
        Call Draw_Dgx(Picture1)
      End If
      sh = False
End Sub

Private Sub meuend_Click()
End
End Sub

Private Sub meuzoom_Click()
 My_Command = "fd"