⭐ 欢迎来到虫虫下载站！ | 📦 资源下载 📁 资源专辑 ℹ️ 关于我们
⭐ 虫虫下载站
📤 上传资源

📄 movepar.frm

📁 用VB6.0MapINfo绘等值线及表面图
💻 FRM
📖 第 1 页 / 共 3 页
字号:
🔍
123 
Dim StrMax As String, FMT As String

Screen.MousePointer = 11
MSFlexGridContou.ColWidth(0) = CommandConTouNo.Width - 56.7
MSFlexGridContou.ColWidth(1) = CommandContouValue.Width
MSFlexGridContou.ColWidth(2) = CommandContouFill.Width
MSFlexGridContou.ColWidth(3) = CommandContouFillInit.Width
MSFlexGridContou.ColWidth(4) = CommandContouMark.Width
MSFlexGridContou.ColWidth(5) = CommandContouMarkInit.Width
'MSFlexGridContou.ColAlignment(0) = 1
'MSFlexGridContou.ColAlignment(1) = 1
MSFlexGridContou.ColAlignment(2) = 2
MSFlexGridContou.ColAlignment(4) = 2
MSFlexGridContou.ColAlignment(5) = 3

If (TheContouPath = "") Then '等值线To区域
    lStartColorFill = &H80FF80
    lEndColorFill = &HFF&
    iCheckFillColor = 1
    bFill = True

    lStartColorCurve = &H0&
    lEndColorCurve = &H0&
    iCheckContouMarkColor = 1
    DeltaN = 2
    
    bPlotLine = 1
    S0 = 5
    iOptionFill = 1
    
    '设置等值线参数
    Vmin = ParFill(IndexMove, 0).value
    Vmax = ParFill(IndexMove, Vn).value
    Call MaxnDec(Vmin, Vmax, nDec, StrMax, FMT)

    ValueMin = 2 * ParFill(IndexMove, 0).value - ParFill(IndexMove, 1).value
    
    Call SetFillColor(lStartColorFill, lEndColorFill, 0, Vn, ColorMin)
    Call SetMarkColor(lStartColorCurve, lEndColorCurve, 0, Vn)
    
    ParFill(IndexMove, 0).FillColorInit = lStartColorFill
    ParFill(IndexMove, Vn).FillColorInit = lEndColorFill
     
    ParFill(IndexMove, 0).MarkColorInit = lStartColorCurve
    ParFill(IndexMove, Vn).MarkColorInit = lEndColorCurve
ElseIf (ParMove(IndexMove).Make = 0) Then
    lStartColorFill = &H80FF80
    lEndColorFill = &HFF&
    If (bMovePicture = False) Then
        iCheckFillColor = 0
        bFill = False
    Else
        iCheckFillColor = 1
        bFill = True
    End If

    lStartColorCurve = &H0&
    lEndColorCurve = &H0&
    iCheckContouMarkColor = 1
    DeltaN = 2
    AngXY = 45
    AngZ = 45
    KZ = 1
    Hslz = 16
    PenWidthT = 1
    
    bPlotLine = 1
    S0 = 5
    iOptionFill = 1
    
    Call ReadContouFile(TheContouPath)
    
    '设置等值线参数
    Call MaxnDec(Vmin, Vmax, nDec, StrMax, FMT)

    Vmin = Val(Format(Vmin, FMT))
    Vmax = Val(Format(Vmax, FMT))
    Vn = 9
    Vd = (Vmax - Vmin) / Vn
    Vd = Val(Format(Vd, FMT))
    
    Call SetContouValue
    
    Call SetFillColor(lStartColorFill, lEndColorFill, 0, Vn, ColorMin)
    Call SetMarkColor(lStartColorCurve, lEndColorCurve, 0, Vn)
    
    ParFill(IndexMove, 0).FillColorInit = lStartColorFill
    ParFill(IndexMove, Vn).FillColorInit = lEndColorFill
     
    ParFill(IndexMove, 0).MarkColorInit = lStartColorCurve
    ParFill(IndexMove, Vn).MarkColorInit = lEndColorCurve
Else
    ColorMin = ParMove(IndexMove).ColorMin                          '底色
    ValueMin = ParMove(IndexMove).ValueMin

    'ParMove(IndexMove).Make = 1                                    '是否已建立参数
    DataType = ParMove(IndexMove).DataType                          '是否网格数据
    iOptionContou = ParMove(IndexMove).iOptionContou                '图形类型,0-平面等值线，1-立体等值线，2-立体表面图

    Xmin = ParMove(IndexMove).Xmin                                  'X最小值
    Xmax = ParMove(IndexMove).Xmax                                  'X最大值
    Ymin = ParMove(IndexMove).Ymin                                  'Y最小值
    Ymax = ParMove(IndexMove).Ymax                                  'Y最大值

    Vmin = ParMove(IndexMove).Vmin                                  '最小值
    Vmax = ParMove(IndexMove).Vmax                                  '最大值
    Vd = ParMove(IndexMove).Vd                                      '步长
    Vn = ParMove(IndexMove).Vn                                      '等值线数
    nDec = ParMove(IndexMove).nDec                                  '小数位数

    iCheckFillColor = ParMove(IndexMove).iCheckFillColor            '是否填色
    lStartColorFill = ParMove(IndexMove).lStartColorFill            '最小值填充颜色
    lEndColorFill = ParMove(IndexMove).lEndColorFill                '最大值填充颜色
    iOptionFill = ParMove(IndexMove).iOptionFill                    '填充图例
    bFill = ParMove(IndexMove).bFill
    bPlotLine = ParMove(IndexMove).bPlotLine

    iCheckContouMarkColor = ParMove(IndexMove).iCheckContouMarkColor '是否绘等值线线
    lStartColorCurve = ParMove(IndexMove).lStartColorCurve          '最小值线条颜色
    lEndColorCurve = ParMove(IndexMove).lEndColorCurve              '最大值线条颜色
    DeltaN = ParMove(IndexMove).DeltaN                              '间隔几条线标注
    S0 = ParMove(IndexMove).S0                                      '等值线上的标注间距
    Hslz = ParMove(IndexMove).Hslz                                  '标注字符高度(点)
    PenWidthT = 1

    AngXY = ParMove(IndexMove).AngXY                                '视线方位角(度)
    AngZ = ParMove(IndexMove).AngZ                                  '视线俯视角(度)
    KZ = ParMove(IndexMove).KZ                                      'Z坐标放大系数
End If
OptionContou(iOptionContou).value = True
If (DataType = 0) Then '网格数据
    OptionContou(0).Enabled = True
    OptionContou(1).Enabled = True
    OptionContou(2).Enabled = True
    OptionContou(3).Enabled = True
    OptionContou(4).Enabled = True
Else '非网格数据
    OptionContou(0).Enabled = True
    OptionContou(1).Enabled = False
    OptionContou(2).Enabled = False
    OptionContou(3).Enabled = False
    OptionContou(4).Enabled = True
End If
If (nSelected = 1) Then
    OptionContou(5).Enabled = True
Else
    OptionContou(5).Enabled = False
End If
If (TheContouPath = "") Then '等值线To区域
    MovePar.Caption = "等值线To等值区域"
    
    OptionContou(0).Enabled = False
    OptionContou(1).Enabled = False
    OptionContou(2).Enabled = False
    OptionContou(3).Enabled = False
    OptionContou(4).Enabled = False
    '等值线值
    CommandContouValue.Caption = "等值线值…"
    CommandContouValue.Enabled = False
    '填充颜色
    CommandContouFill.Enabled = True
    '标注参数
    CommandContouMark.Enabled = True
    '等值线编辑
    MSFlexGridContou.Enabled = True
    '视角参数
    Command3D.Enabled = False
    
    CommandDelete.Enabled = False
    CommandAdd.Enabled = False
End If

bClick = False
Call AddMSFlexGrid
bClick = True
Screen.MousePointer = 0
End Sub

Private Sub MSFlexGridContou_DblClick()
    If (bClick = False) Then Exit Sub
    
    bClick = False
    Row = MSFlexGridContou.Row
    If (MSFlexGridContou.Col = 1) Then
        If (TheContouPath = "") Then
            MsgBox "该参数无效", vbOKOnly, "等值线To等值区域"
        Else
            If (OptionContou(0).value = True) Then
                StrCommand = "当前等值线值"
            Else
                StrCommand = "当前色块值"
            End If
        
            CurValue = MSFlexGridContou.Text
            Parame.Show 1
            MSFlexGridContou.Text = CurValue
            ParFill(IndexMove, Row).value = Val(CurValue)
        End If
    ElseIf (MSFlexGridContou.Col = 2) Then
        StrCommand = "当前填充参数"
        CurCellBackColor = MSFlexGridContou.CellBackColor
        CurTXT = MSFlexGridContou.Text
        Parame.Show 1
        MSFlexGridContou.CellBackColor = CurCellBackColor
        MSFlexGridContou.Text = CurTXT
    ElseIf (MSFlexGridContou.Col = 3) Then
        StrCommand = "当前填充连续颜色设置"
        CurCellBackColor = MSFlexGridContou.CellBackColor
        If (CurCellBackColor = QBColor(15)) Then
            Init = 0
            CurCellBackColor = ParFill(IndexMove, Row).FillColor
        Else
            Init = 1
        End If
        
        Parame.Show 1
        
        If (Init = 0) Then
            CurCellBackColor = QBColor(15)
        End If
        MSFlexGridContou.Col = 3
        MSFlexGridContou.CellBackColor = CurCellBackColor
        ParFill(IndexMove, Row).FillColorInit = CurCellBackColor
    ElseIf (MSFlexGridContou.Col = 4) Then
        If (OptionContou(0).value = True) Then
            StrCommand = "当前标注参数"
            CurCellForeColor = MSFlexGridContou.CellForeColor
            CurTXT = MSFlexGridContou.Text
            Parame.Show 1
            MSFlexGridContou.CellForeColor = CurCellForeColor
            MSFlexGridContou.Text = CurTXT
        Else
            MsgBox "该参数无效", vbOKOnly, "当前标注参数"
        End If
    ElseIf (MSFlexGridContou.Col = 5) Then
        StrCommand = "当前标注连续颜色设置"
        CurCellBackColor = MSFlexGridContou.CellForeColor
        If (CurCellBackColor = QBColor(15)) Then
            Init = 0
            CurCellBackColor = ParFill(IndexMove, Row).MarkColorInit
        Else
            Init = 1
        End If
        
        Parame.Show 1
        
        If (Init = 0) Then
            CurCellBackColor = QBColor(15)
        End If
        MSFlexGridContou.Col = 5
        MSFlexGridContou.CellForeColor = CurCellBackColor
        ParFill(IndexMove, Row).MarkColorInit = CurCellBackColor
    End If
    DoEvents
    bClick = True
End Sub
Private Sub OptionContou_Click(Index As Integer)
iOptionContou = Index
If (Index = 0) Then '平面等值线
    '等值线值
    CommandContouValue.Caption = "等值线值…"
    CommandContouValue.Enabled = True
    '填充颜色
    CommandContouFill.Enabled = True
    '标注参数
    CommandContouMark.Enabled = True
    '等值线编辑
    MSFlexGridContou.Enabled = True
    '视角参数
    Command3D.Enabled = False
ElseIf (Index = 1) Then '立体等值线
    '等值线值
    CommandContouValue.Enabled = True
    CommandContouValue.Caption = "等值线值…"
    '填充颜色
    CommandContouFill.Enabled = True
    '标注参数
    CommandContouMark.Enabled = True
    '等值线编辑
    MSFlexGridContou.Enabled = True
    '视角参数
    Command3D.Enabled = True
ElseIf (Index = 2) Then '网状图
    '等值线值
    CommandContouValue.Enabled = False
    CommandContouValue.Caption = "等值线值…"
    '填充颜色
    CommandContouFill.Enabled = True
    '标注参数
    CommandContouMark.Enabled = False
    '等值线编辑
    MSFlexGridContou.Enabled = True
    '视角参数
    Command3D.Enabled = True
ElseIf (Index = 3) Then '色块图
    '等值线值
    CommandContouValue.Enabled = True
    CommandContouValue.Caption = "色块值…"
    '填充颜色
    CommandContouFill.Enabled = True
    '标注参数
    CommandContouMark.Enabled = False
    '等值线编辑
    MSFlexGridContou.Enabled = True
    '视角参数
    Command3D.Enabled = False
ElseIf (Index = 5) Then '3DMap
    '等值线值
    CommandContouValue.Enabled = True
    CommandContouValue.Caption = "色块值…"
    '填充颜色
    CommandContouFill.Enabled = True
    '标注参数
    CommandContouMark.Enabled = False
    '等值线编辑
    MSFlexGridContou.Enabled = True
    '视角参数
    Command3D.Enabled = False
Else '数值图、3DMap
    '等值线值
    CommandContouValue.Enabled = False
    CommandContouValue.Caption = "等值线值…"
    '填充颜色
    CommandContouFill.Enabled = False
    '标注参数
    CommandContouMark.Enabled = False
    '等值线编辑
    MSFlexGridContou.Enabled = False
    '视角参数
    Command3D.Enabled = False
End If
End Sub
123

⌨️ 快捷键说明

复制代码 Ctrl + C
搜索代码 Ctrl + F
全屏模式 F11
切换主题 Ctrl + Shift + D
显示快捷键 ?
增大字号 Ctrl + =
减小字号 Ctrl + -