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

📄 contou.bas

📁 采用三角化的方法基于mapinfo的等值线算法例子。
💻 BAS
📖 第 1 页 / 共 3 页
字号:
🔍
123 
            M1 = -1
            For J = 0 To nSJX
                If (LB(J) <> -1) Then
                    C1 = Abs(Xb(I1, 0) - Xb(J, 0))
                    c2 = Abs(Yb(I1, 0) - Yb(J, 0))
                    C3 = Abs(Xb(I1, 0) - Xb(J, 1))
                    C4 = Abs(Yb(I1, 0) - Yb(J, 1))
                    If (C1 <= 0.0001 And c2 <= 0.0001) Then M1 = M1 + 1
                    If (C3 <= 0.0001 And C4 <= 0.0001) Then M1 = M1 + 1
                End If
            Next J
            If (M1 = 0) Then
                LB(I1) = 0
            Else
                M1 = -1
                For J = 0 To nSJX
                    If (LB(J) <> -1) Then
                        C1 = Abs(Xb(I1, 1) - Xb(J, 0))
                        c2 = Abs(Yb(I1, 1) - Yb(J, 0))
                        C3 = Abs(Xb(I1, 1) - Xb(J, 1))
                        C4 = Abs(Yb(I1, 1) - Yb(J, 1))
                        If (C1 <= 0.0001 And c2 <= 0.0001) Then M1 = M1 + 1
                        If (C3 <= 0.0001 And C4 <= 0.0001) Then M1 = M1 + 1
                    End If
                Next J
                If (M1 = 0) Then
                    X1 = Xb(I1, 0)
                    Y1 = Yb(I1, 0)
                    Xb(I1, 0) = Xb(I1, 1)
                    Yb(I1, 0) = Yb(I1, 1)
                    Yb(I1, 1) = Y1
                    Xb(I1, 1) = X1
                    LB(I1) = 0
                End If
            End If
        End If
    Next I1
    '开曲线
    Key = 1
    I1 = -1
    Do
        If (Key = 1) Then '开曲线
            Do
                I1 = I1 + 1
                If (I1 >= nSJX) Then '第一个闭曲线
                    Key = 2
                    I1 = -1
                    Exit Do
                End If
                If (LB(I1) = 0) Then
                    Key = 1
                    Exit Do
                End If
            Loop
        End If
        If (Key = 2) Then '闭曲线
            Do
                I1 = I1 + 1
                If (I1 >= nSJX) Then
                    Key = 0
                    Exit Do
                End If
                
                If (LB(I1) = 1) Then
                    Key = 2
                    Exit Do
                End If
            Loop
        End If
        If (Key = 0) Then Exit Do
        
      
        
        '追踪开曲线或闭曲线
        LD = 1
        DwX(1) = Xb(I1, 0)
        DwY(1) = Yb(I1, 0)
        Do
            For J = 0 To nSJX
                If (LB(J) <> -1) Then
                    If (Abs(DwX(LD) - Xb(J, 0)) < 0.0001 And Abs(DwY(LD) - Yb(J, 0)) < 0.0001) Then
                        LD = LD + 1
                        DwX(LD) = Xb(J, 1)
                        DwY(LD) = Yb(J, 1)
                        LB(J) = -1
                        If (LD = nDwXY) Then
                            Key2 = True
                        Else
                            Key2 = False
                        End If
                        Exit For
                    End If
                    If (Abs(DwX(LD) - Xb(J, 1)) < 0.0001 And Abs(DwY(LD) - Yb(J, 1)) < 0.0001) Then
                        LD = LD + 1
                        DwX(LD) = Xb(J, 0)
                        DwY(LD) = Yb(J, 0)
                        LB(J) = -1
                        If (LD = nDwXY) Then
                            Key2 = True
                        Else
                            Key2 = False
                        End If
                        Exit For
                    End If
                End If
                Key2 = True
            Next J
            If (Key2 = True) Then Exit Do
        Loop
        CurForeColor = 0
        Call Smooth(value, nDec, S0, Key, 10, LD, DwX, DwY, Zgrid)
    Loop
    End If
Next mk


  
'关闭MIFMID文件
Call MIFMID_Close

'把MIFMID文件转换为MapInfo表
Call MIFMID_Tab
    
'标注等值线
If (mapWinID > 0) Then '标注等值线

    MapInfo.Do "Set map redraw off"
    MapInfo.Do "Set Map Layer 1 Label Parallel ON  Auto ON  Overlap OFF Duplicates ON  Line None Position Center Center Font MakeFont(""" & "Arial" & """,0, 10,0,16777215 )"
    MapInfo.Do "set map redraw on"

End If

Erase BorderX, BorderY
  
End Sub
Private Sub SJX()
Dim R As Single, RT As Single
Dim J As Integer, K As Integer
Dim A1 As Single, B1 As Single, C1 As Single, Tt As Single
Dim AA As Single, BB As Single, CC As Single, CosC As Single
Dim bCheck As Boolean, bEQBD As Boolean
Dim Ni As Integer, Nj As Integer, Pi As Integer, Pj As Integer, Pk As Integer
Dim M1 As Integer, M2 As Integer
Dim bSJX As Boolean
'边界段数
Dim nBD As Integer
'用于判断边界环是否搜索过
Dim bBD() As Boolean
'用于判断数据点是否在边界环内
Dim bPoint() As Byte
'第i边界起点BD,第i边对应顶点
Dim BD() As Integer, BDij() As Integer
'第i边界的上一节点、下一节点
Dim Nlast As Integer, Nnext As Integer


ReDim ID1(0 To 2 * NContou), ID2(0 To 2 * NContou), ID3(0 To 2 * NContou)
'Begin生成第一个三角形
Pi = 0
'找出距第一点最近的点2
RT = 1E+20
For J = 1 To NContou
    R = (Xcontou(J) - Xcontou(Pi)) ^ 2 + (Ycontou(J) - Ycontou(Pi)) ^ 2
    If (R < RT) Then
        RT = R
        Pj = J
    End If
Next J
'找出第三点
Tt = 0
For J = 1 To NContou
    If (J <> Pj) Then
        AA = (Xcontou(Pj) - Xcontou(J)) ^ 2 + (Ycontou(Pj) - Ycontou(J)) ^ 2
        BB = (Xcontou(Pi) - Xcontou(J)) ^ 2 + (Ycontou(Pi) - Ycontou(J)) ^ 2
        CC = (Xcontou(Pi) - Xcontou(Pj)) ^ 2 + (Ycontou(Pi) - Ycontou(Pj)) ^ 2
        CosC = 1# - (AA + BB - CC) / (2# * Sqr(AA * BB))
        If (CosC > Tt + 0.00001) Then
            Tt = CosC
            Pk = J
        End If
    End If
Next J
nSJX = 0
ID1(nSJX) = Pi
ID2(nSJX) = Pj
ID3(nSJX) = Pk
'End生成第一个三角形

'定义边界环数组
ReDim BD(0 To NContou), BDij(0 To NContou), bBD(0 To NContou), bPoint(0 To NContou)

For J = 0 To NContou
    bBD(J) = False
    bPoint(J) = 0
Next J
'生成三条边
nBD = 3

BD(1) = Pi
BDij(1) = Pk
bBD(1) = True


BD(2) = Pj
BDij(2) = Pi
bBD(2) = True

BD(3) = Pk
BDij(3) = Pj
bBD(3) = True

bPoint(Pi) = 1
bPoint(Pj) = 1
bPoint(Pk) = 1

Do
    Ni = Ni + 1

    bEQBD = False
    For J = Ni To nBD
        If (bBD(J) = True) Then
            bEQBD = True
            Exit For
        End If
    Next J
    If (bEQBD = False) Then
        For J = 1 To Ni - 1
            If (bBD(J) = True) Then
                bEQBD = True
                Exit For
            End If
        Next J
    End If
    Ni = J
    If (bEQBD = False) Then Exit Do
    
    '第Ni边的终点节点
    If (Ni = nBD) Then
        Nj = 1
    Else
        Nj = Ni + 1
    End If
    '第Ni边的后邻
    If (Ni = 1) Then
        Nlast = nBD
    Else
        Nlast = Ni - 1
    End If
    '第Ni边的前邻
    If (Nj = nBD) Then
        Nnext = 1
    Else
        Nnext = Nj + 1
    End If
        
    '第Ni边的三个顶点
    Pi = BD(Ni)
    Pj = BD(Nj)
    Pk = BDij(Ni)
    
    'Begin找下一点
    bCheck = False
    If (Xcontou(Pj) = Xcontou(Pi)) Then
        C1 = Xcontou(Pk) - Xcontou(Pi)
    Else
        A1 = (Ycontou(Pj) - Ycontou(Pi)) / (Xcontou(Pj) - Xcontou(Pi))
        B1 = Ycontou(Pj) - A1 * Xcontou(Pj)
        C1 = Ycontou(Pk) - Xcontou(Pk) * A1 - B1
    End If
    If (C1 <= 0#) Then
        M1 = -1
    Else
        M1 = 1
    End If
    
    Tt = 0#
    For K = 1 To NContou
        If (K = Pi Or K = Pj Or bPoint(K) = 2) Then
        Else
            If (Xcontou(Pj) = Xcontou(Pi)) Then
                C1 = Xcontou(K) - Xcontou(Pi)
            Else
                C1 = Ycontou(K) - Xcontou(K) * A1 - B1
            End If
            If (C1 <= 0#) Then
                M2 = -1
            Else
                M2 = 1
            End If
            If (M1 <> M2) Then
                AA = (Xcontou(Pj) - Xcontou(K)) ^ 2 + (Ycontou(Pj) - Ycontou(K)) ^ 2
                BB = (Xcontou(Pi) - Xcontou(K)) ^ 2 + (Ycontou(Pi) - Ycontou(K)) ^ 2
                CC = (Xcontou(Pi) - Xcontou(Pj)) ^ 2 + (Ycontou(Pi) - Ycontou(Pj)) ^ 2
                CosC = 1# - (AA + BB - CC) / (2# * Sqr(AA * BB))
                If (CosC > Tt + 0.00001) Then
                    Tt = CosC
                    Pk = K
                    bCheck = True
                End If
            End If
        End If
    Next K
    'End找下一点
    If (bCheck = True) Then '找到下一点
        bSJX = True
        '找前邻、后邻
        If (Pk = BD(Nlast)) Then '后邻,删除Pi点
            '修改后邻点参数
            BDij(Nlast) = Pi
            bBD(Nlast) = True
            bPoint(Pk) = 1
            
            For J = Ni + 1 To nBD
                BD(J - 1) = BD(J)
                BDij(J - 1) = BDij(J)
                bBD(J - 1) = bBD(J)
            Next J
            
            nBD = nBD - 1       '减少一个边
            bPoint(Pi) = 2      'Pi点位于圈内
        ElseIf (Pk = BD(Nnext)) Then '前邻,删除Pj点
            '修改Ni点参数
            BDij(Ni) = Pj
            bBD(Ni) = True
            bPoint(Pk) = 1
            
            For J = Nj + 1 To nBD
                BD(J - 1) = BD(J)
                BDij(J - 1) = BDij(J)
                bBD(J - 1) = bBD(J)
            Next J
            
            nBD = nBD - 1       '减少一个边
            bPoint(Pj) = 2      'Pj点位于圈内
        ElseIf (bPoint(Pk) < 1) Then '下一点不在边界环上,插入Pk点
            '修改Ni点参数
            BDij(Ni) = Pj
            bBD(Ni) = True
            bPoint(Pk) = 1
            
            '数据后推
            For J = nBD To Ni + 1 Step -1
                BD(J + 1) = BD(J)
                BDij(J + 1) = BDij(J)
                bBD(J + 1) = bBD(J)
            Next J
            nBD = nBD + 1
            
            'Pk点参数
            BD(Ni + 1) = Pk
            BDij(Ni + 1) = Pi
            bBD(Ni + 1) = True
            Ni = Ni + 1
        Else
            bSJX = False
        End If
        If (bSJX = True) Then
            '生成新三角形
            nSJX = nSJX + 1
            ID1(nSJX) = Pi
            ID2(nSJX) = Pj
            ID3(nSJX) = Pk
        End If
    Else '没找到下一点,该边界不再搜索
        bBD(Ni) = False
    End If
Loop

'整理边界
nBorder = nBD - 1
ReDim BorderX(0 To nBorder + 1), BorderY(0 To nBorder + 1)
For J = 0 To nBorder
    BorderX(J) = Xcontou(BD(J + 1))
    BorderY(J) = Ycontou(BD(J + 1))
Next J
BorderX(nBorder + 1) = BorderX(0)
BorderY(nBorder + 1) = BorderY(0)
End Sub


Public Sub PlotContou23()
    Dim I As Integer, J As Integer
    Dim TableNameT As String
    Dim ParValue() As Single, Vn As Integer, S0 As Single, nDec As Integer
    Dim StrMax As String

    Screen.MousePointer = 11

    bPictureMesh = False
    
    TheContouPath = TheInstallPath + "等值线数据\mesh.dat"
    TableName = "mesh.dat"
    
    J = InStr(TableName, ".")
    TableNameT = Left(TableName, J - 1)
    TableName = TableNameT + ".TAB"
            
    Call ReadContouFile(TheContouPath)
    Screen.MousePointer = 11
    
    S0 = 5
    
    '设置等值线参数

    Call MaxnDec(Vmin, Vmax, nDec, StrMax, FMT)

    Vmin = Val(Format(Vmin, FMT))
    Vmax = Val(Format(Vmax, FMT))
    
    
    
    MsgBox Vmax & "  " & Vmin
    
    
    
    Vn = 9
    Vd = (Vmax - Vmin) / Vn
    Vd = Val(Format(Vd, FMT))
    ReDim ParValue(0 To Vn)
    
    Call SetContouValue(ParValue)
    
    Call Contou23(ParValue, Vn, S0, nDec)
   
    Erase Xcontou, Ycontou, Zcontou
    Erase Zgrid, bZgrid
    Erase ID1, ID1, ID3
    Erase BorderX, BorderY

    Screen.MousePointer = 0
End Sub
'读绘等值线的数据
Public Sub ReadContouFile(TheContouPath As String)
Dim IX As Integer, IY As Integer, II As Long
Dim I As Long
Dim Temp As String, DSAA_DSBB As String * 4, ValueTemp As Single, DouValueTemp As Double
Dim N0 As Long, N As Long
Dim Xt As Single, Yt As Single
Dim XminT As Double, XmaxT As Double, YminT As Double, YmaxT As Double, VminT As Double, VmaxT As Double
Dim bSpace As Boolean
Dim lNX As Long, lNY As Long, xStep As Double, yStep As Double

On Error Resume Next
Open TheContouPath For Binary Access Read Lock Read As #1
Get #1, 1, DSAA_DSBB
Close (1)
If (DSAA_DSBB = "DSAA") Then 'WinSurfer的ASCII格式
    DataType = 0
    Open TheContouPath For Input As #1
    Line Input #1, Temp
    Input #1, NX, NY
    Input #1, Xmin, Xmax
    Input #1, Ymin, Ymax
    Input #1, Vmin, Vmax
    For IX = 1 To NX
        Input #1, ValueTemp
    Next IX
    Line Input #1, Temp
    Close (1)
    If (Len(Trim(Temp)) < 1) Then
        bSpace = True
    Else
        bSpace = False
    End If
    Open TheContouPath For Input As #1
    Line Input #1, Temp
    Input #1, NX, NY
    Input #1, Xmin, Xmax
    Input #1, Ymin, Ymax
    Input #1, Vmin, Vmax
    ReDim Zgrid(1 To NX, 1 To NY), bZgrid(1 To NX, 1 To NY)
    N0 = NX * NY
123

⌨️ 快捷键说明

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