三角高.frm

三角高计算

VERSION 5.00
Object = "{5E9E78A0-531B-11CF-91F6-C2863C385E30}#1.0#0"; "MSFLXGRD.OCX"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form sjg 
   Caption         =   "三角高"
   ClientHeight    =   6405
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   14805
   LinkTopic       =   "Form1"
   ScaleHeight     =   6405
   ScaleWidth      =   14805
   StartUpPosition =   3  '窗口缺省
   Begin VB.Frame Frame2 
      Caption         =   "说明："
      Height          =   6015
      Left            =   9240
      TabIndex        =   6
      Top             =   120
      Width           =   5415
      Begin VB.PictureBox Picture1 
         BorderStyle     =   0  'None
         Height          =   3855
         Left            =   240
         Picture         =   "三角高.frx":0000
         ScaleHeight     =   3855
         ScaleWidth      =   5055
         TabIndex        =   8
         Top             =   2040
         Width           =   5055
      End
      Begin VB.Label Label1 
         Caption         =   $"三角高.frx":0B0A
         Height          =   1575
         Left            =   120
         TabIndex        =   7
         Top             =   240
         Width           =   5175
      End
   End
   Begin VB.CommandButton Command3 
      Caption         =   "退 出"
      Height          =   495
      Left            =   6480
      TabIndex        =   5
      Top             =   5640
      Width           =   1815
   End
   Begin MSComDlg.CommonDialog CDg1 
      Left            =   6000
      Top             =   4560
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.TextBox Txt 
      Height          =   270
      Left            =   7680
      TabIndex        =   4
      Text            =   "Text2"
      Top             =   3720
      Width           =   975
   End
   Begin VB.CommandButton Command2 
      Caption         =   "成果输出"
      Height          =   495
      Left            =   3540
      TabIndex        =   3
      Top             =   5640
      Width           =   1815
   End
   Begin VB.CommandButton Command1 
      Caption         =   "计 算"
      Height          =   495
      Left            =   600
      TabIndex        =   2
      Top             =   5640
      Width           =   1815
   End
   Begin VB.TextBox Text1 
      Height          =   270
      Left            =   1560
      TabIndex        =   1
      Text            =   "Text1"
      Top             =   2400
      Width           =   975
   End
   Begin MSFlexGridLib.MSFlexGrid MSFlexGrid1 
      Height          =   4695
      Left            =   0
      TabIndex        =   0
      Top             =   840
      Width           =   9135
      _ExtentX        =   16113
      _ExtentY        =   8281
      _Version        =   393216
   End
   Begin VB.Label Label2 
      AutoSize        =   -1  'True
      Caption         =   "三角高计算表"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   15.75
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   315
      Left            =   3600
      TabIndex        =   9
      Top             =   240
      Width           =   1890
   End
End
Attribute VB_Name = "sjg"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private OldText As String
Private ColSelect() As Boolean
Private SaveCellBkColor As Long
Dim shu(100, 8) As Double


Const pi = 3.141592654




Private Sub Command1_Click()
Dim L, i, j As Integer
'Dim cc As Single, px As Single, t As Single

'L = Val(Text3.Text): cc = Val(Text4.Text): px = Val(Text6.Text): t = Val(Text5.Text)

For i = 1 To 100

    For j = 1 To 7
       MSFlexGrid1.Row = i
       MSFlexGrid1.Col = j
       
       
       shu(i, j) = Val(MSFlexGrid1.Text)
       
       
            
    Next j
    
    
    If MSFlexGrid1.Text = "" Then
       
       Exit For
             
    End If
    shu(i, 4) = DEG(shu(i, 4)) * pi / 180
    shu(i, 7) = DEG(shu(i, 7)) * pi / 180
    
    
    'shu(i, 8) = shu(i, 1) - shu(i, 5) - shu(i, 4): shu(i, 8) = Format(shu(i, 8), "####.##0")
    'hAB=(d2sinα2-d1sinα1)+((1-K)/(2R))*(d2*d2-d1*d1)-v2+v1
    shu(i, 8) = (shu(i, 6) * Sin(shu(i, 7)) - shu(i, 3) * Sin(shu(i, 4))) + ((1 - 0.13) / (2 * 6371000)) * (shu(i, 6) * shu(i, 6) - shu(i, 3) * shu(i, 3)) - shu(i, 5) + shu(i, 2)
    shu(i, 8) = Format(shu(i, 8), "0.0000")
    MSFlexGrid1.TextMatrix(i, 8) = Str(shu(i, 8))
    
Next i


    
End Sub

Private Sub Command2_Click()
Txt.Text = ""
Dim i, j As Integer
Dim strfilename As String

For i = 0 To MSFlexGrid1.Rows - 1
MSFlexGrid1.Row = i
   For j = 0 To MSFlexGrid1.Cols - 1
   MSFlexGrid1.Col = j
     If IsNull(MSFlexGrid1.Text) = False Then
     'xlSheet.Cells(i + 7, j + 1) = MSFlexGrid1.Text
     If i = 0 Then
        Txt.Text = Txt.Text & MSFlexGrid1.Text & "  "
        Else
        Txt.Text = Txt.Text & MSFlexGrid1.Text & "   "
     End If
     End If
     
   Next j
   If MSFlexGrid1.Text = "" Then
       
       Exit For
             
    End If
   Txt.Text = Txt.Text & vbCrLf
Next i

CDg1.Filter = "文本文件（*.txt）|*.txt|所有文件（*.*）|*.*"
    CDg1.ShowSave
    strfilename = CDg1.FileName
    If strfilename = "" Then Exit Sub
    
    Open strfilename For Output As #1
    Print #1, Txt.Text
    
    Close #1
Exit Sub
End Sub

Private Sub Command3_Click()
Unload Me

End Sub

Private Sub Form_Load()
Txt.Visible = False
Text1.Visible = False
Me.Show
With MSFlexGrid1
     .Cols = 9
     .Rows = 101
     ReDim ColSelect(1 To .Cols - 1)
     SaveCellBkColor = .CellBackColor
     Call InitGrid
     .AllowBigSelection = True
     .FillStyle = flexFillRepeat
     '.AllowUserResizing = True  '请事先设好
End With
MSFlexGrid1.TextMatrix(0, 1) = "测段"
MSFlexGrid1.TextMatrix(0, 2) = "后目标高"
MSFlexGrid1.TextMatrix(0, 3) = "后斜距"
MSFlexGrid1.TextMatrix(0, 4) = "后竖直角"
MSFlexGrid1.TextMatrix(0, 5) = "前目标高"
MSFlexGrid1.TextMatrix(0, 6) = "前斜距"
MSFlexGrid1.TextMatrix(0, 7) = "前竖直角"
MSFlexGrid1.TextMatrix(0, 8) = "高差"
'MSFlexGrid1.CellWidth = 10

End Sub

Private Sub InitGrid()
Dim i As Long
With MSFlexGrid1
  .Row = 0
  For i = 1 To .Cols - 1
      .Col = i: .Text = "Col" + Format(i, "00") '若Cols超出99，则修改Format
  Next                      '的格式
End With
With MSFlexGrid1
  .Col = 0
  For i = 1 To .Rows - 1
      .Row = i: .Text = i
  Next
End With
'Dim width5 As Long
'With MSFlexGrid1
'     width5 = .Width \ .Cols
'    For i = 0 To .Cols - 1
'         .ColWidth(i) = width5
'     Next
'End With
End Sub
Private Sub MSFlexGrid1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim inMostLeft As Boolean
Dim inMostTop As Boolean

Call ProcMultiColSel(Shift)
With MSFlexGrid1
     If Button = vbKeyRButton Then
    '按mouse 右键且位於最上列/最左行则是更动title
    If .MouseCol = 0 Or .MouseRow = 0 Then
       Call toEditGrid(.MouseCol, .MouseRow)
    End If
     Else
    If Button = vbKeyLButton Then
       If .ColSel = .Col And .RowSel = .Row Then
       '表示没有多个栏位的选取，这时才真正是可以输入
         Call toEditGrid(.Col, .Row)
       End If
    End If
     End If
End With
End Sub
Private Sub MSFlexGrid1_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyReturn And Not Text1.Visible Then
   With MSFlexGrid1
    Call toEditGrid(.Col, .Row)
   End With
End If
End Sub
'TextBox上的输入反映到MsFlexGrid上
Private Sub Text1_Change()
MSFlexGrid1.Text = Text1.Text
End Sub
'按下Down/Up 时结束TextBox的Keyin
Private Sub Text1_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyUp Then
   Text1.Visible = False
   MSFlexGrid1.SetFocus
   SendKeys "{up}"
Else
  If KeyCode = vbKeyDown Then
     Text1.Visible = False
     MSFlexGrid1.SetFocus
     SendKeys "{down}"
  End If
End If
End Sub
Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii = vbKeyReturn Then
   KeyAscii = 0
   Text1.Visible = False
   MSFlexGrid1.SetFocus
End If
If KeyAscii = vbKeyEscape Then
   KeyAscii = 0
   MSFlexGrid1.Text = OldText
   Text1.Visible = False
   MSFlexGrid1.SetFocus
End If
End Sub

Private Sub Text1_LostFocus()
Text1.Visible = False
End Sub
'设定TextBox於MSFlexGrid1的Current Cell上
Private Sub toEditGrid(ByVal C As Integer, ByVal R As Integer)
With MSFlexGrid1
   .Col = C: .Row = R
   Text1.Left = .Left + .ColPos(C)
   Text1.Top = .Top + .RowPos(R)
   If .Appearance = flex3D Then
      Text1.Left = Text1.Left + 2 * Screen.TwipsPerPixelX
      Text1.Top = Text1.Top + 2 * Screen.TwipsPerPixelY
   End If
   Text1.Width = .ColWidth(C)
   Text1.Height = .RowHeight(R)
   Text1.Text = .Text
   OldText = .Text
End With
Text1.Visible = True
Text1.SelStart = Len(Text1.Text)
Text1.SetFocus
End Sub
'以下程式处理Multi-column Selection的问题
Private Sub ProcMultiColSel(ByVal Shift As Integer)
Dim i As Long, HaveSel As Boolean
Dim SelSt As Long, SelEnd As Long
Dim OldRowSel As Long, OldColSel As Long
With MSFlexGrid1
OldRowSel = .RowSel: OldColSel = .ColSel
If HaveSelEntireCol Then
   '如果有整行被选取的清况，则计算选取的起始结束行
   SelSt = IIf(.Col <= .ColSel, .Col, .ColSel)
   SelEnd = IIf(.Col > .ColSel, .Col, .ColSel)
   For i = SelSt To SelEnd
       ColSelect(i) = True
   Next
   .CellBackColor = .BackColorSel
   If Shift <> vbCtrlMask Then '没有按Ctl键则清除其他Column的Selection
      Call RefreshCols(SelSt, SelEnd)
   End If
Else
   HaveSel = False
   For i = 1 To .Cols - 1
       HaveSel = HaveSel Or ColSelect(i)
   Next
   If HaveSel Then
      Call RefreshAll
   End If
End If
.RowSel = OldRowSel
.ColSel = OldColSel
End With
End Sub
'Check是否有整行的选取
Private Function HaveSelEntireCol() As Boolean
With MSFlexGrid1
If .RowSel = (.Rows - 1) And .Row = 1 Then
   HaveSelEntireCol = True
Else
   HaveSelEntireCol = False
End If
End With
End Function
'清除所有的Selection
Private Sub RefreshAll()
Dim SaveCol As Long, SaveRow As Long, i As Long
With MSFlexGrid1
    SaveCol = .Col: SaveRow = .Row
    .Col = 1: .Row = 1
    .ColSel = .Cols - 1: .RowSel = .Rows - 1
     MSFlexGrid1.CellBackColor = SaveCellBkColor
    .Col = SaveCol: .Row = SaveRow
    .ColSel = SaveCol: .RowSel = SaveRow
    For i = 1 To .Cols - 1
    ColSelect(i) = False
    Next
End With
End Sub
'清除其他Column的Selection除了columns From Selst to SelEnd外，其他清除
Private Sub RefreshCols(ByVal SelSt As Long, ByVal SelEnd As Long)
Dim SaveCol As Long, SaveRow As Long, i As Long
With MSFlexGrid1
   SaveCol = .Col: SaveRow = .Row
   For i = 1 To .Cols - 1
      If Not (i >= SelSt And i <= SelEnd) And ColSelect(i) Then
    .Col = i: .Row = 1
    .ColSel = i: .RowSel = .Rows - 1
    MSFlexGrid1.CellBackColor = SaveCellBkColor
    ColSelect(i) = False
      End If
   Next
   .Col = SaveCol: .Row = SaveRow
   .ColSel = SaveCol: .RowSel = SaveRow
End With
End Sub

Private Sub MSFlexGrid1_Scroll()
SendKeys "{ESC}"
End Sub
Function DEG(de As Double) As Double
Dim sign As Double, d1 As Double, d2 As Double, d3 As Double
sign = Sgn(de)
de = Abs(de)
d1 = Int(de)
d2 = Int((de - d1) * 100)
d3 = de - d1 - d2 / 100
DEG = sign * (d1 + d2 / 60 + d3 / 0.36)
End Function