sjw.frm

VB建立三角形网

End Sub

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

Private Sub mnuredraw_Click()
Picture1.Picture = LoadPicture()
Picture1.Cls
Picture2.Picture = LoadPicture()
Picture2.Cls
     If Ddf = "sjw" Then
       Call Command1_Click
      ElseIf Ddf = "dgx" Then
        Call Draw_Dgx(Picture1)
        Call Draw_Dgx(Picture2)
      End If
End Sub
Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If My_Command = "fd" Then
         If Button = 1 Then
            MouseX1 = X
            MouseY1 = Y
            Mark = True
            Move_Mark = True
         End If
      End If
  ''''''''''*********** 扫视函数 Pan *************
  If My_Command = "pan" And sh = True Then
    If Button = 1 And My_Count = 1 Then
       MouseX1 = X
       MouseY1 = Y
       Move_Mark = True
       Mark = True
       My_Count = 2
    ElseIf Button = 1 And My_Count = 2 Then
       MouseX2 = X
       MouseY2 = Y
       My_Count = 0
       My_Command = ""
       Move_Mark = False
       DrawStyle = 0
       DrawMode = 13
       Picture1.Scale (CSHx1 - (MouseX2 - MouseX1), CSHy1 - (MouseY2 - MouseY1))-(CSHx2 - (MouseX2 - MouseX1), CSHy2 - (MouseY2 - MouseY1))
       CSHx1 = CSHx1 - (MouseX2 - MouseX1)
       CSHy1 = CSHy1 - (MouseY2 - MouseY1)
       CSHx2 = CSHx2 - (MouseX2 - MouseX1)
       CSHy2 = CSHy2 - (MouseY2 - MouseY1)
       Picture1.Cls
        If Ddf = "sjw" Then
        Call DrawSjw(Picture1, Si1)
      ElseIf Ddf = "dgx" Then
        Call Draw_Dgx(Picture1)
      End If
     End If
  End If
  ''''''''''''''''**************      **************
End Sub

Private Sub picture1_mousemove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  '********************* 放大函数的橡皮筋技术 ******************
  Dim i%, rr#
  Dim Dlt1#, Dlt2#

  If Move_Mark And My_Command = "fd" Then
     Picture1.DrawStyle = 1
     Picture1.DrawMode = 6
     If Mark Then
        MouseX0 = X
        MouseY0 = Y
        Picture1.Line (MouseX1, MouseY1)-(MouseX0, MouseY0), , B
        Mark = False
     Else
        Picture1.Line (MouseX1, MouseY1)-(MouseX0, MouseY0), , B
        MouseX0 = X
        MouseY0 = Y
        Picture1.Line (MouseX1, MouseY1)-(MouseX0, MouseY0), , B
     End If
   End If
   Picture1.DrawStyle = 0
   Picture1.DrawMode = 13
   '****************** 扫视函数 Pan ******************
   If My_Command = "pan" And Move_Mark = True Then
      Picture1.DrawStyle = 1
      Picture1.DrawMode = 6
      If Mark = True Then
        MouseX0 = X
        MouseY0 = Y
        Picture1.Line (MouseX1, MouseY1)-(MouseX0, MouseY0)
        Mark = False
      Else
         Picture1.Line (MouseX1, MouseY1)-(MouseX0, MouseY0)
         MouseX0 = X
         MouseY0 = Y
         Picture1.Line (MouseX1, MouseY1)-(MouseX0, MouseY0)
      End If
    End If
   Picture1.DrawStyle = 0
   Picture1.DrawMode = 13
   Text2.Text = Format(X, "0.00")
   Text3.Text = Format(Y, "0.00")
   For i = 1 To FileLength '
    rr = Sqr((Myd(i).X - X) ^ 2 + (Myd(i).Y - Y) ^ 2)
    If rr <= 9 Then
     Picture1.ToolTipText = "点号：" & Myd(i).No & Chr$(13) & Chr$(10)
     Picture1.ToolTipText = Picture1.ToolTipText & "编码：" & Myd(i).Code & Chr$(13) & Chr$(10)
     Picture1.ToolTipText = Picture1.ToolTipText & "X坐标：" & Myd(i).X & Chr$(13) & Chr$(10)
     Picture1.ToolTipText = Picture1.ToolTipText & "Y坐标：" & Myd(i).Y & Chr$(13) & Chr$(10)
     Picture1.ToolTipText = Picture1.ToolTipText & "高程：" & Myd(i).Z & Chr$(13) & Chr$(10)
    End If
   Next i
   ''''''''**********************漫游
'If My_Command = "fd" And Man = "manyou" And Button = 1 Then
'      If wing = True Then
'       Bzx = X
'       Bzy = Y
'       wing = False
'      Else
'       Dlt1 = (X - Bzx)
'      Dlt2 = (Y - Bzy)
'      Picture1.Scale (Picture1.Left + Dlt1, Picture1.Top + Picture1.height + Dlt2)-(Picture1.Left + Picture1.Width + Dlt1, Picture1.Top + Dlt2)
'      Call DrawSjw(Picture1, si1)
'      End If
'  End If
 
End Sub
Private Sub picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
   '****************** 放大函数 start ****************
   Dim BlyzX#, BlyzY#
   If Button = 1 And My_Command = "fd" Then
      Picture1.DrawMode = 13
      Picture1.DrawStyle = 0
      Picture1.Line (MouseX1, MouseY1)-(X, Y), QBColor(13), B
      MouseX2 = X
     ' Debug.Print MouseX1, MouseY1, X, Y
      MouseY2 = Y
      sh = True
      Move_Mark = False
      My_Command = " "
      BlyzX = Abs(MouseX1 - X) / Picture1.Width
      BlyzY = Abs(MouseY1 - Y) / Picture1.height
      Blyz0 = BlyzX
      If BlyzY > BlyzX Then
         Blyz0 = BlyzY
      End If
      If MouseX1 < X And MouseY1 < Y Then
            Picture1.Scale (MouseX1, MouseY1 + Blyz0 * Picture1.height)-(MouseX1 + Blyz0 * Picture1.Width, MouseY1)
            CSHx1 = MouseX1
            CSHy1 = MouseY1 + Blyz0 * Picture1.height
            CSHx2 = MouseX1 + Blyz0 * Picture1.Width
            CSHy2 = MouseY1
      End If
      If MouseX1 < X And MouseY1 > Y Then
            Picture1.Scale (MouseX1, MouseY1 + Blyz0 * Picture1.height)-(MouseX1 + Blyz0 * Picture1.Width, MouseY1)
            CSHx1 = MouseX1
            CSHy1 = MouseY1
            CSHx2 = MouseX1 + Blyz0 * Picture1.Width
            CSHy2 = MouseY1 + Blyz0 * Picture1.height
      End If
      If X < MouseX1 Then
           MsgBox "选点的顺序错误，请重选！"
           My_Command = ""
      End If
      Picture1.Cls
      If Ddf = "sjw" Then
        Call DrawSjw(Picture1, Si1)
      ElseIf Ddf = "dgx" Then
        Call Draw_Dgx(Picture1)
      End If
    End If
    ''******************** 放大函数 end ******************
 End Sub
Private Sub Font_Click()
  CommonDialog1.CancelError = True
  On Error GoTo errhandler
  CommonDialog1.Flags = cdlCFBoth Or cdlCFEffects
  CommonDialog1.ShowFont
  Picture1.FontName = CommonDialog1.FontName
  Picture1.FontSize = CommonDialog1.FontSize
  Picture1.FontBold = CommonDialog1.FontBold
  Picture1.FontItalic = CommonDialog1.FontItalic
  Picture1.FontUnderline = CommonDialog1.FontUnderline
  Picture1.FontStrikethru = CommonDialog1.FontStrikethru
  Picture1.ForeColor = CommonDialog1.ForeColor
  Exit Sub
errhandler:
  Exit Sub
End Sub

Private Sub open_Click()
  On Error GoTo errhandler
  CommonDialog1.Filter = "All file (*.*)|*.*|Text file (*.txt)|*.txt|Bmp file (*.bmp)|*.bmp|Icon file(*.ico)|*.ico"
  CommonDialog1.FilterIndex = 3
  CommonDialog1.ShowOpen
  Picture1.Picture = LoadPicture(CommonDialog1.FileName)
  Exit Sub
errhandler:
  Exit Sub
End Sub
Private Sub Picture2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
   Picture2.MousePointer = 2
   Picture2.DrawMode = 6
   If Rad = True Then
     x00 = X
     y00 = Y
     Picture2.Circle (X, Y), 60, QBColor(10)
     Rad = False
   Bzz = 2
   Else
    Picture2.Circle (x00, y00), 60, QBColor(10)
    x00 = X
    y00 = Y
    Picture2.Circle (x00, y00), 60, QBColor(10)
   End If
   Picture2.DrawMode = 13
End Sub

Private Sub Picture2_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
   Picture1.Scale (x00 - 100, y00 + 100)-(x00 + 100, y00 - 100)
   If Ddf = "sjw" Then
    Call DrawSjw(Picture1, Si1)
    ElseIf Ddf = "dgx" Then
    Call Draw_Dgx(Picture1)
    End If
End Sub

Private Sub SAVE_Click()
  On Error GoTo errhandler
  CommonDialog1.Filter = "All file (*.*)|*.*|Text file (*.txt)|*.txt|Bmp file (*.bmp)|*.bmp|Icon file(*.ico)|*.ico"
  CommonDialog1.FilterIndex = 3
  CommonDialog1.ShowSave
  SavePicture Picture1.Image, CommonDialog1.FileName
  Exit Sub
errhandler:
  Exit Sub
End Sub

Private Sub color_Click()
   CommonDialog1.CancelError = True
   On Error GoTo errhandler
   CommonDialog1.Flags = cdlCCRGBInit
   CommonDialog1.ShowColor
   Picture1.ForeColor = CommonDialog1.COLOR
   Exit Sub
errhandler:
   Exit Sub
   Call mnuredraw_Click
End Sub
Private Function Volume(Scode As Integer, designheight As Double)
  Volume = Pl(Scode) * (Av(Scode) - designheight) / 1000#
End Function
  Private Function Areas(p1%, p2%, p3%) As Double
    Dim A#, B#, C#, E#
    A = Sqr((Myd(p1).X - Myd(p2).X) ^ 2 + (Myd(p1).Y - Myd(p2).Y) ^ 2)
    B = Sqr((Myd(p2).X - Myd(p3).X) ^ 2 + (Myd(p2).Y - Myd(p3).Y) ^ 2)
    C = Sqr((Myd(p1).X - Myd(p3).X) ^ 2 + (Myd(p1).Y - Myd(p3).Y) ^ 2)
    E = (A + B + C) / 2#
    Areas = Sqr((E - A) * (E - B) * (E - C) * E)
  End Function
''''''''''''************************* 以下为等高线的形成部分 ******************************'''''''
''''''''''''''''********判断一边是否与高程 Z 有交点************'''''''''''''''''''''
Function PDXJ(No_Bian%, Z#)
  Dim Z1#, Z2#, Dz#
  Z1 = Myd(Le(No_Bian).Start).Z
  Z2 = Myd(Le(No_Bian).Last).Z
  Dz = (Z - Z1) * (Z - Z2)
  If Dz > 0 Then
    PDXJ = 0
  ElseIf Dz <= 0 Then
    PDXJ = 2
  End If
End Function
'''''''''''''''************求交点*********************""""""""""""""""'''
Sub QqJj(No_Bian%, Z#, X#, Y#)
  Dim Xz1#, Yz1#, Xz2#, Yz2#, Z1#, Z2#
  Xz1 = Myd(Le(No_Bian).Start).X
  Yz1 = Myd(Le(No_Bian).Start).Y
  Xz2 = Myd(Le(No_Bian).Last).X
  Yz2 = Myd(Le(No_Bian).Last).Y
  Z1 = Myd(Le(No_Bian).Start).Z
  Z2 = Myd(Le(No_Bian).Last).Z
  X = Xz1 + (Xz2 - Xz1) / (Z2 - Z1) * (Z - Z1)
  Y = Yz1 + (Yz2 - Yz1) / (Z2 - Z1) * (Z - Z1)
End Sub
'''''''''''''''追踪等到高线'''''''''''''
Sub ZZDGX(Between#)
   Dim i%, S1%, S2%, S3%, Z1#, Z2#, Dt#, K%, Z#
   Picture1.DrawStyle = 0
   K = 0
   For i = 1 To Cc
     S1 = Triangle(i).B1
     S2 = Triangle(i).B2
     S3 = Triangle(i).B3
     Z1 = Myd(Le(S1).Start).Z
     Z2 = Myd(Le(S1).Last).Z
     If Z1 > Z2 Then
       Dt = Z1
       Z1 = Z2
       Z2 = Dt
     End If
     Z = Z1 - (Z1 Mod Between) + Between
     Do While (Z <= Z2)
       Call QqJj(S1, Z, A(K).x1, A(K).y1)
       If PDXJ(S2, Z) = 2 Then
          Call QqJj(S2, Z, A(K).x2, A(K).y2)
       ElseIf PDXJ(S3, Z) = 2 Then
          Call QqJj(S3, Z, A(K).x2, A(K).y2)
       End If
       K = K + 1
       Z = Z + Between
     Loop
     Z1 = Myd(Le(S2).Start).Z
     Z2 = Myd(Le(S2).Last).Z
     If Z1 > Z2 Then
       Dt = Z1
       Z1 = Z2
       Z2 = Dt
     End If
     Z = Z1 - (Z1 Mod Between) + Between
     Do While (Z <= Z2)
       If PDXJ(S3, Z) = 2 Then
         Call QqJj(S2, Z, A(K).x1, A(K).y1)
         Call QqJj(S3, Z, A(K).x2, A(K).y2)
         K = K + 1
       End If
       Z = Z + Between
     Loop
     Num_Dgx = K - 1
   Next i
   Picture1.Cls
   For i = 0 To Num_Dgx
     Picture1.Line (A(i).x1, A(i).y1)-(A(i).x2, A(i).y2)
   Next i
  
End Sub
Sub Draw_Dgx(Object As PictureBox)
  Dim i%
  Object.Cls
  For i = 0 To Num_Dgx
    Object.Line (A(i).x1, A(i).y1)-(A(i).x2, A(i).y2)
  Next i
  For i = 1 To Cc
   If Le(i).Lef = -1 Or Le(i).Rig = -1 Then
     'Object.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
End Sub
Private Sub DrawZeroLine(Object As PictureBox, hh As Double)
  Dim i%, S1%, S2%, S3%, Z1#, Z2#, Dt#, K%, Z#, DE%
  Dim Z3#, Z4#, x1#, x2#, y1#, y2#, tt%
   Picture1.DrawStyle = 0
   K = 0
   Vv = 0
   For i = 1 To Cc
     S1 = Triangle(i).B1
     S2 = Triangle(i).B2
     S3 = Triangle(i).B3
     Z1 = Myd(Le(S1).Start).Z
     Z2 = Myd(Le(S1).Last).Z
     If Z1 > Z2 Then
       Dt = Z1
       Z1 = Z2
       Z2 = Dt
     End If
     Z3 = Myd(Le(S2).Start).Z
     Z4 = Myd(Le(S2).Last).Z
     If Z3 > Z4 Then
       Dt = Z3
       Z3 = Z4
       Z4 = Dt
     End If
     If hh >= Z1 And hh <= Z2 Or hh >= Z3 And hh <= Z4 Then
          If hh >= Z1 And hh <= Z2 Then
            Call QqJj(S1, hh, x1, y1)
            If hh >= Z3 And hh <= Z4 Then
              Call QqJj(S2, hh, x2, y2)
            Else
              Call QqJj(S3, hh, x2, y2)
            End If
          Else
            Call QqJj(S2, hh, x1, y1)
            Call QqJj(S3, hh, x2, y2)
          End If
        Object.Line (x1, y1)-(x2, y2), RGB(255, 0, 0)
            tt = tt + 1
            ZeroStartX(tt) = x1
            ZeroStartY(tt) = y1
            ZeroLastX(tt) = x2
            ZerolastY(tt) = y2
            Vv = Vv + 1
            ZeroX(Vv) = x1
            ZeroY(Vv) = y1
             For DE = 1 To Vv - 1
               If ZeroX(DE) = ZeroX(Vv) And ZeroY(DE) = ZeroY(Vv) Then
                 Vv = Vv - 1
               End If
             Next DE
            Vv = Vv + 1
            ZeroX(Vv) = x2
            ZeroY(Vv) = y2
            For DE = 1 To Vv - 1
               If ZeroX(DE) = ZeroX(Vv) And ZeroY(DE) = ZeroY(Vv) Then
                 Vv = Vv - 1
               End If
            Next DE
     End If
  Next i
  Zn = tt
End Sub
Public Sub Fill(X As Long, Y As Long, Obj As PictureBox, FColor As Long)
    ' Obj.ScaleMode = vbPixels        ' Windows 用像素画.
     Obj.ForeColor = vbBlack     ' 设置画的线为黑色.
     Obj.FillStyle = vbFSSolid    ' 设置 FillStyle 为实线.
     Obj.FillColor = FColor ' 设置 FillColor.
   ' 调用 Windows API 填充.
    FloodFill Obj.hDC, X, Y, Obj.ForeColor
  Obj.Scale (minX, minY + Picture1.height * Si1)-(minX + Picture1.Width * Si1, minY)
End Sub