contou.bas

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

End Sub


'
'
Public Sub Wcs(Xorig As Single, Yorig As Single, Xlen As Single, Ylen As Single)
'1mm=56.7twip
WcsX = Xorig ' * 56.7
WcsY = PaperHeight - Yorig ' * 56.7
Xleng = Xlen ' * 56.7
Yleng = Ylen ' * 56.7
Iinit = 0
End Sub

'
'
Public Sub Ucs(Xmin As Single, Ymin As Single, Xmax As Single, Ymax As Single)

If (Xleng * Yleng * (Xmax - Xmin) * (Ymax - Ymin) <= 0#) Then
        Iinit = 0
Else
        Iinit = 1
End If
Xminp = Xmin
Xmaxp = Xmax
Yminp = Ymin
Ymaxp = Ymax
''If (Xmaxp - Xminp > 0#) Then XFact = Xleng / (Xmaxp - Xminp)
''If (Ymaxp - Yminp > 0#) Then Yfact = Yleng / (Ymaxp - Yminp)
If (Xmaxp - Xminp > 0 And Ymaxp - Yminp > 0) Then
    XYFact = (Xleng / (Xmaxp - Xminp) + Yleng / (Ymaxp - Yminp)) / 2#
    WcsX0 = WcsX - Xminp * XYFact
    WcsY0 = WcsY + Yminp * XYFact
End If
End Sub
'绘三维边框
Private Sub Border3D(Vmin As Single, NX As Integer, NY As Integer)
Dim I As Integer, J As Integer
Dim Xo As Single, Yo As Single, Xot As Single, Yot As Single
Dim Px As Single, Py As Single, PZ As Single
Dim XX(1 To 5) As Single, YY(1 To 5) As Single, ZZ(1 To 2) As Single
Dim X(0 To 3) As Single, Y(0 To 3) As Single, Z(0 To 3) As Single
Dim LonLat(1 To 2, 1 To 4) As Single
Dim Mark As String, PZTemp As Single
Dim jMapType As Integer
Dim hRgnClose As Long, hBrush As Long
Dim P(0 To 5) As POINTAPI

PictureMesh.DrawWidth = 1
PictureMesh.Font = "宋体"
PictureMesh.Font.Size = 10
Hslz = 10

Cd = 45# / Atn(1#)

XX(1) = 1
YY(1) = 1
LonLat(1, 1) = LonMin
LonLat(2, 1) = LatMin

XX(2) = NX
YY(2) = 1
LonLat(1, 2) = LonMax
LonLat(2, 2) = LatMin

XX(3) = NX
YY(3) = NY
LonLat(1, 3) = LonMax
LonLat(2, 3) = LatMax

XX(4) = 1
YY(4) = NY
LonLat(1, 4) = LonMin
LonLat(2, 4) = LatMax

XX(5) = XX(1)
YY(5) = YY(1)

ZZ(1) = Vmin
ZZ(2) = Vmax


If (iMapType = 0) Then
    jMapType = 1
Else
    jMapType = 0
End If

If (iMapType = 0) Then
    PZTemp = Vmax
Else
    PZTemp = Vmin
End If

'绘上下边框
CurForeColor = QBColor(0)
PictureMesh.ForeColor = CurForeColor
PictureMesh.DrawWidth = 2
For I = 1 To 2
    For J = 1 To 4
        Px = (XX(J) - 1) * DX
        Py = (YY(J) - 1) * DY
        PZ = ZZ(I)
        Call Project(Px, Py, PZ, Xo, Yo)

        Px = (XX(J + 1) - 1) * DX
        Py = (YY(J + 1) - 1) * DY
        PZ = ZZ(I)
        Call Project(Px, Py, PZ, Xot, Yot)
        Call PlotCurve(Xo, Yo, 3)
        Call PlotCurve(Xot, Yot, 2)
    Next J
Next I
'绘立柱
For J = 1 To 4
    Px = (XX(J) - 1) * DX
    Py = (YY(J) - 1) * DY
    PZ = Vmin
    Call Project(Px, Py, PZ, Xo, Yo)

    Px = (XX(J) - 1) * DX
    Py = (YY(J) - 1) * DY
    PZ = Vmax
    Call Project(Px, Py, PZ, Xot, Yot)
    Call PlotCurve(Xo, Yo, 3)
    Call PlotCurve(Xot, Yot, 2)
Next J

For J = 1 To 4
    Px = (XX(J) - 1) * DX
    Py = (YY(J) - 1) * DY
    PZ = Vmin
    Call Project(Px, Py, PZ, Xo, Yo)
    Xo = WcsX0 + Xo * XYFact
    Yo = WcsY0 - Yo * XYFact
    
    Mark = Format(LonLat(1, J), "###.0# ") + Format(LonLat(2, J), "###.0#")

    PictureMesh.CurrentX = Xo - PictureMesh.TextWidth(Mark) / 2
    PictureMesh.CurrentY = Yo
    PictureMesh.Print Mark
Next J

PictureMesh.DrawWidth = 1
PictureMesh.ForeColor = 0
If (AngXY > 0 And AngXY < 90) Then
    If (iMapType = 0) Then
        '左面
        X(0) = 0
        Y(0) = 0
        Z(0) = Vmax
    
        X(1) = 0
        Y(1) = 0
        Z(1) = Vmin
    
        X(2) = 0
        Y(2) = (NY - 1) * DY
        Z(2) = Vmin
    
        X(3) = 0
        Y(3) = (NY - 1) * DY
        Z(3) = Vmax
    
        For I = 0 To 3
            Call Project(X(I), Y(I), Z(I), Xo, Yo)
        
            P(I).X = WcsX0 + Xo * XYFact
            P(I).Y = WcsY0 - Yo * XYFact
        Next I
        P(4) = P(0)
                
        hRgnClose = CreatePolygonRgn(P(1), 4, WINDING) '创建多边形区域
        hBrush = CreateSolidBrush(&HC0FFC0)
        FillRgn PictureMesh.hdc, hRgnClose, hBrush
        DeleteObject (hBrush)
        DeleteObject (hRgnClose)
        
        '前面
        X(0) = 0
        Y(0) = 0
        Z(0) = Vmax
    
        X(1) = 0
        Y(1) = 0
        Z(1) = Vmin
    
        X(2) = (NX - 1) * DX
        Y(2) = 0
        Z(2) = Vmin
    
        X(3) = (NX - 1) * DX
        Y(3) = 0
        Z(3) = Vmax
    
        For I = 0 To 3
            Call Project(X(I), Y(I), Z(I), Xo, Yo)
        
            P(I).X = WcsX0 + Xo * XYFact
            P(I).Y = WcsY0 - Yo * XYFact
        Next I
        P(4) = P(0)
                
        hRgnClose = CreatePolygonRgn(P(1), 4, WINDING) '创建多边形区域
        hBrush = CreateSolidBrush(&HC0C0FF)
        FillRgn PictureMesh.hdc, hRgnClose, hBrush
        DeleteObject (hBrush)
        DeleteObject (hRgnClose)
        
        
        X(0) = 0
        Y(0) = 0
        Z(0) = Vmax
    
        X(1) = (NX - 1) * DX
        Y(1) = 0
        Z(1) = Vmax
    
        X(2) = (NX - 1) * DX
        Y(2) = (NY - 1) * DY
        Z(2) = Vmax
    
        X(3) = 0
        Y(3) = (NY - 1) * DY
        Z(3) = Vmax
    
        For I = 0 To 3
            Call Project(X(I), Y(I), Z(I), Xo, Yo)
        
            P(I).X = WcsX0 + Xo * XYFact
            P(I).Y = WcsY0 - Yo * XYFact
        Next I
        P(4) = P(0)
                
        hRgnClose = CreatePolygonRgn(P(1), 4, WINDING) '创建多边形区域
        hBrush = CreateSolidBrush(&HFFC0C0)
        FillRgn PictureMesh.hdc, hRgnClose, hBrush
        DeleteObject (hBrush)
        DeleteObject (hRgnClose)
    End If

    For I = 1 To NY
        Px = iMapType * (NX - 1) * DX
        Py = (I - 1) * DY
        PZ = Vmin
        Call Project(Px, Py, PZ, Xo, Yo)
    
        Px = iMapType * (NX - 1) * DX
        Py = (I - 1) * DY
        PZ = Vmax
        Call Project(Px, Py, PZ, Xot, Yot)
    
        Call PlotCurve(Xo, Yo, 3)
        Call PlotCurve(Xot, Yot, 2)
    Next I
    
    For I = 1 To NX
        Px = (I - 1) * DX
        Py = iMapType * (NY - 1) * DY
        PZ = Vmin
        Call Project(Px, Py, PZ, Xo, Yo)
    
        Px = (I - 1) * DX
        Py = iMapType * (NY - 1) * DY
        PZ = Vmax
        Call Project(Px, Py, PZ, Xot, Yot)
    
        Call PlotCurve(Xo, Yo, 3)
        Call PlotCurve(Xot, Yot, 2)
    Next I
    
    For I = 1 To NH + 1
        Px = 0
        Py = iMapType * (NY - 1) * DY
        PZ = (I - 1) * HStep
        Call Project(Px, Py, PZ, Xo, Yo)

        Px = (NX - 1) * DX
        Py = iMapType * (NY - 1) * DY
        PZ = (I - 1) * HStep
        Call Project(Px, Py, PZ, Xot, Yot)
    
        Call PlotCurve(Xo, Yo, 3)
        Call PlotCurve(Xot, Yot, 2)
    Next I
    
    For I = 1 To NH + 1
        Px = iMapType * (NX - 1) * DX
        Py = 0
        PZ = (I - 1) * HStep
        Call Project(Px, Py, PZ, Xo, Yo)


        Px = iMapType * (NX - 1) * DX
        Py = (NY - 1) * DY
        PZ = (I - 1) * HStep
        Call Project(Px, Py, PZ, Xot, Yot)
    
        Call PlotCurve(Xo, Yo, 3)
        Call PlotCurve(Xot, Yot, 2)
    Next I
    
    For I = 2 To NH + 1
        Px = 0
        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(Mark)
        PictureMesh.CurrentY = Yo - PictureMesh.TextHeight(Mark) / 2
        PictureMesh.Print Mark
    Next I
    
    For I = 2 To NH + 1
        Px = (NX - 1) * DX
        Py = 0
        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
ElseIf (AngXY < 180) Then
    If (iMapType = 0) Then
        '左面
        X(0) = 0
        Y(0) = 0
        Z(0) = Vmax
    
        X(1) = 0
        Y(1) = 0
        Z(1) = Vmin
    
        X(2) = 0
        Y(2) = (NY - 1) * DY
        Z(2) = Vmin
    
        X(3) = 0
        Y(3) = (NY - 1) * DY
        Z(3) = Vmax
    
        For I = 0 To 3
            Call Project(X(I), Y(I), Z(I), Xo, Yo)
        
            P(I).X = WcsX0 + Xo * XYFact
            P(I).Y = WcsY0 - Yo * XYFact
        Next I
        P(4) = P(0)
                
        hRgnClose = CreatePolygonRgn(P(1), 4, WINDING) '创建多边形区域
        hBrush = CreateSolidBrush(&HC0FFC0)
        FillRgn PictureMesh.hdc, hRgnClose, hBrush
        DeleteObject (hBrush)
        DeleteObject (hRgnClose)
        
        '后面
        X(0) = 0
        Y(0) = (NY - 1) * DY
        Z(0) = Vmax
    
        X(1) = 0
        Y(1) = (NY - 1) * DY
        Z(1) = Vmin
    
        X(2) = (NX - 1) * DX
        Y(2) = (NY - 1) * DY
        Z(2) = Vmin
    
        X(3) = (NX - 1) * DX
        Y(3) = (NY - 1) * DY
        Z(3) = Vmax
    
        For I = 0 To 3
            Call Project(X(I), Y(I), Z(I), Xo, Yo)
        
            P(I).X = WcsX0 + Xo * XYFact
            P(I).Y = WcsY0 - Yo * XYFact
        Next I
        P(4) = P(0)
                
        hRgnClose = CreatePolygonRgn(P(1), 4, WINDING) '创建多边形区域
        hBrush = CreateSolidBrush(&HC0C0FF)
        FillRgn PictureMesh.hdc, hRgnClose, hBrush
        DeleteObject (hBrush)
        DeleteObject (hRgnClose)
        
        
        X(0) = 0
        Y(0) = 0
        Z(0) = Vmax
    
        X(1) = (NX - 1) * DX
        Y(1) = 0
        Z(1) = Vmax
    
        X(2) = (NX - 1) * DX
        Y(2) = (NY - 1) * DY
        Z(2) = Vmax
    
        X(3) = 0
        Y(3) = (NY - 1) * DY
        Z(3) = Vmax
    
        For I = 0 To 3
            Call Project(X(I), Y(I), Z(I), Xo, Yo)
        
            P(I).X = WcsX0 + Xo * XYFact
            P(I).Y = WcsY0 - Yo * XYFact
        Next I
        P(4) = P(0)
                
        hRgnClose = CreatePolygonRgn(P(1), 4, WINDING) '创建多边形区域
        hBrush = CreateSolidBrush(&HFFC0C0)
        FillRgn PictureMesh.hdc, hRgnClose, hBrush
        DeleteObject (hBrush)
        DeleteObject (hRgnClose)
    End If

    For I = 1 To NY
        Px = iMapType * (NX - 1) * DX
        Py = (I - 1) * DY