contou.bas

用VB6.0MapINfo绘等值线及表面图

        PZ = (I - 1) * HStep
        Call Project(Px, Py, PZ, Xo, Yo)
        Xo = WcsX0 + Xo * XYFact
        Yo = WcsY0 - Yo * XYFact
    
        Mark = Format(Vmax - PZ, "##0 ")
        
        PictureMesh.CurrentX = Xo - PictureMesh.TextWidth(Mark)
        PictureMesh.CurrentY = Yo - PictureMesh.TextHeight(Mark) / 2
        PictureMesh.Print Mark
    Next I
    
    For I = 2 To NH + 1
        Px = (NX - 1) * DX
        Py = (NY - 1) * DY
        PZ = (I - 1) * HStep
        Call Project(Px, Py, PZ, Xo, Yo)
        Xo = WcsX0 + Xo * XYFact
        Yo = WcsY0 - Yo * XYFact
    
        Mark = Format(Vmax - PZ, "##0 ")
        PictureMesh.CurrentX = Xo + PictureMesh.TextWidth(" ")
        PictureMesh.CurrentY = Yo - PictureMesh.TextHeight(Mark) / 2
        PictureMesh.Print Mark
    Next I
    
End If

PictureMesh.DrawWidth = 1
PictureMesh.ForeColor = 0
'绘经度线
For I = 1 To NX
    Px = (I - 1) * DX
    Py = 0
    PZ = PZTemp
    Call Project(Px, Py, PZ, Xo, Yo)


    Px = (I - 1) * DX
    Py = (NY - 1) * DY
    PZ = PZTemp
    Call Project(Px, Py, PZ, Xot, Yot)
    
    Call PlotCurve(Xo, Yo, 3)
    Call PlotCurve(Xot, Yot, 2)
Next I

'绘纬度线
For I = 1 To NY
    Px = 0
    Py = (I - 1) * DY
    PZ = PZTemp
    Call Project(Px, Py, PZ, Xo, Yo)

    Px = (NX - 1) * DX
    Py = (I - 1) * DY
    PZ = PZTemp
    Call Project(Px, Py, PZ, Xot, Yot)
    
    Call PlotCurve(Xo, Yo, 3)
    Call PlotCurve(Xot, Yot, 2)
Next I

End Sub
'绘三维边框
Private Sub Border3(Vmin As Single, NX As Integer, NY As Integer, Zgrid() As Single)
Dim cdw(0 To 2, 0 To 3) As Single, iix(0 To 2, 0 To 3) As Integer, iiy(0 To 2, 0 To 3) As Integer
Dim xrl As Single, yrl As Single, value As Single, Temp1 As Single, Temp2 As Single
Dim I As Integer, J As Integer, ipen As Integer, Key As Integer
Dim IX As Integer, IY As Integer, IXt As Integer, IYt As Integer
Dim Xo As Single, Yo As Single, Xot As Single, Yot As Single
Dim iPen_Old As Integer, iPen_New As Integer
Dim OutStr As String, X As Single, Y As Single, H As Single
Dim X1 As Single, Y1 As Single, X2 As Single, Y2 As Single, Angle(0 To 3) As Single, Angle0 As Single, Angle1 As Single
Dim YminT As Single, Imin As Integer
Dim iVisible(0 To 3) As Boolean, Cd As Single

Cd = 45# / Atn(1#)
'Begin设置角点立柱、地基线
'*C1    1*/
cdw(0, 0) = Zgrid(1, 1)
iix(0, 0) = 1
iiy(0, 0) = 1
'*C1    2*/
cdw(1, 0) = Vmin
iix(1, 0) = 1
iiy(1, 0) = 1
'*C1    3*/
cdw(2, 0) = Vmin
iix(2, 0) = NX
iiy(2, 0) = 1

'*C2    1*/
cdw(0, 1) = Zgrid(NX, 1)
iix(0, 1) = NX
iiy(0, 1) = 1
'*C2    2*/
cdw(1, 1) = Vmin
iix(1, 1) = NX
iiy(1, 1) = 1
'*c2    3*/
cdw(2, 1) = Vmin
iix(2, 1) = NX
iiy(2, 1) = NY

'*C3    1*/
cdw(0, 2) = Zgrid(NX, NY)
iix(0, 2) = NX
iiy(0, 2) = NY
'*C3    2*/
cdw(1, 2) = Vmin
iix(1, 2) = NX
iiy(1, 2) = NY
'*C3    3*/
cdw(2, 2) = Vmin
iix(2, 2) = 1
iiy(2, 2) = NY

'*C4    1*/
cdw(0, 3) = Zgrid(1, NY)
iix(0, 3) = 1
iiy(0, 3) = NY
'*C4    2*/
cdw(1, 3) = Vmin
iix(1, 3) = 1
iiy(1, 3) = NY
'*C4    3*/
cdw(2, 3) = Vmin
iix(2, 3) = 1
iiy(2, 3) = 1
'End设置角点立柱、地基线

'Begin绘角点立柱、地基线
CurForeColor = QBColor(0)
If (bPictureMesh = True) Then
    PictureMesh.ForeColor = CurForeColor
    PictureMesh.DrawWidth = 2
Else
    Call MIFMID_MakePen(2, 2, CurForeColor)
End If

'Begin求最小值点
YminT = 10000000000#
For I = 0 To 3
    IX = iix(1, I)
    IY = iiy(1, I)
    value = cdw(1, I)
        
    xrl = (IX - 1) * DX
    yrl = (IY - 1) * DY
    Call Vanish(IX, IY, xrl, yrl, value, Xo, Yo, iPen_New, Zgrid)
    If (Yo < YminT) Then
        Imin = I
        YminT = Yo
    End If
Next I
'End求最小值点

'Begin根据最小值判断可见性
If (Imin = 0) Then
    iVisible(0) = True
    iVisible(1) = False
    iVisible(2) = False
    iVisible(3) = True
ElseIf (Imin = 1) Then
    iVisible(0) = True
    iVisible(1) = True
    iVisible(2) = False
    iVisible(3) = False
ElseIf (Imin = 2) Then
    iVisible(0) = False
    iVisible(1) = True
    iVisible(2) = True
    iVisible(3) = False
Else
    iVisible(0) = False
    iVisible(1) = False
    iVisible(2) = True
    iVisible(3) = True
End If
'End根据最小值判断可见性

For I = 0 To 3
    iPen_Old = 3
    For J = 0 To 2
        IX = iix(J, I)
        IY = iiy(J, I)
        value = cdw(J, I)
        
        xrl = (IX - 1) * DX
        yrl = (IY - 1) * DY
        Call Vanish(IX, IY, xrl, yrl, value, Xo, Yo, iPen_New, Zgrid)
        If (iVisible(I) = True) Then '绘可见线
            If (iPen_New = 2 And iPen_Old = 2) Then
                Call PlotCurve(Xo, Yo, 2)
            Else
                Call PlotCurve(Xo, Yo, 3)
            End If
        End If
        iPen_Old = iPen_New
        If (J = 1) Then
            X1 = Xo
            Y1 = Yo
        ElseIf (J = 2) Then
            If (Xo = X1) Then
                Angle(I) = 90# ' 3.14159 / 2
            ElseIf (Yo = Y1) Then
                Angle(I) = 0#
            Else
                Angle(I) = Cd * Atn((Yo - Y1) / (Xo - X1))
            End If
        End If
    Next J
Next I
If (bPictureMesh = True) Then
    PictureMesh.DrawWidth = 1
    PictureMesh.Font = "宋体"
    PictureMesh.Font.Size = 10
    Hslz = 10
Else
    Call MIFMID_MakePen(1, 2, CurForeColor)
    Call MIFMID_MakeFont("MS Sans Serf", 1.5 * Hslz, QBColor(0), 1, QBColor(15), 0, 0, 0, 0, 0, 0)
End If
'End绘角点立柱、地基线

'Begin绘其它立柱
If (iVisible(0) = True) Then
    IY = 1
    For IX = 1 To NX
        xrl = (IX - 1) * DX
        yrl = (IY - 1) * DY

        value = Zgrid(IX, IY)
        Call Project(xrl, yrl, value, Xo, Yo)
        Call PlotCurve(Xo, Yo, 3)
        
        value = Vmin
        Call Project(xrl, yrl, value, Xo, Yo)
        Call PlotCurve(Xo, Yo, 2)
        
        If (IX = 1 Or IX = NX Or IX = Fix(NX / 2)) Then
            If (bPictureMesh = True) Then
                X1 = Xold
                Y1 = Yold
            Else
                X1 = WcsX0 + Xold * XYFact
                Y1 = WcsY0 - Yold * XYFact
            End If
            
            yrl = (IY - 1 - 1) * DY
            value = Vmin
            Call Project(xrl, yrl, value, Xo, Yo)
            X2 = WcsX0 + Xo * XYFact
            Y2 = WcsY0 - Yo * XYFact
            
            If (X2 = X1) Then
                Xo = X1
                Yo = Y1 + 20
            Else
                If (X2 > X1) Then
                    Xo = X1 + 20 / Sqr(1 + ((Y2 - Y1) / (X2 - X1)) ^ 2)
                Else
                    Xo = X1 - 20 / Sqr(1 + ((Y2 - Y1) / (X2 - X1)) ^ 2)
                End If
                Yo = Y1 + (Xo - X1) * (Y2 - Y1) / (X2 - X1)
            End If
            OutStr = Format(Xmin + xrl, "#####0.0####")
            Angle0 = Angle(0)
            
            If (bPictureMesh = True) Then
                PictureMesh.DrawWidth = 1
                PictureMesh.Line (Xold, Yold)-(Xo, Yo)
                Call ContouSymbolT(Xo, Yo, OutStr, Angle0)
            Else
                Xot = (Xo - WcsX0) / XYFact
                Yot = (WcsY0 - Yo) / XYFact
                Call MIFMID_MakePen(1, 2, CurForeColor)
                Call MIFMID_CreateLine(Xold, Yold, Xot, Yot)
                Call MIFMID_CreateText(Xot, Yot, OutStr, Angle0)
            End If
        End If
    Next IX
End If

If (iVisible(1) = True) Then
    IX = NX
    For IY = 1 To NY
        xrl = (IX - 1) * DX
        yrl = (IY - 1) * DY

        value = Zgrid(IX, IY)
        Call Project(xrl, yrl, value, Xo, Yo)
        Call PlotCurve(Xo, Yo, 3)
        
        value = Vmin
        Call Project(xrl, yrl, value, Xo, Yo)
        Call PlotCurve(Xo, Yo, 2)
        If (IY = 1 Or IY = NY Or IY = Fix(NY / 2)) Then
            xrl = (IX + 1 - 1) * DX
            value = Vmin
            If (bPictureMesh = True) Then
                X1 = Xold
                Y1 = Yold
            Else
                X1 = WcsX0 + Xold * XYFact
                Y1 = WcsY0 - Yold * XYFact
            End If
            
            Call Project(xrl, yrl, value, Xo, Yo)
            
            X2 = WcsX0 + Xo * XYFact
            Y2 = WcsY0 - Yo * XYFact
            
            If (X2 = X1) Then
                Xo = X1
                Yo = Y1 + 20
            Else
                If (X2 > X1) Then
                    Xo = X1 + 20 / Sqr(1 + ((Y2 - Y1) / (X2 - X1)) ^ 2)
                Else
                    Xo = X1 - 20 / Sqr(1 + ((Y2 - Y1) / (X2 - X1)) ^ 2)
                End If
                Yo = Y1 + (Xo - X1) * (Y2 - Y1) / (X2 - X1)
            End If

            OutStr = Format(Ymin + yrl, "#####0.0####")
            Angle0 = Angle(1)
            If (bPictureMesh = True) Then
                PictureMesh.DrawWidth = 1
                PictureMesh.Line (Xold, Yold)-(Xo, Yo)
                Call ContouSymbolT(Xo, Yo, OutStr, Angle0)
            Else
                Xot = (Xo - WcsX0) / XYFact
                Yot = (WcsY0 - Yo) / XYFact
                Call MIFMID_MakePen(1, 2, CurForeColor)
                Call MIFMID_CreateLine(Xold, Yold, Xot, Yot)
                Call MIFMID_CreateText(Xot, Yot, OutStr, Angle0)
            End If
        End If
    Next IY
End If
If (iVisible(2) = True) Then
    IY = NY
    For IX = 1 To NX
        xrl = (IX - 1) * DX
        yrl = (IY - 1) * DY

        value = Zgrid(IX, IY)
        Call Project(xrl, yrl, value, Xo, Yo)
        Call PlotCurve(Xo, Yo, 3)
        
        value = Vmin
        Call Project(xrl, yrl, value, Xo, Yo)
        Call PlotCurve(Xo, Yo, 2)
        If (IX = 1 Or IX = NX Or IX = Fix(NX / 2)) Then
            yrl = (IY + 1 - 1) * DY
            If (bPictureMesh = True) Then
                X1 = Xold
                Y1 = Yold
            Else
                X1 = WcsX0 + Xold * XYFact
                Y1 = WcsY0 - Yold * XYFact
            End If
            
            value = Vmin
            Call Project(xrl, yrl, value, Xo, Yo)
            X2 = WcsX0 + Xo * XYFact
            Y2 = WcsY0 - Yo * XYFact
            
            If (X2 = X1) Then
                Xo = X1
                Yo = Y1 + 20
            Else
                If (X2 > X1) Then
                    Xo = X1 + 20 / Sqr(1 + ((Y2 - Y1) / (X2 - X1)) ^ 2)
                Else
                    Xo = X1 - 20 / Sqr(1 + ((Y2 - Y1) / (X2 - X1)) ^ 2)
                End If
                Yo = Y1 + (Xo - X1) * (Y2 - Y1) / (X2 - X1)
            End If
            
            OutStr = Format(Xmin0p + xrl, "#####0.0####")
            Angle0 = Angle(2)
            If (bPictureMesh = True) Then
                PictureMesh.DrawWidth = 1
                PictureMesh.Line (Xold, Yold)-(Xo, Yo)
                Call ContouSymbolT(Xo, Yo, OutStr, Angle0)
            Else
                Xot = (Xo - WcsX0) / XYFact
                Yot = (WcsY0 - Yo) / XYFact
            
                Call MIFMID_MakePen(1, 2, CurForeColor)
                Call MIFMID_CreateLine(Xold, Yold, Xot, Yot)
                Call CreateText(Xot, Yot, OutStr, Angle0, 0, 0)
            End If
        End If
    Next IX
End If
If (iVisible(3) = True) Then
    IX = 1
    For IY = 1 To NY
        xrl = (IX - 1) * DX
        yrl = (IY - 1) * DY

        value = Zgrid(IX, IY)
        Call Project(xrl, yrl, value, Xo, Yo)
        Call PlotCurve(Xo, Yo, 3)
        
        value = Vmin
        Call Project(xrl, yrl, value, Xo, Yo)
        Call PlotCurve(Xo, Yo, 2)
        If (IY = 1 Or IY = NY Or IY = Fix(NY / 2)) Then
            xrl = (IX - 1 - 1) * DX
            value = Vmin
            If (bPictureMesh = True) Then
                X1 = Xold
                Y1 = Yold
            Else
                X1 = WcsX0 + Xold * XYFact
                Y1 = WcsY0 - Yold * XYFact
            End If
            
            Call Project(xrl, yrl, value, Xo, Yo)
            
            X2 = WcsX0 + Xo * XYFact
            Y2 = WcsY0 - Yo * XYFact
            
            If (X2 = X1) Then
                Xo = X1
                Yo = Y1 + 20
            Else