曲面_等值线f2.frm

本程序采四边形网格法编制了曲面等值线程序

        Next J
    Next I
'检查退化点并消除
    For W = PA To PB Step PC
        For I = 1 To M
            For J = 1 To N
                If S0(I, J) = W Then S0(I, J) = S0(I, J) + 0.00001
            Next J
        Next I
    Next W
    For W = PA To PB Step PC
        For J = 1 To N          '检查垂直边
            For I = 1 To M - 1
                If S0(I, J) < W And S0(I + 1, J) > W Or S0(I, J) > W _
                    And S0(I + 1, J) < W Then
'在网格的垂直边存在等值点，求出等值点相对位置
                    H(I, J) = (W - S0(I, J)) / (S0(I + 1, J) - S0(I, J))
                Else
'无等值点
                    H(I, J) = -2
                End If
            Next I
        Next J
        For I = 1 To M          '检查水平边
            For J = 1 To N - 1
                If S0(I, J) < W And S0(I, J + 1) > W Or S0(I, J) > W _
                    And S0(I, J + 1) < W Then
'在网格的水平边存在等值点，求出等值点相对位置
                    S(I, J) = (W - S0(I, J)) / (S0(I, J + 1) - S0(I, J))
                Else
'无等值点
                    S(I, J) = -2
                End If
            Next J
        Next I
'搜索区域的上边
        For J = 1 To N - 1
            If S(1, J) > 0 Then WF 1, J, 1, 0, J
        Next J
'搜索区域的左边
        For I = 1 To M - 1
            If H(I, 1) > 0 Then WF I, 1, 0, I, 0
        Next I
'搜索区域的底边
        For J = 1 To N - 1
            If S(M, J) > 0 Then WF M, J, 1, M, J
        Next J
'搜索区域的右边
        For I = 1 To M - 1
            If H(I, N) > 0 Then WF I, N, 0, I, N
        Next I
'搜索封闭的等值线
        For I = 2 To M - 1
            For J = 1 To N - 1
                If S(I, J) > 0 Then WF I, J, 1, I - 1, J
            Next J
        Next I
    Next W
End Sub

Private Sub Form_Load()
    Me.Top = 0
    Me.Left = 0
    Me.Height = 11000: Me.Width = 15360
    pic.ScaleMode = 7                           '图片框以厘米为单位
    Printer.ScaleMode = 7                       '打印机以厘米为单位
    pic.Height = 17: pic.Width = 26
    DX = 1: DY = 1
'PA是初始等值线，缺省以最小值作为初始等值线值
'PB是终止等值线，缺省以最大值作为终止等值线值
'PC是等值线间距，缺省按10条等值线计算
    PA = 100000000
    PB = -100000000
    For I = 1 To M
        For J = 1 To N
            If V(I, J) > PB Then PB = V(I, J)
            If V(I, J) < PA Then PA = V(I, J)
        Next J
    Next I
    PC = (PB - PA) / 10
    lblTitle.Visible = False    '图题标签不可视
    mnuMove.Enabled = False     '移动图题不可用
    intPrinter = 0              '先不用打印机
    mnuPrint.Enabled = False    '先不能使用打印机
End Sub

'改变参数
Private Sub mnuChange_Click()
'在参数窗体显示参数
    frmChange.txtX = Str(DX)
    frmChange.txtY = Str(DY)
    frmChange.txtPA = Str(PA)
    frmChange.txtPB = Str(PB)
    frmChange.txtPC = Str(PC)
    frmChange.Visible = True
End Sub

'屏幕绘图
Private Sub mnuDraw_Click()
    pic.Cls
'如果点数很多，按厘米计会超出图幅，这时将使用规定的自定义坐标系
'图幅的宽度约23厘米，高度约15厘米
    If N * DX >= pic.Width Or M * DY >= pic.Height Then
        If N * DX < 1.5 * M * DY Then
            WW = M * DY
        Else
            WW = N * DX / 1.5
        End If
'建立自定义坐标系
        pic.Scale (0, 0)-(WW * 1.5, WW)
        MsgBox "按给定参数图形太大，只能使用规定坐标系！"
    Else
        pic.ScaleMode = 7
    End If
    lblTitle.Caption = strLabelName
    Contour intM, intN, DX, DY, V               '调用绘制等值线过程
    lblTitle.Visible = True                     '图题可视
    mnuMove.Enabled = True                      '移动图题菜单可用
    mnuPrint.Enabled = True                     '打印机可用
End Sub

'退出，结束程序运行
Private Sub mnuExit_Click()
    Unload Me
    frmFileName.Visible = True
End Sub

'打印机绘图
Private Sub mnuPrint_Click()
    Printer.Scale (0, 0)-(WW * 1.5, WW)
    If lblTitle.Visible = False Then GoTo 100
    Printer.Font = lblTitle.Font                '图题的字体
    Printer.FontSize = lblTitle.FontSize        '图题的尺寸
    Printer.CurrentX = lblTitle.Left            '图题的X坐标
    Printer.CurrentY = lblTitle.Top             '图题的Y坐标
'打印图题
    Printer.Print lblTitle.Caption
100:
    If lblAdd.Visible = False Then GoTo 200
    Printer.Font = lblAdd.Font                  '加号的字体
    Printer.FontSize = lblAdd.FontSize          '加号的尺寸
    Printer.CurrentX = lblAdd.Left              '加号的X坐标
    Printer.CurrentY = lblAdd.Top               '加号的Y坐标
'打印加号
    Printer.Print lblAdd.Caption
200:
    If lblMus.Visible = False Then GoTo 300
    Printer.Font = lblMus.Font                  '减号的字体
    Printer.FontSize = lblMus.FontSize          '减号的尺寸
    Printer.CurrentX = lblMus.Left              '减号的X坐标
    Printer.CurrentY = lblMus.Top               '减号的Y坐标
'打印减号
    Printer.Print lblMus.Caption
300:
    intPrinter = 1                              '使用打印机绘制等值线
    Contour intM, intN, DX, DY, V               '在A4纸上绘制等值线图
    Printer.EndDoc                              '输出
End Sub

'将图片框pic的DragMode属性设为0-Manual，可以利用鼠标手动拖动pic
Private Sub pic_DragDrop(Source As Control, X As Single, Y As Single)
    Source.Move X + pic.Left - sngX, Y + pic.Top - sngY
End Sub

'按下鼠标时记下pic的当前位置
Private Sub pic_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    sngX = X: sngY = Y
    pic.Drag vbBeginDrag
End Sub

'下移标题
Private Sub mnuDown_Click()
    lblTitle.Top = lblTitle.Top + 0.1
    lblTitle.Move lblTitle.Left, lblTitle.Top
End Sub

'左移标题
Private Sub mnuLeft_Click()
    lblTitle.Left = lblTitle.Left - 0.1
    lblTitle.Move lblTitle.Left, lblTitle.Top
End Sub

'右移标题
Private Sub mnuRight_Click()
    lblTitle.Left = lblTitle.Left + 0.1
    lblTitle.Move lblTitle.Left, lblTitle.Top
End Sub

'上移标题
Private Sub mnuUP_Click()
    lblTitle.Top = lblTitle.Top - 0.1
    lblTitle.Move lblTitle.Left, lblTitle.Top
End Sub

'数据行和数据列都倒转
Private Sub mnuBoth_Click()
    If intRow <> intCol Then
        MsgBox "数据行数与数据列数不相等，不能交换数据！"
        Exit Sub
    End If
'数据列倒转
    For I = 1 To intRow
        For J = 1 To intCol \ 2
            D = V(intCol - J + 1, I)
            V(intCol - J + 1, I) = V(J, I)
            V(J, I) = D
        Next J
    Next I
'数据行倒转
    For I = 1 To intRow \ 2
        For J = 1 To intCol
            D = V(J, intRow - I + 1)
            V(J, intRow - I + 1) = V(J, I)
            V(J, I) = D
        Next J
    Next I
End Sub

'数据行倒转
Private Sub mnuRow_Click()
    If intRow <> intCol Then
        MsgBox "数据行数与数据列数不相等，不能交换数据！"
        Exit Sub
    End If
    For I = 1 To intRow \ 2
        For J = 1 To intCol
            D = V(J, intRow - I + 1)
            V(J, intRow - I + 1) = V(J, I)
            V(J, I) = D
        Next J
    Next I
End Sub

'数据列倒转
Private Sub mnuCol_Click()
    If intRow <> intCol Then
        MsgBox "数据行数与数据列数不相等，不能交换数据！"
        Exit Sub
    End If
    For I = 1 To intRow
        For J = 1 To intCol \ 2
            D = V(intCol - J + 1, I)
            V(intCol - J + 1, I) = V(J, I)
            V(J, I) = D
        Next J
    Next I
End Sub

'使用原始数据
Private Sub mnuReNew_Click()
    If intRow <> intCol Then
        MsgBox "数据行数与数据列数不相等，不能交换数据！"
        Exit Sub
    End If
    For I = 1 To intRow
        For J = 1 To intCol
            V(J, I) = V1(J, I)
        Next J
    Next I
End Sub

'删除加号
Private Sub mnuADel_Click()
    lblAdd.Visible = False
End Sub

'删除减号
Private Sub mnuMDEL_Click()
    lblMus.Visible = False
End Sub

'添加加号
Private Sub mnuAdd_Click()
    lblAdd.Visible = True
End Sub

'添加减号
Private Sub mnuMus_Click()
    lblMus.Visible = True
End Sub

'下移加号
Private Sub mnuAD_Click()
    lblAdd.Top = lblAdd.Top + 0.1
    lblAdd.Move lblAdd.Left, lblAdd.Top
End Sub

'左移加号
Private Sub mnuAL_Click()
    lblAdd.Left = lblAdd.Left - 0.1
    lblAdd.Move lblAdd.Left, lblAdd.Top
End Sub

'右移加号
Private Sub mnuAR_Click()
    lblAdd.Left = lblAdd.Left + 0.1
    lblAdd.Move lblAdd.Left, lblAdd.Top
End Sub

'上移加号
Private Sub mnuAU_Click()
    lblAdd.Top = lblAdd.Top - 0.1
    lblAdd.Move lblAdd.Left, lblAdd.Top
End Sub

'下移减号
Private Sub mnuMD_Click()
    lblMus.Top = lblMus.Top + 0.1
    lblMus.Move lblMus.Left, lblMus.Top
End Sub

'左移减号
Private Sub mnuML_Click()
    lblMus.Left = lblMus.Left - 0.1
    lblMus.Move lblMus.Left, lblMus.Top
End Sub

'右移减号
Private Sub mnuMR_Click()
    lblMus.Left = lblMus.Left + 0.1
    lblMus.Move lblMus.Left, lblMus.Top
End Sub

'上移减号
Private Sub mnuMU_Click()
    lblMus.Top = lblMus.Top - 0.1
    lblMus.Move lblMus.Left, lblMus.Top
End Sub