sjw.frm

VB建立三角形网

      Left            =   720
      ScaleHeight     =   5595
      ScaleWidth      =   6435
      TabIndex        =   1
      Top             =   -120
      Width           =   6495
   End
   Begin MSComDlg.CommonDialog CommonDialog1 
      Left            =   1200
      Top             =   3600
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.CommandButton Command2 
      Caption         =   "结束"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   13680
      TabIndex        =   0
      ToolTipText     =   "结束系统"
      Top             =   6600
      Width           =   615
   End
   Begin VB.Menu mnufile 
      Caption         =   "文件"
      Begin VB.Menu open 
         Caption         =   "打开"
      End
      Begin VB.Menu save 
         Caption         =   "保存"
      End
      Begin VB.Menu mnuline 
         Caption         =   "-"
      End
      Begin VB.Menu meuend 
         Caption         =   "结束"
      End
   End
   Begin VB.Menu MNUMAP 
      Caption         =   "视图"
      Begin VB.Menu meuzoom 
         Caption         =   "放大"
      End
      Begin VB.Menu mnupan 
         Caption         =   "扫视"
      End
      Begin VB.Menu meuback 
         Caption         =   "还原"
      End
      Begin VB.Menu mnuredraw 
         Caption         =   "重画"
      End
      Begin VB.Menu mnull 
         Caption         =   "-"
      End
      Begin VB.Menu font 
         Caption         =   "字体"
      End
      Begin VB.Menu COLOR 
         Caption         =   "颜色"
      End
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Const Net_num = 10
Const BB = 2850
Const PP = 2290
Const DG = 100
Const DX = 40
Dim Myd(1 To PP) As Points
Dim Net(-1 To Net_num, -1 To Net_num) As Cross
Dim FileLength As Integer
Dim Triangle(1 To BB) As sjx
Dim Le(0 To BB) As Length
Dim Num(1 To PP) As String
Dim minX, minY, maxX, maxY, x1, x2, y1, y2, fg, Si1#, Si2#
Const Pai = 3.14159265358979
Const Micro = 0.001
Dim Cc As Integer
Dim LeNum As Integer
'象素参数
Dim LastWidth%, LastHeight%

Public My_Command$, MouseX1#, MouseY1#, MouseX0#, MouseY0#, Right_Button%, Pd_Right%, Move_Mark
Public MouseX2#, MouseY2#, Mark, My_Count%, CSHx1#, CSHy1#, CSHx2#, CSHy2#, Man$, Blyz0#
''''''''Picture2_MouseMove
Dim x00#, y00#, Rad As Boolean, Bzz%, Wing As Boolean
Dim Bzx#, Bzy#
Dim Aa(-1 To Net_num, -1 To Net_num) As Integer
Dim Av(BB) As Double, Pl(BB) As Double
'等直线参数
'Dim Epx(DG, DX, BB) As Double
'Dim Epy(DG, DX, BB) As Double
Dim Ds(PP, DX) As Integer, Xs(DX) As Integer
Dim Num_Bet%
Dim MaxHeight#, MinHeight#, Between#, BetHeight(300) As Double, DeHe#
'Dim Svp(DG, BB) As Integer, Num_Spb(BB) As Integer
Dim Num_Dgx As Integer
Dim A(3000) As ss
Dim Ddf$, sh As Boolean
'零线点坐标参数
 Dim ZeroX(50) As Double, ZeroY(50) As Double, Vv As Integer
 Dim CenterX(BB) As Double, CenterY(BB) As Double, MaxGc#
 '画零线
 Dim ZeroStartX(100) As Double, ZeroStartY(100) As Double, ZeroLastX(100) As Double
 Dim ZerolastY(100) As Double, Zn%
Private Sub Screen1_Intilize()
Dim i%, j%, si01#, si02#, sing1#, sing2#
Form1.Left = 0#
Form1.Top = 0#
Form1.Width = Screen.Width
Form1.height = Screen.height
Picture1.Left = Form1.Left + 735
Picture1.Top = Form1.Top
Picture1.Width = Form1.height - 800#
Picture1.height = Form1.height - 800#
   Form1.Picture1.ScaleMode = vbPixels
  LastWidth = Picture1.ScaleWidth
  LastHeight = Picture1.ScaleHeight
  'Debug.Print "sdkfh", LastWidth, LastHeight
minX = Myd(1).X
maxX = Myd(1).X
minY = Myd(1).Y
maxY = Myd(1).Y
For i = 1 To FileLength - 1
  If (minX > Myd(i + 1).X) Then
   minX = Myd(i + 1).X
End If
If (maxX < Myd(i + 1).X) Then
    maxX = Myd(i + 1).X
End If
If (minY > Myd(i + 1).Y) Then
   minY = Myd(i + 1).Y
End If
If (maxY < Myd(i + 1).Y) Then
   maxY = Myd(i + 1).Y
End If
Next i
si01 = (maxX - minX) / Picture1.Width
si02 = (maxY - minY) / Picture1.height
If si01 > si02 Then
Si1 = si01
Else
Si1 = si02
End If
Picture1.Scale (minX, minY + Picture1.height * Si1)-(minX + Picture1.Width * Si1, minY)

Picture1.Picture = LoadPicture()
For i = 0 To Net_num
Picture1.Line (minX + sing1, minY)-(minX + sing1, minY + Picture1.height * Si1), RGB(0, 256, 0)
Picture1.Line (minX, minY + sing2)-(minX + Picture1.Width * Si1, minY + sing2), RGB(0, 256, 0)
sing1 = sing1 + (Picture1.Width * Si1) / Net_num
sing2 = sing2 + (Picture1.height * Si1) / Net_num
Next i
'求出各矩形框的左下角坐标 ,右上角坐
sing1 = 0#
For i = 0 To Net_num - 1
sing2 = 0#
For j = 0 To Net_num - 1
Net(i, j).minXX = minX + sing1
Net(i, j).minYY = minY + sing2
Net(i, j).maxXX = minX + sing1 + (Picture1.Width * Si1) / Net_num
Net(i, j).maxYY = minY + sing2 + (Picture1.height * Si1) / Net_num
sing2 = sing2 + (Picture1.height * Si1) / Net_num
Next j
sing1 = sing1 + (Picture1.Width * Si1) / Net_num
Next i
For i = 0 To Net_num
For j = 0 To Net_num
Picture1.Circle (Net(i, j).minXX, Net(i, j).minYY), 1, RGB(180, 0, 0)
Next j
Next i
End Sub
Private Sub Screen2_Intilize()
Dim i%, j%, si01#, si02#, sing1#, sing2#
'Picture2.Left = 7320
'Picture2.Top = 3840
'Picture2.Width = 2055
'Picture2.height = 2055
si01 = (maxX - minX) / Picture2.Width
si02 = (maxY - minY) / Picture2.height
If si01 > si02 Then
  Si2 = si01
Else
  Si2 = si02
End If
Picture2.Scale (minX, minY + Picture2.height * Si2)-(minX + Picture2.Width * Si2, minY)
Picture2.Picture = LoadPicture()
End Sub
Private Sub readfile()
Dim i%, Name$
Name$ = InputBox("请输入数据文件", "提示", "d:\坐标点.txt")
If Name <> "" Then
  Open Name$ For Input As #1
'frmSplash.Label3.Visible = True
'frmSplash.Refresh
i = 1
Do While Not EOF(1)
'Input #1, Num(i)
'Myd(i).No = Val(Mid$(Num(i), 4, 4))
'Myd(i).Code = Val(Mid$(Num(i), 33, 16))
'Myd(i).X = Val(Mid$(Num(i), 57, 16)) / 1000
'Myd(i).Y = Val(Mid$(Num(i), 81, 16)) / 1000
'Myd(i).Z = Val(Mid$(Num(i), 105, 16))
Input #1, Myd(i).No
Input #1, Myd(i).X
Input #1, Myd(i).Y
Input #1, Myd(i).Z
FileLength = FileLength + 1
i = i + 1
Loop
Close (1)
Else
 End
End If
End Sub

Private Sub DrawSjw(Obj As PictureBox, si As Double)
Dim i%, sing1#, sing2#, j%
Open "c:\file04.dat" For Output As #4
Obj.Cls
Obj.Picture = LoadPicture()
For i = 0 To Net_num + 1
Obj.Line (minX + sing1, minY)-(minX + sing1, minY + Obj.height * si), RGB(116, 255, 255)
Obj.Line (minX, minY + sing2)-(minX + Obj.Width * si, minY + sing2), RGB(116, 255, 255)
sing1 = sing1 + (Obj.Width * si) / Net_num
sing2 = sing2 + (Obj.height * si) / Net_num
Next i
For i = 0 To Net_num
For j = 0 To Net_num
Obj.Circle (Net(i, j).minXX, Net(i, j).minYY), 1, RGB(255, 0, 0)
Next j
Next i
For i = 1 To FileLength
Obj.Circle (Myd(i).X, Myd(i).Y), 1, RGB(255, 0, 0)
Next i
For i = 0 To LeNum
Print #4, i, Le(i).Start, Le(i).Last, Le(i).Lef, Le(i).Rig
If (Le(i).Start <> 0) Then
Obj.Line (Myd(Le(i).Start).X, Myd(Le(i).Start).Y)-(Myd(Le(i).Last).X, Myd(Le(i).Last).Y)
End If
Next i
Close (4)
End Sub

Private Sub Command1_Click()
 Call DrawSjw(Picture1, Si1)
 Call DrawSjw(Picture2, Si2)
 Ddf = "sjw"
End Sub

Private Sub Command10_Click()
  Dim Between1$
 Between1 = InputBox("请输入等高距", "提示", "2000")
   If Between1 = "" Then
    Exit Sub
   End If
   Between = Val(Between1)
    Call ZZDGX(Between)
    Call Draw_Dgx(Picture2)
    Ddf = "dgx"
    MsgBox ("等高线绘制完毕")
End Sub
Private Sub Command11_Click()
  '添充颜色
  Dim PointCode1%, PointCode2%, PointCode3%, Average#, i%, X As Long, Y As Long, Gc#, Shh#
   Dim Xu1#, Xu2#
   Call meuback_Click
   Xu1 = LastWidth / Picture1.Width
   Xu2 = LastHeight / Picture1.height
    Picture1.FillStyle = 0
    Picture1.ScaleMode = vbPixels
    For i = 1 To Cc
        PointCode1 = Le(Triangle(i).B1).Start
        PointCode2 = Le(Triangle(i).B1).Last
     If (Le(Triangle(i).B2).Start = PointCode1) Then
        PointCode3 = Le(Triangle(i).B2).Last
     ElseIf (Le(Triangle(i).B2).Start = PointCode2) Then
        PointCode3 = Le(Triangle(i).B2).Last
     ElseIf (Le(Triangle(i).B2).Last = PointCode1) Then
        PointCode3 = Le(Triangle(i).B2).Start
     ElseIf (Le(Triangle(i).B2).Last = PointCode2) Then
        PointCode3 = Le(Triangle(i).B2).Start
     Else
       'MsgBox "a"
     End If
   Average = (Myd(PointCode1).Z + Myd(PointCode2).Z + Myd(PointCode3).Z) / 3#
   X = CLng(((Myd(PointCode1).X + Myd(PointCode2).X + Myd(PointCode3).X) / 3# - minX) / Si1 * Xu1)
   Y = LastHeight - CLng(((Myd(PointCode1).Y + Myd(PointCode2).Y + Myd(PointCode3).Y) / 3# - minY) / Si1 * Xu2)
   Gc = Average - DeHe
   Shh = 2 * CInt(Gc / 2000#) / CInt(MaxGc / 2000#)
   If Average > DeHe Then
        'Picture1.Circle (X, Y), 5, RGB(0, 255, 0)
     If 128 + Abs(Shh * 128) < 255 Then
      Call Fill(X, Y, Form1.Picture1, RGB(128 + Abs(Shh * 128), 128 + Abs(Shh * 128), 0)) '128 + Abs(Shh * 128)))
      Else
      Call Fill(X, Y, Form1.Picture1, RGB(255, 255, 0))
      End If
    Else
       'Picture1.Circle (X, Y), 5, RGB(0, 0, 255)
    Call Fill(X, Y, Form1.Picture1, RGB(0, Abs(128 - Abs(128 * Shh)), Abs(128 - Abs(128 * Shh))))
   End If
 Next i
 Picture1.FillStyle = 1
 Picture1.DrawWidth = 2
 Call DrawZeroLine(Picture1, Val(DeHe))
 Picture1.DrawWidth = 1
End Sub

Private Sub Command12_Click()
  Dim i%, OutName$, Bc(1000) As Double, AvBc#, Ts#
  OutName$ = InputBox("请输入输出数据文件名：", "输出提示", "d:\Outdata.txt")
  If OutName <> "" Then
   Open OutName For Output As #9
  Else
   Exit Sub
  End If
  Form2.Show
  Print #9, "边表：边号           起点          终点                  边长"
  For i = 0 To LeNum
   Bc(i) = Sqr((Myd(Le(i).Start).X - Myd(Le(i).Last).X) ^ 2 + (Myd(Le(i).Start).Y - Myd(Le(i).Last).Y) ^ 2)
   Form2.List1.AddItem Space(5) & Format(i, "000") & Space(10) & Format(Le(i).Start, "000") & Space(10) & _
                       Format(Le(i).Last, "000") & Space(10) & Format(Bc(i), "000.00")
   Print #9, Space(5) & Format(i, "000") & Space(10) & Format(Le(i).Start, "000") & Space(10) & _
                       Format(Le(i).Last, "000") & Space(10) & Format(Bc(i), "000.00")
   AvBc = AvBc + Bc(i)
  Next i
   Print #9, "平均边长：", CStr(Format(AvBc / (LeNum + 1), "#####.##"))
   Form2.Label8.Caption = CStr(Format(AvBc / (LeNum + 1), "#####.##"))
   Print #9, "三角形表：编码         边一          边二          边三       面积           填（-）挖（+）量"
  For i = 1 To Cc
   Form2.List2.AddItem Space(5) & Format(i, "000") & Space(10) & Format(Triangle(i).B1, "000") & _
     Space(10) & Format(Triangle(i).B2, "000") & Space(10) & Format(Triangle(i).B3, "000") & Space(10) & _
     Format(Pl(i), "0000.00") & Space(10) & Format((Av(i) - DeHe) / 1000# * Pl(i), "00000.000")
    Print #9, Space(5) & Format(i, "000") & Space(10) & Format(Triangle(i).B1, "000") & _
     Space(10) & Format(Triangle(i).B2, "000") & Space(10) & Format(Triangle(i).B3, "000") & Space(10) & _
     Format(Pl(i), "0000.00") & Space(10) & Format((Av(i) - DeHe) / 1000# * Pl(i), "00000.000")
     Ts = Ts + Pl(i)
  Next i
  Form2.Label5.Caption = CStr(Format(DeHe, "0.00"))
  Print #9, "设计高程：", CStr(Format(DeHe, "0.00"))
   Print #9, "零线上点的坐标"
   Print #9, "编号：      Y坐标             X 坐标 "
   For i = 1 To Vv
     Form2.List3.AddItem Format(i, "000") & Space(10) & Format(ZeroX(i), "000000.00") & Space(10) & Format(ZeroY(i), "000000.00")
     Print #9, Format(i, "000") & Space(10) & Format(ZeroX(i), "000000.00") & Space(10) & Format(ZeroY(i), "000000.00")
   Next i
   Form2.Label12.Caption = CStr(Format(Ts / Cc, "#######.###")) & "平方米"
   Print #9, "平均面积：", CStr(Format(Ts / Cc, "#######.###")) & "平方米"
  Close (9)
  Form2.Label13.Caption = "所有数据均输入文件：" & OutName$
End Sub
Private Sub Command14_Click()
 Call meuback_Click
End Sub
Private Sub Command2_Click()
  End
End Sub
Private Sub Command13_click()
 End
End Sub

Private Sub Command3_Click()
 If Ddf = "sjw" Then
       Call Command1_Click
      ElseIf Ddf = "dgx" Then
        Call Draw_Dgx(Picture1)
        Call Draw_Dgx(Picture2)
      End If
 Picture1.DrawWidth = 3
  Call DrawZeroLine(Picture1, DeHe)
  Call DrawZeroLine(Picture2, DeHe)
  Picture1.DrawWidth = 1
End Sub

Private Sub Command4_Click()
Dim i%, Deh$
 Deh$ = (InputBox("请输入设计高程", "DesignHeight", "160716"))
 DeHe = Val(Deh$)
 Text8.Text = DeHe
 If Deh$ = "" Then
   Text6.Text = ""
   Text7.Text = ""
   Exit Sub
 End If
 Call JsTwL(DeHe)
End Sub
Private Sub JsTwL(sh As Double)
Dim i%, Fill#, Dig#
 For i = 1 To Cc
     If Volume(i, sh) < 0 Then
      Fill = Fill + Volume(i, sh)
      End If
     If Volume(i, sh) > 0 Then
      Dig = Dig + Volume(i, sh)
      End If
      Text6.Text = Format(Dig, "0.00")
      Text7.Text = Format(-Fill, "0.00")
  Next i
End Sub
Private Sub Command5_Click()
 Dim i%, K%
 Dim Twb$, Tb%, Wb%, Volb#, Con#, Range1#, Range2#, Range0#
 Twb$ = InputBox$("请输入填挖比（格式：X：Y）", "提示", "1:1")
   If Twb = "" Then
   Text8.Text = ""
   Exit Sub
   End If
   K = 1
   Do While Mid$(Twb, K, 1) <> ":"
   K = K + 1
   Loop