frmareacaculate.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 frmAreaCaculate 
   Caption         =   "通过坐标计算多边形面积"
   ClientHeight    =   5025
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   6270
   LinkTopic       =   "Form1"
   ScaleHeight     =   5025
   ScaleWidth      =   6270
   StartUpPosition =   3  'Windows Default
   Begin MSComDlg.CommonDialog CommonDialog 
      Left            =   4200
      Top             =   0
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.TextBox txtArea 
      Height          =   375
      Left            =   3960
      TabIndex        =   5
      Top             =   4560
      Width           =   1575
   End
   Begin VB.CommandButton cmdAreaCaculate 
      Caption         =   "面积计算"
      Height          =   375
      Left            =   2280
      TabIndex        =   3
      Top             =   4560
      Width           =   1095
   End
   Begin VB.CommandButton cmdExcelImportData 
      Caption         =   "从Excel中导入坐标数据"
      Height          =   375
      Left            =   120
      TabIndex        =   2
      Top             =   4560
      Width           =   2055
   End
   Begin MSFlexGridLib.MSFlexGrid MSFlexGrid 
      Height          =   3975
      Left            =   120
      TabIndex        =   0
      Top             =   480
      Width           =   6135
      _ExtentX        =   10821
      _ExtentY        =   7011
      _Version        =   393216
   End
   Begin VB.Label Label3 
      AutoSize        =   -1  'True
      Caption         =   "平方米"
      Height          =   195
      Left            =   5640
      TabIndex        =   6
      Top             =   4680
      Width           =   540
   End
   Begin VB.Label Label2 
      AutoSize        =   -1  'True
      Caption         =   "面积："
      Height          =   195
      Left            =   3480
      TabIndex        =   4
      Top             =   4680
      Width           =   540
   End
   Begin VB.Label Label1 
      BackColor       =   &H80000000&
      Caption         =   "请在下面组框中输入点号、X坐标和Y坐标注意：输入的时候按某个方向依次输入!!"
      Height          =   375
      Left            =   120
      TabIndex        =   1
      Top             =   0
      Width           =   3375
   End
End
Attribute VB_Name = "frmAreaCaculate"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim dataX() As Double
Dim dataY() As Double
Dim pointName() As String

Private Sub cmdAreaCaculate_Click()
    Dim X() As Double
    Dim Y() As Double
    Dim dY() As Double
    Dim i, j As Integer
    Dim RCount As Integer
    Dim CCount As Integer
    
    Dim s As Double
    s = 0#
    
    RCount = MSFlexGrid.Rows
    CCount = MSFlexGrid.Cols
    ReDim X(RCount - 2)
    ReDim Y(RCount - 2)
    ReDim dY(RCount - 2)
    
    For i = 0 To RCount - 2
        With MSFlexGrid
            .Row = i + 1
            .Col = 1
            X(i) = Val(.Text)
            .Col = 2
            Y(i) = Val(.Text)
        End With
    Next i
    
    For i = 0 To RCount - 2
        If i = 0 Then
            dY(i) = Y(1) - Y(RCount - 2)
        ElseIf i = RCount - 2 Then
            dY(i) = Y(0) - Y(RCount - 3)
        Else
            dY(i) = Y(i + 1) - Y(i - 1)
        End If
    Next i
    
    For i = 0 To RCount - 2
        s = s + X(i) * dY(i)
    Next i
    s = s / 2
    
    txtArea.Text = Format(s, "0#.00")
End Sub

Private Sub cmdExcelImportData_Click()
    Dim xlapp As New Excel.Application
    Dim xlbook  As Excel.Workbook
    Dim xlsheet As Excel.Worksheet
    Dim strFilePathName As String
    Dim rowCount As Integer
    Dim i, j As Integer
    Dim ElsErr As Label
        
    CommonDialog.InitDir = App.Path
    CommonDialog.Action = 1
    strFilePathName = CommonDialog.FileName
    '如果选择了取消按钮，则退出该操作
    CommonDialog.CancelError = False
    On Error GoTo ErrHandler
          
    xlapp.Workbooks.Open strFilePathName
    xlapp.Visible = False
    Set xlbook = xlapp.Workbooks(1)
    Set xlsheet = xlbook.Worksheets(1)
    
    rowCount = xlapp.ActiveSheet.UsedRange.Rows.Count
    MSFlexGrid.Rows = rowCount
    ReDim dataX(rowCount)
    ReDim dataY(rowCount)
    ReDim pointName(rowCount)
    
    For i = 2 To rowCount
        For j = 1 To 3
            MSFlexGrid.Row = i - 1
            MSFlexGrid.Col = j - 1
            MSFlexGrid.ColAlignment(j - 1) = 4
            MSFlexGrid.Text = xlsheet.Cells(i, j)
            If j = 1 Then
                pointName(i - 2) = xlsheet.Cells(i, j)
            ElseIf j = 2 Then
                dataX(i - 2) = Val(xlsheet.Cells(i, j))
            Else
                dataY(i - 2) = Val(xlsheet.Cells(i, j))
            End If
        Next j
    Next i
    
    xlapp.Workbooks.Close
    
    Set xlsheet = Nothing
    Set xlbook = Nothing
    Set xlapp = Nothing
ErrHandler:
    Exit Sub
End Sub

Private Sub Form_Load()
    MSFlexGrid.Cols = 3
    MSFlexGrid.Redraw = True
    With MSFlexGrid
        .ColWidth(0) = (MSFlexGrid.Width - 100) / 3
        .ColWidth(1) = (MSFlexGrid.Width - 100) / 3
        .ColWidth(2) = (MSFlexGrid.Width - 100) / 3
    End With
    With MSFlexGrid
        .Row = 0
        .Col = 0
        .ColAlignment(0) = 4
        .Text = "点名"
        .Col = 1
        .ColAlignment(1) = 4
        .Text = "X坐标"
        .Col = 2
        .ColAlignment(2) = 4
        .Text = "Y坐标"
    End With
End Sub