drawcontour.frm

生成等高线

         Height          =   285
         Index           =   0
         Left            =   960
         TabIndex        =   9
         Text            =   "0"
         Top             =   600
         Width           =   735
      End
      Begin VB.TextBox Slope 
         Height          =   285
         Index           =   0
         Left            =   960
         TabIndex        =   8
         Text            =   "1"
         Top             =   240
         Width           =   735
      End
      Begin VB.Label Label5 
         Caption         =   "Intercept"
         Height          =   255
         Index           =   0
         Left            =   120
         TabIndex        =   11
         Top             =   600
         Width           =   855
      End
      Begin VB.Label Label4 
         Caption         =   "slope"
         Height          =   255
         Index           =   0
         Left            =   240
         TabIndex        =   10
         Top             =   360
         Width           =   615
      End
   End
   Begin VB.Frame Frame3 
      Caption         =   "Line Values"
      Height          =   735
      Left            =   240
      TabIndex        =   4
      Top             =   4920
      Width           =   2535
      Begin VB.OptionButton Option2 
         Caption         =   "Uneven"
         Height          =   255
         Index           =   1
         Left            =   1320
         TabIndex        =   6
         Top             =   240
         Width           =   1095
      End
      Begin VB.OptionButton Option2 
         Caption         =   "Even"
         Height          =   375
         Index           =   0
         Left            =   120
         TabIndex        =   5
         Top             =   240
         Value           =   -1  'True
         Width           =   975
      End
   End
   Begin VB.PictureBox Picture2 
      Height          =   4815
      Left            =   6240
      ScaleHeight     =   4755
      ScaleWidth      =   5235
      TabIndex        =   3
      Top             =   120
      Width           =   5295
   End
   Begin VB.CommandButton Command2 
      Caption         =   "Add Labels"
      Height          =   375
      Left            =   4800
      TabIndex        =   2
      Top             =   5160
      Width           =   1215
   End
   Begin VB.PictureBox Picture1 
      Height          =   4695
      Left            =   240
      ScaleHeight     =   309
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   373
      TabIndex        =   1
      Top             =   120
      Width           =   5655
   End
   Begin CONTOUROCXLib.ContourOCX ContourOCX1 
      Height          =   735
      Left            =   5400
      TabIndex        =   0
      Top             =   4320
      Visible         =   0   'False
      Width           =   1335
      _Version        =   65536
      _ExtentX        =   2355
      _ExtentY        =   1296
      _StockProps     =   0
   End
   Begin VB.Label Label3 
      Caption         =   "Line Value Step"
      Height          =   495
      Left            =   3120
      TabIndex        =   28
      Top             =   5160
      Width           =   855
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim SelectedIndex As Integer
Dim LineValueType As Integer
Dim RandomMethod As Integer
Dim Source As Integer

Private Sub DrawLines()
Dim LineCount As Long
Dim pointCount As Long

Dim PreX As Double, PreY As Double, CurX As Double, CurY As Double, z As Double

ContourOCX1.GetLineCount LineCount
For i = 0 To LineCount - 1 Step 1
 ContourOCX1.GetCtrlPointCount i, pointCount
 For j = 0 To pointCount - 1
ContourOCX1.GetCtrlPoint i, j, CurX, CurY, z


If j > 0 Then Picture1.Line (PreX, PreY)-(CurX, CurY), 3883
PreX = CurX
PreY = CurY
 Next
 Next
End Sub
Private Sub Command1_Click()
Picture1.Cls
' free memory
ContourOCX1.FreeData
Dim i As Long, j As Long, row As Long, col As Long
Dim step As Single '等值线间隔
Dim INVALIDDATA As Long  '默认无效值
INVALIDDATA = 99999
Dim X As Double, Y As Double, value As Double   '实际坐标
row = CInt(Val(RowEdit.Text))
col = CInt(Val(ColEdit.Text))
linestep = Val(StepEdit.Text)
'initialize
ContourOCX1.Initial row, col, linestep, InterposeCheck.value, RestrictCheck.value
'ContourOCX1.Initial row, col, Linestep '行数，列数，等值线间隔

'Uneven line values
If (LineValueType > 0) Then


ContourOCX1.AddCustomedStep 5    '生成值为5的等值线
ContourOCX1.AddCustomedStep 4.5  '生成值为5的等值线
ContourOCX1.AddCustomedStep 1   '生成值为1的等值线
End If
'input data points
For i = 0 To row - 1 Step 1
For j = 0 To col - 1 Step 1
 X = j * 50  '由列号得出横坐标
 Y = i * 50 '由行号得出纵坐标
 value = Rnd(100) * 10
 
 ContourOCX1.AddPoint i, j, X, Y, value '行号，列号，坐标（X，Y），值（高程）
Next
Next


' if there are some invalid data
'ContourOCX1.AddPoint 3, 2, 100, 150, INVALIDDATA '假如（3，2）处为无效点
'ContourOCX1.AddPoint 3, 3, 150, 150, INVALIDDATA '假如（3，3）处为无效点


'there are 3 methods to create contour

Select Case SelectedIndex

Case 0: ContourOCX1.Calculate 1, INVALIDDATA
Case 1: ContourOCX1.calculate2 True, INVALIDDATA, 1  '是否要对无效值进行重新插补， 无效值
Case 2: ContourOCX1.Calculate3 True, INVALIDDATA, 20   '是否要对无效值进行重新插补， 无效值
End Select


'''''''''''''''''''''''''''''
Call DrawLines
 
 '如果要释放空间
' ContourOCX1.FreeData
End Sub

Private Sub Command2_Click()
Dim LineCount As Long, pointCount As Long

Dim X As Double, Y As Double, value As Double
ContourOCX1.GetLineCount LineCount ' Total line count

For i = 0 To LineCount - 1
ContourOCX1.GetCtrlPointCount i, pointCount ' get count of points in one line
ContourOCX1.GetCtrlPoint i, Int((pointCount - 1) / 2), X, Y, value 'get the  middle point in one line

Picture1.CurrentX = X
Picture1.CurrentY = Y
Picture1.Print value
Next

End Sub
Private Function validateData(value As Single) As Integer
 If (value < 0) Then
  validateData = 0
 Else
  If value > 255 Then
   validateData = 255
  Else
   validateData = CInt(value)
  End If
  
 End If
 
End Function
Private Sub Command3_Click()
Dim suc As Long
Dim PolygonCount As Long, pointCount As Long
 Dim minVal As Single, maxVal As Single, Area1 As Single, Area2 As Single
ContourOCX1.ConvertToPolygon suc



If suc > 0 Then

 ContourOCX1.ResetPolyPostion Val(Slope(0).Text), Val(Intercept(0).Text), Val(Slope(1).Text), Val(Intercept(1).Text)
 ContourOCX1.GetPolygonCount PolygonCount
 List1.Clear
 'set color by value
 For i = 0 To PolygonCount - 1
  
  ContourOCX1.GetPolygonPointCountValueArea i, pointCount, minVal, maxVal, Area1, Area2
  ContourOCX1.ResetOnePolygonColor i, validateData(minVal * 20), 255 - validateData(minVal * 20)
  List1.AddItem i
 Next
 
 'draw
 ContourOCX1.DrawAllPolygons Picture2.hDC
Else
 MsgBox "conversion failed!"
End If

End Sub

Private Sub Command4_Click()
ContourOCX1.ResetPolyPostion Val(Slope(0).Text), Val(Intercept(0).Text), Val(Slope(1).Text), Val(Intercept(1).Text)
End Sub

Private Sub Command5_Click()
ContourOCX1.DrawAllPolygons Picture2.hDC
Call DrawLines
End Sub

Private Sub Command6_Click()
Picture1.Cls
ContourOCX1.FreeData
Dim Smooth As Integer, linestep As Single
Smooth = Val(SmoothEdit.Text)
linestep = Val(StepEdit.Text)

Select Case RandomMethod

Case 0: ContourOCX1.InitialRandomIIDW -1, -1, linestep, Smooth
Case 1: ContourOCX1.InitialRandomCFWAI -1, linestep, Smooth
Case 2: ContourOCX1.InitialRandomKrigingOK -1, 30, 1, 2, -1  ' ordinary Kriging ,linear model ,nugget=0
End Select
'Uneven line values
If (LineValueType > 0) Then


ContourOCX1.AddCustomedStep 5    '生成值为5的等值线
ContourOCX1.AddCustomedStep 4.5  '生成值为5的等值线
ContourOCX1.AddCustomedStep 1   '生成值为1的等值线
End If
'data source
Select Case Source
Case 1:
    Dim count As Long
    Dim path As String
    path = App.path + "\1.txt"
    count = ContourOCX1.AddRandomPointsFromFile(path)
Case 0:
    For i = 0 To Int(RandomPointCount.Text)
    X = Rnd() * 300
    Y = Rnd() * 300
    value = Rnd() * 10
    ContourOCX1.AddPointRandom X, Y, value
    Picture1.CurrentX = X
    Picture1.CurrentY = Y
    Picture1.Circle (X, Y), 1
    If (DrawPoint.value = 1) Then
    Picture1.Print Format(value, "0.0")
    End If
    Next
End Select
ContourOCX1.CalculateRandom
Call DrawLines

End Sub

Private Sub Command7_Click()
CommonDialog1.ShowSave
If Len(CommonDialog1.FileName) > 0 Then
   Dim LineCount As Long, PolygonCount As Long
   Dim path As String, ShpType As String
   
   
   ContourOCX1.GetLineCount LineCount
   ContourOCX1.GetPolygonCount PolygonCount
   'line
   If (LineCount > 0) Then
     path = CommonDialog1.FileName & "_line"
     ShpType = "line"
     ContourOCX1.InitializeSHPFile path, ShpType
     ContourOCX1.CreateShapeFile

    End If
     'plane
      If (PolygonCount > 0) Then
     path = CommonDialog1.FileName & "_polygon"
     ShpType = "Polygon"
     ContourOCX1.InitializeSHPFile path, ShpType
     ContourOCX1.CreateShapeFile

    End If
    
'Create shape file
 End If
End Sub

Private Sub Form_Load()
SelectedIndex = 0
Call InterposeCheck_Click
End Sub

Private Sub InterposeCheck_Click()
If InterposeCheck.value = 1 Then
 RestrictCheck.Enabled = True
 
 Else
 RestrictCheck.Enabled = False
 End If
End Sub

Private Sub List1_Click()
 Dim minVal As Single, maxVal As Single, Area1 As Single, Area2 As Single
 Dim pointCount As Long
 ContourOCX1.GetPolygonPointCountValueArea List1.ListIndex, pointCount, minVal, maxVal, Area1, Area2
 PolyProperty.Text = "Value Range: " & minVal & "- " & maxVal & vbCrLf
 PolyProperty.Text = PolyProperty.Text + "Area   : " & Area2
 ContourOCX1.FlashPolygon Picture2.hDC, List1.ListIndex, CLng(Val(FlshFllColor.Text)), CLng(Val(FlshBrdrColor.Text))
 
End Sub

Private Sub Option1_Click(Index As Integer)
SelectedIndex = Index
If (Index = 2) Then
InterposeCheck.Enabled = False
RestrictCheck.Enabled = False
Else
InterposeCheck.Enabled = True
RestrictCheck.Enabled = True

End If
End Sub

Private Sub Option2_Click(Index As Integer)
 LineValueType = Index
End Sub

Private Sub Option3_Click(Index As Integer)
 RandomMethod = Index
End Sub

Private Sub Option4_Click(Index As Integer)
Source = Index
End Sub