contou.bas

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

                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(3)
            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
'End绘其它立柱

ipen = 3
For I = 1 To NX - 1
    yrl = 0
    For J = 1 To 11
        xrl = (J - 1) / 10#
        value = Zgrid(I, 1) + xrl * (Zgrid(I + 1, 1) - Zgrid(I, 1))
        
        xrl = (xrl + I - 1) * DX
        IX = I
        IY = 1
        Call Vanish(IX, IY, xrl, yrl, value, Xo, Yo, iPen_New, Zgrid)
        If (iPen_New = 2 And ipen = 2) Then
            Call PlotCurve(Xo, Yo, 2)
        Else
            Call PlotCurve(Xo, Yo, 3)
        End If
        ipen = iPen_New
    Next J
Next I
'-????
ipen = 3
For I = 1 To NY - 1
    xrl = (NX - 1#) * DX
    For J = 1 To 11
        yrl = (J - 1) / 10#
        value = Zgrid(NX, I) + yrl * (Zgrid(NX, I + 1) - Zgrid(NX, I))
        yrl = (yrl + I - 1) * DY
        
        IX = NX
        IY = I
        
        Call Vanish(IX, IY, xrl, yrl, value, Xo, Yo, iPen_New, Zgrid)
        If (iPen_New = 2 And ipen = 2) Then
            Call PlotCurve(Xo, Yo, 2)
        Else
            Call PlotCurve(Xo, Yo, 3)
        End If
        ipen = iPen_New
    Next J
Next I
ipen = 3
For I = 1 To NX - 1
    yrl = (NY - 1#) * DY
    For J = 1 To 11
        xrl = (J - 1) / 10#
        value = Zgrid(I, NY) + xrl * (Zgrid(I + 1, NY) - Zgrid(I, NY))
        xrl = (xrl + I - 1) * DX
        
        IX = I
        IY = NY
        
        Call Vanish(IX, IY, xrl, yrl, value, Xo, Yo, iPen_New, Zgrid)
        If (iPen_New = 2 And ipen = 2) Then
            Call PlotCurve(Xo, Yo, 2)
        Else
            Call PlotCurve(Xo, Yo, 3)
        End If
        ipen = iPen_New
    Next J
Next I
'--????
ipen = 3
For I = 1 To NY - 1
    xrl = 0
    For J = 1 To 11
        yrl = (J - 1) / 10#
        value = Zgrid(1, I) + yrl * (Zgrid(1, I + 1) - Zgrid(1, I))
        yrl = (yrl + I - 1) * DY
        
        IX = 1
        IY = I
        
        Call Vanish(IX, IY, xrl, yrl, value, Xo, Yo, iPen_New, Zgrid)
        If (iPen_New = 2 And ipen = 2) Then
            Call PlotCurve(Xo, Yo, 2)
        Else
            Call PlotCurve(Xo, Yo, 3)
        End If
        ipen = iPen_New
    Next J
Next I
End Sub
Public Sub NewFont(Nsym As Integer)
Dim XWfont As String, Temp As Byte
Dim iLoc As Integer, No As Integer

SymFont = Nsym
If (Nsym <= 0) Then
    XWfont = TheInstallPath + "CENTERED.SYM"
Else
    XWfont = TheInstallPath + "SET" + Format(Nsym, "0") + ".SYM"
End If

Nfslz = 12 'FreeFile

Open XWfont For Binary Access Read As #Nfslz
iLoc = 4
While Not (EOF(Nfslz))
        Seek #Nfslz, iLoc
        Get #Nfslz, , Temp
        No = Temp                 'Ascii
        If (No < 32 Or No > 128) Then GoTo IEND
        Get #Nfslz, , Temp             '高度
        If (Temp = 0) Then
            SymHeight(No) = 22
        Else
            SymHeight(No) = 256 - Temp
        End If
        Get #Nfslz, , Temp             '宽度
        SymWidth(No) = Temp
        Get #Nfslz, , Temp             '记录数
        SymNPoint(No) = Temp
        SymAddr(No) = iLoc + 4
        iLoc = iLoc + SymNPoint(No) * 3 + 4
Wend
IEND:
'Close (Nfslz)

End Sub

'写等值线数据
Private Sub ContouSymbolT(X As Single, Y As Single, cText As String, Angle0 As Single)
Dim cAscii As String * 1, iAscii As Integer, WidthCtext As Single
Dim Xc As Single, Yc As Single, Xnew As Single, Ynew As Single, X1 As Single, Y1 As Single
Dim Temp As Byte
Dim ipen As Integer, Fact As Single
Dim NcText As Integer, I As Integer, J As Integer
Dim Angle As Single

Angle = Angle0 * 3.14159265 / 180#

NcText = Len(Trim(cText))
WidthCtext = 0#
For I = 1 To NcText
    cAscii = Mid(cText, I, 1)
    iAscii = Asc(cAscii)
    WidthCtext = WidthCtext + SymWidth(iAscii) * Hslz / SymHeight(iAscii)
Next I

Xc = X + (Hslz * Sin(Angle) / 2 - WidthCtext * Cos(Angle) / 2)
Yc = Y + (Hslz * Cos(Angle) / 2 + WidthCtext * Sin(Angle) / 2)

For I = 1 To NcText
    cAscii = Mid(cText, I, 1)
    iAscii = Asc(cAscii)
    
    Seek #Nfslz, SymAddr(iAscii)
    Fact = Hslz / SymHeight(iAscii)
    For J = 1 To SymNPoint(iAscii)
        Get Nfslz, , Temp
        Xnew = Temp
        If (Xnew > 128) Then Xnew = Xnew - 256
            Get Nfslz, , Temp
        Ynew = Temp
        If (Ynew > 128) Then Ynew = Ynew - 256
        Get Nfslz, , Temp
        ipen = Temp
        X1 = Xc + (Xnew * Cos(Angle) - Ynew * Sin(Angle)) * Fact
        Y1 = Yc - (Xnew * Sin(Angle) + Ynew * Cos(Angle)) * Fact
        'X1 = Xc + (AM1 * Xnew + AM2 * Ynew) * Fact
        'Y1 = yc - (AN1 * Xnew + AN2 * Ynew + AN3 * KZ * Vmin) * Fact
        If (ipen = 2) Then
            PictureMesh.Line (Xold, Yold)-(X1, Y1)
        End If
        Xold = X1
        Yold = Y1
    Next J
    Xc = Xc + SymWidth(iAscii) * Fact * Cos(Angle)
    Yc = Yc - SymWidth(iAscii) * Fact * Sin(Angle)
Next I

End Sub



'形成封闭多边形
Private Sub ClosePoly(X() As Single, Y() As Single, N As Integer, NN As Integer, Key As Integer)
Dim I As Integer, I1 As Integer, I2 As Integer, N1 As Integer, N2 As Integer, S As Integer
Dim X1 As Single, Y1 As Single, X2 As Single, Y2 As Single, Xm As Single, Ym As Single
Dim A1 As Single, B1 As Single, C1 As Single, C1t As Single, DN As Integer

NN = N
If (Abs(X(1) - X(NN)) < 0.0001 And Abs(Y(1) - Y(NN)) < 0.0001) Then '已经是封闭多边形
    NN = NN - 1
    N = N - 1
    Key = 2
Else '对开曲线顺时针形成封闭区
    Key = 1
    '找距起始点最近的点
    C1t = 1.1E+38
    For I = 0 To nBorder
        C1 = (X(1) - BorderX(I)) ^ 2 + (Y(1) - BorderY(I)) ^ 2
        If (C1 < C1t) Then
            I1 = I
            C1t = C1
            If (C1 = 0#) Then Exit For
        End If
    Next I
    '找距终止点最近的点
    C1t = 1.1E+38
    For I = 0 To nBorder
        C1 = (X(NN) - BorderX(I)) ^ 2 + (Y(NN) - BorderY(I)) ^ 2
        If (C1 < C1t) Then
            I2 = I
            C1t = C1
            If (C1 = 0#) Then Exit For
        End If
    Next I
    If (I2 = I1) Then '在同一节点一边或两边
        '判断起始点、终止点和最近节点是否在在同一线段上
        If (Abs(X(NN) - X(1)) < 0.001) Then
            C1 = Abs(BorderX(I1) - X(1))
        Else
            B1 = (Y(NN) - Y(1)) / (X(NN) - X(1))
            A1 = Y(NN) - B1 * X(NN)
            C1 = Abs(BorderY(I1) - (A1 + B1 * BorderX(I1)))
        End If
        If (Abs(C1) > 0.001) Then  '位于节点拐角的两端
            NN = NN + 1
            X(NN) = BorderX(I1)
            Y(NN) = BorderY(I1)
        End If
    Else '起始点、终止点不在同一线段上
        If (I2 > I1) Then
            S = -1
            
            X1 = BorderX(I2)
            Y1 = BorderY(I2)
            X2 = BorderX(I2 - 1)
            Y2 = BorderY(I2 - 1)
            Xm = X(NN)
            Ym = Y(NN)
            DN = 1
            If (X1 = Xm) Then
                If ((Ym < Y1 And Ym < Y2) Or (Ym > Y1 And Ym > Y2)) Then DN = 0
            Else
                If ((Xm < X1 And Xm < X2) Or (Xm > X1 And Xm > X2)) Then DN = 0
            End If
            N1 = I2 - DN
            
            X1 = BorderX(I1)
            Y1 = BorderY(I1)
            X2 = BorderX(I1 + 1)
            Y2 = BorderY(I1 + 1)
            Xm = X(1)
            Ym = Y(1)
            DN = 1
            If (X1 = Xm) Then
                If ((Ym < Y1 And Ym < Y2) Or (Ym > Y1 And Ym > Y2)) Then DN = 0
            Else
                If ((Xm < X1 And Xm < X2) Or (Xm > X1 And Xm > X2)) Then DN = 0
            End If
            N2 = I1 + DN
        Else 'If (I2 < I1) Then
            S = 1
            
            X1 = BorderX(I2)
            Y1 = BorderY(I2)
            X2 = BorderX(I2 + 1)
            Y2 = BorderY(I2 + 1)
            Xm = X(NN)
            Ym = Y(NN)
            DN = 1
            If (X1 = Xm) Then
                If ((Ym < Y1 And Ym < Y2) Or (Ym > Y1 And Ym > Y2)) Then DN = 0
            Else
                If ((Xm < X1 And Xm < X2) Or (Xm > X1 And Xm > X2)) Then DN = 0
            End If
            N1 = I2 + DN
            
            X1 = BorderX(I1)
            Y1 = BorderY(I1)
            X2 = BorderX(I1 - 1)
            Y2 = BorderY(I1 - 1)
            Xm = X(1)
            Ym = Y(1)
            DN = 1
            If (X1 = Xm) Then
                If ((Ym < Y1 And Ym < Y2) Or (Ym > Y1 And Ym > Y2)) Then DN = 0
            Else
                If ((Xm < X1 And Xm < X2) Or (Xm > X1 And Xm > X2)) Then DN = 0
            End If
            N2 = I1 - DN
        End If
        
        For I = N1 To N2 Step S
            NN = NN + 1
            X(NN) = BorderX(I)
            Y(NN) = BorderY(I)
        Next I
    End If
End If
End Sub

'N顶点数
Private Function Square(X() As Single, Y() As Single, N As Integer) As Single
    Dim I As Integer, S As Double, NN As Integer
    
    If ((Abs(X(1) - X(N)) + Abs(Y(1) - Y(N))) < 0.0001) Then
        NN = N - 1
    Else
        NN = N
    End If
    
    S = X(NN) * Y(1) - X(1) * Y(NN)
    
    For I = 1 To NN - 1
        S = S + X(I) * Y(I + 1) - X(I + 1) * Y(I)
    Next I
    S = S / 2
    Square = Abs(S)
End Function
'求出投影后的窗口坐标
Private Sub FindWindow(Xmin As Single, Ymin As Single, Xmax As Single, Ymax As Single, Zgrid() As Single)
    Dim Xo As Single, Yo As Single
    Dim IX As Integer, IY As Integer

    Xmin = 1E+38
    Xmax = -1E+38
    Ymin = 1E+38
    Ymax = -1E+38
    
    For IY = 1 To NY
        For IX = 1 To NX
            Call Project((IX - 1) * DX, (IY - 1) * DY, Vmax, Xo, Yo)
            If (Xo < Xmin) Then Xmin = Xo
            If (Yo < Ymin) Then Ymin = Yo
            If (Xo > Xmax) Then Xmax = Xo
            If (Yo > Ymax) Then Ymax = Yo
        Next IX
    Next IY

    For IY = 1 To NY
        For IX = 1 To NX
            Call Project((IX - 1) * DX, (IY - 1) * DY, Vmin, Xo, Yo)
            If (Xo < Xmin) Then Xmin = Xo
            If (Yo < Ymin) Then Ymin = Yo
            If (Xo > Xmax) Then Xmax = Xo
            If (Yo > Ymax) Then Ymax = Yo
        Next IX
    Next IY
End Sub
'隐线判定子程序
Private Sub Vanish(IX As Integer, IY As Integer, Px As Single, Py As Single, PZ As Single, Xo As Single, Yo As Single, iSBL As Integer, Zgrid() As Single)
Dim iXo As Integer, iYo As Integer, iNCR As Integer
Dim POX As Single, POY As Single, POZ As Single, EPS As Single, Temp1 As Single, Temp2 As Single
Dim ys2 As Single

iSBL = 2
Call Project(Px, Py, PZ, Xo, Yo)
iXo = IX
iNCR = 1
If (AL1 < 0#) Then iNCR = -1
Ys1 = Yo
Do
    iXo = iXo + iNCR
    If (iXo < 1 Or iXo > NX) Then Exit Do
    POX = (iXo - 1) * DX
    If (Abs(AM2) <= 0.00001) Then Exit Do
    POY = (Xo - AM1 * POX) / AM2
    iYo = Fix(POY / DY) + 1
    If (iYo < 2 Or iYo > NY - 1) Then Exit Do
    EPS = POY / DY - (iYo - 1#)
    Temp1 = Zgrid(iXo, iYo)
    Temp2 = Zgrid(iXo, iYo + 1)
    POZ = Temp1 + EPS * (Temp2 - Temp1)
    'Begin隐点判定
    '''ys2 = AN1 * POX + AN2 * POY + AN3 * POZ * KZ
    ys2 = AN1 * POX + AN2 * POY + AN3 * (POZ - Vmin) * KZZ
    
    If ((Ys1 < Yo And Yo <= ys2) Or (Ys1 > Yo And Yo >= ys2)) Then
        iSBL = 3
    Else
        Ys1 = ys2
    End If
    'End隐点判定
    If (iSBL = 3) Then Exit Sub
Loop
iYo = IY
iNCR = 1
If (AL2 < 0#) Then iNCR = -1
Ys1 = Yo
Do
    iYo = iYo + iNCR
    If (iYo < 1 Or iYo > NY) Then Exit Do
    POY = (iYo - 1) * DY
    If (Abs(AM1) <= 0.00001) Then Exit Do
    POX = (Xo - AM2 * POY) / AM1
    iXo = Fix(POX / DX) + 1
    If (iXo < 2 Or iXo > NX - 1) Then Exit Do
    EPS = POX / DX - (iXo - 1#)
    Temp1 = Zgrid(iXo, iYo)
    Temp2 = Zgrid(iXo + 1, iYo)
    POZ = Temp1 + EPS * (Temp2 - Temp1)
    'Begin隐点判定
    ''ys2 = AN1 * POX + AN2 * POY + AN3 * POZ * KZ
    ys2 = AN1 * POX + AN2 * POY + AN3 * (POZ - Vmin) * KZZ
    If ((Ys1 < Yo And Yo <= ys2) Or (Ys1 > Yo And Yo >= ys2)) Then
        iSBL = 3
    Else
        Ys1 = ys2
    End If
    'End隐