📄 frmreclass.frm
字号:
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "Comdlg32.ocx"
Begin VB.Form frmReclass
BorderStyle = 3 'Fixed Dialog
Caption = "Dem 重分级"
ClientHeight = 4425
ClientLeft = 2760
ClientTop = 3750
ClientWidth = 3900
Icon = "frmReclass.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 4425
ScaleWidth = 3900
ShowInTaskbar = 0 'False
Begin VB.CheckBox chkRetainMissingValue
Caption = "Retain Missing Value"
Height = 315
Left = 3075
TabIndex = 20
Top = 7440
Width = 2535
End
Begin VB.CheckBox chkRetainNodata
Caption = "Retain Nodata"
Height = 255
Left = 195
TabIndex = 19
Top = 7440
Width = 2415
End
Begin VB.ComboBox cmbChangeMissTo
Height = 315
Left = 3075
TabIndex = 18
Text = "Change Missing Value to Nodata "
Top = 7800
Width = 2655
End
Begin VB.ComboBox cmbChangeNodtato
Height = 315
Left = 195
TabIndex = 15
Text = "ChangeNodata To"
Top = 7800
Width = 2655
End
Begin VB.Frame Frame1
Caption = "分级设置"
Height = 2325
Left = 105
TabIndex = 10
Top = 795
Width = 3720
Begin MSComDlg.CommonDialog fileDialog
Left = 1470
Top = 915
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.OptionButton optRange
Caption = "区间对应"
Height = 255
Left = 1215
TabIndex = 17
Top = 1545
Value = -1 'True
Width = 1095
End
Begin VB.OptionButton optUnique
Caption = "单值对应"
Height = 255
Left = 120
TabIndex = 16
Top = 1545
Width = 1095
End
Begin VB.CommandButton cmdLoad
Caption = "加载"
Height = 375
Left = 1950
TabIndex = 14
Top = 1845
Width = 1215
End
Begin VB.CommandButton cmdSave
Caption = "保存"
Height = 375
Left = 660
TabIndex = 13
Top = 1845
Width = 1215
End
Begin VB.ListBox lst2
Height = 1230
Left = 1845
TabIndex = 12
Top = 240
Width = 1800
End
Begin VB.ListBox lst1
Height = 1230
Left = 60
TabIndex = 11
Top = 240
Width = 1725
End
End
Begin VB.ComboBox cmbDsSrc
Height = 315
Left = 1155
Style = 2 'Dropdown List
TabIndex = 5
Top = 60
Width = 2670
End
Begin VB.ComboBox cmbDtSrc
Height = 315
Left = 1155
Style = 2 'Dropdown List
TabIndex = 4
Top = 465
Width = 2670
End
Begin VB.ComboBox cmbDsDes
Height = 315
Left = 1155
Style = 2 'Dropdown List
TabIndex = 3
Top = 3180
Width = 2670
End
Begin VB.TextBox txtDesDt
Height = 315
Left = 1155
TabIndex = 2
Top = 3540
Width = 2670
End
Begin VB.CommandButton btnCancel
Caption = "取消"
Height = 375
Left = 2055
TabIndex = 1
Top = 3975
Width = 1215
End
Begin VB.CommandButton btnOk
Caption = "确定"
Height = 375
Left = 780
TabIndex = 0
Top = 3975
Width = 1215
End
Begin VB.Label Label2
AutoSize = -1 'True
Caption = "输入数据源"
Height = 195
Left = 120
TabIndex = 9
Top = 120
Width = 900
End
Begin VB.Label Label3
AutoSize = -1 'True
Caption = "输入数据集"
Height = 195
Left = 120
TabIndex = 8
Top = 495
Width = 900
End
Begin VB.Label Label4
AutoSize = -1 'True
Caption = "输出数据源"
Height = 195
Left = 120
TabIndex = 7
Top = 3240
Width = 900
End
Begin VB.Label Label5
AutoSize = -1 'True
Caption = "输出数据集"
Height = 195
Left = 120
TabIndex = 6
Top = 3585
Width = 900
End
End
Attribute VB_Name = "frmReclass"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private arrRange1() As Double
Private arrRange2() As Double
Private Sub btnCancel_Click()
Unload Me
End Sub
Private Sub cmbDsSrc_Click()
Dim objDS As soDataSource
Dim objDT As soDataset
Dim strName As String
strName = cmbDsSrc.Text
If strName = "" Then
MsgBox "请选择输入的数据源！", vbInformation
Exit Sub
End If
Set objDS = frmGridAnalyst.SuperWorkspace1.Datasources.Item(strName)
cmbDtSrc.Clear
For Each objDT In objDS.Datasets
If objDT.Type = scdDEM Or objDT.Type = scdGrid Then
cmbDtSrc.AddItem (objDT.Name)
End If
Next
If cmbDtSrc.ListCount > 0 Then cmbDtSrc.ListIndex = 0
Set objDS = Nothing
Set objDT = Nothing
End Sub
Private Sub cmbDtSrc_Click()
Dim objDS As soDataSource
Dim objDT As soDataset
Dim objDtRast As soDatasetRaster
Dim i As Integer
Dim dInter As Double
Dim dMinz As Double
Set objDS = frmGridAnalyst.SuperWorkspace1.Datasources(cmbDsSrc.Text)
Set objDT = objDS.Datasets(cmbDtSrc.Text)
If Not objDT.Vector Then
Set objDtRast = objDT
dInter = (objDtRast.MaxZ - objDtRast.MinZ) / 10
dMinz = objDtRast.MinZ
ReDim arrRange1(10)
ReDim arrRange2(10)
lst1.Clear
lst2.Clear
For i = 0 To 9
arrRange1(i) = dMinz + i * dInter
arrRange2(i) = dMinz + (i + 1) * dInter
lst1.AddItem dMinz + i * dInter & " -----" & dMinz + (i + 1) * dInter
lst2.AddItem i
Next
End If
End Sub
Private Sub cmdLoad_Click()
Dim RemapTable As New soRemapTable
Dim i As Integer
fileDialog.ShowOpen
If RemapTable.Load(fileDialog.FileName) = False Then
MsgBox "Can't Load the Remaptable!"
Exit Sub
Else
lst1.Clear
lst2.Clear
If RemapTable.MappingType = scmRange Then
For i = 1 To RemapTable.NewValuesCount
lst1.AddItem RemapTable.BreakValues(i * 2 - 1) & "----" & RemapTable.BreakValues(i * 2)
lst2.AddItem RemapTable.NewValues(i)
Next
Else
For i = 1 To RemapTable.NewValuesCount
lst1.AddItem RemapTable.BreakValues(i)
lst2.AddItem RemapTable.NewValues(i)
Next
End If
End If
End Sub
Private Sub cmdSave_Click()
Dim RemapTable As New soRemapTable
Dim i As Integer
Dim dRange1, dRange2 As Double
Dim GridAnalysis As New soGridAnalyst
Dim objDtSrc As soDataset
Dim objDsDes As soDataSource
RemapTable.NewValuesCount = lst2.ListCount
If chkRetainMissingValue.Value Then
RemapTable.RetainMissingValue = True
Else
RemapTable.ChangeMissingValueToNoData = True
End If
RemapTable.RetainNoData = chkRetainNodata.Value
If optUnique.Value Then
RemapTable.MappingType = scmUnique
Else
RemapTable.MappingType = scmRange
For i = 1 To lst1.ListCount
'drange1 =
RemapTable.BreakValues(i * 2 - 1) = arrRange1(i - 1)
RemapTable.BreakValues(i * 2) = arrRange2(i - 1)
RemapTable.NewValues(i) = lst2.List(i - 1)
Next
End If
fileDialog.ShowSave
RemapTable.Save fileDialog.FileName
Set RemapTable = Nothing
End Sub
Private Sub Form_Load()
Dim objDS As soDataSource
Set objDS = frmGridAnalyst.SuperWorkspace1.Datasources.Item(1)
If objDS Is Nothing Then
MsgBox "打开数据源失败！", vbInformation
cmdSave.Enabled = False
cmdLoad.Enabled = False
btnOk.Enabled = False
Exit Sub
End If
For Each objDS In frmGridAnalyst.SuperWorkspace1.Datasources
cmbDsSrc.AddItem objDS.Alias
cmbDsDes.AddItem objDS.Alias
Next
If cmbDsSrc.ListCount > 0 Then cmbDsSrc.ListIndex = 0
If cmbDsDes.ListCount > 0 Then cmbDsDes.ListIndex = 0
Set objDS = Nothing
End Sub
Private Sub btnOk_Click()
Dim RemapTable As New soRemapTable
Dim i As Integer
Dim dRange1 As Double, dRange2 As Double
Dim GridAnalysis As New soGridAnalyst
Dim objDtSrc As soDataset
Dim objDsDes As soDataSource
RemapTable.NewValuesCount = lst2.ListCount
If chkRetainMissingValue.Value Then
RemapTable.RetainMissingValue = True
Else
RemapTable.ChangeMissingValueToNoData = True
End If
RemapTable.RetainNoData = chkRetainNodata.Value
If optUnique.Value Then
RemapTable.MappingType = scmUnique
Else
RemapTable.MappingType = scmRange
For i = 1 To lst1.ListCount
'drange1 =
RemapTable.BreakValues(i * 2 - 1) = arrRange1(i - 1)
RemapTable.BreakValues(i * 2) = arrRange2(i - 1)
RemapTable.NewValues(i) = lst2.List(i - 1)
Next
End If
Set objDtSrc = frmGridAnalyst.SuperWorkspace1.Datasources(cmbDsSrc.Text).Datasets(cmbDtSrc.Text)
Set objDsDes = frmGridAnalyst.SuperWorkspace1.Datasources(cmbDsDes.Text)
GridAnalysis.Reclass objDtSrc, objDsDes, txtDesDt.Text, RemapTable, scpDouble, True
frmGridAnalyst.SuperWkspManager1.Refresh
Unload Me
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -