📄 contou.bas
字号:
Attribute VB_Name = "Module5"
Option Explicit
Public Type POINTAPI
X As Long
Y As Long
End Type
Public WcsX0 As Single, WcsY0 As Single, XYFact As Single
Public WcsX As Single, WcsY As Single
Public Xold As Single, Yold As Single
Public Xleng As Single, Yleng As Single
Public Xminp As Single, Yminp As Single, Xmaxp As Single, Ymaxp As Single
Public Xmin As Single, Xmax As Single, Ymin As Single, Ymax As Single
Public Xmin0p As Single, Ymin0p As Single
Public S0 As Single
Public DX As Single, DY As Single, NX As Integer, NY As Integer
Public HStep As Single, NH As Integer
Public AngXY As Single, AngZ As Single
Public N As Single
Public KZ As Single, KZZ As Single
Public StartRed As Integer, StartGreen As Integer, StartBlue As Integer, dRed As Integer, dGreen As Integer, dBlue As Integer
Public bMarkColor As Integer, bFillColor As Integer, iMark As Integer
Public ColorMin As Long, ValueMin As Single, FillScaleWidth As Single
Public ColorMinCur As Long, ValueMinCur As Single, iOptionContou As Integer
Public iContou As Integer, Init As Integer
Public Xcontou() As Single, Ycontou() As Single, Zcontou() As Single, NContou As Long
Public Vmin As Single, Vmax As Single, Vd As Single, Vn As Integer
Public Zgrid() As Single, bZgrid() As Boolean
Public TheContouPath As String
Public DataType As Byte
Public ContouIndex As Integer
Public bFill As Boolean, StrFill As String, bPlotLine As Byte
Public StartColor As Long, EndColor As Long
Public TheInPath As String, TheInFile As String, TheInIndex As String
Public Cd As Single, Pi As Single
Public A1 As Single, A2 As Single, A3 As Single, B1 As Single, B2 As Single, B3 As Single
Public J1 As Integer, I1 As Integer, J2 As Integer, I2 As Integer, J3 As Integer, i3 As Integer
Public AL1 As Single, AL2 As Single, AL3 As Single, AM1 As Single, AM2 As Single, AM3 As Single, AN1 As Single, AN2 As Single, AN3 As Single
Public Ys1 As Single, R0 As Single
Public Flag_Old As Integer, Flag_New As Integer, iPen_Old As Integer
Public xrl As Single, yrl As Single
Public IXL As Integer, IYL As Integer
Public value As Single
Public X0 As Single, Y0 As Single
Public TotalSquare As Integer
Public FMT As String, bFillScale As Boolean
Public BorderX() As Single, BorderY() As Single, nBorder As Integer
Public nSJX As Integer, ID1() As Integer, ID2() As Integer, ID3() As Integer
Public iColor As Integer, iFillStyle As Integer
Public iCheckLatLon As Integer
Public bClick As Boolean
Public StrError As Variant, StrWait As String, StrCommand As String
Public iOptionFill As Integer
Public iCheckFillColor As Integer, iCheckContouMarkColor As Integer
Public lStartColorCurve As Long, lEndColorCurve As Long
Public lStartColorFill As Long, lEndColorFill As Long
Public DeltaN As Integer, nDec As Integer
Public CurCellBackColor As Long, CurCellForeColor As Long, CurTXT As String, Row As Integer, CurValue As String
Dim CurFillColor As Long, CurForeColor As Long
Dim InNumber As Integer, InOutNumber As Integer, OutNo As Integer, InNo As Integer
Public Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Public Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As POINTAPI, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long
Public Declare Function FillRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long, ByVal hBrush As Long) As Long
Public Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Public Const RGN_AND = 1
Public Const RGN_COPY = 5
Public Const RGN_DIFF = 4
Public Const RGN_OR = 2
Public Const RGN_XOR = 3
Public Const COMPLEXREGION = 3
Public Const NULLREGION = 1
Public Const SIMPLEREGION = 2
Private Const FLOODFILLBORDER = 0
Private Const FLOODFILLSURFACE = 1
Public Const WINDING = 2
Public TableNameT As String, TheGRDFile As String
Public XFact As Single, Yfact As Single, Iinit As Integer
Public StrDDWY As String
Public FileMT0 As String, nSelected As Integer
Public The3DMapFile As String
'判断是否为经纬网
Public bLatLon As Boolean
Public nTheLowFile As Integer
Public PenWidthT As Integer
Public GTSLVIndex As String
Public bMovePicture As Boolean
'绘β分布图
Dim ScaleBeta As Double
Dim MinYear As Integer, MinMonth As Integer, MinDate As Integer
Dim MaxYear As Integer, MaxMonth As Integer, MaxDate As Integer
Dim mmPaperHeight As Long, mmPaperWidth As Long, FileType As String
Dim BetaYmax As Double
Dim iBorderLeft As Integer, iBorderRight As Integer, iBorderTop As Integer, iBorderBottom As Integer
Dim PicSubHeight As Single, PicSubWidth As Single
Public DataBaseLink As Integer
Public bPictureMesh As Boolean
Public Nfslz As Integer, Hslz As Double, SymFont As Integer
Public SymWidth(32 To 128) As Integer, SymHeight(32 To 128) As Integer, SymNPoint(32 To 128) As Integer, SymAddr(32 To 128) As Integer
Public PictureMesh As PictureBox
Public TheEarthQuakeFile As String
Public MinTime As Long, MaxTime As Long, MMin As Double, MMax As Double
Public LonMin As Double, LonMax As Double, LonStep As Double, Lon As Double, LonN As Integer
Public LatMin As Double, LatMax As Double, LatStep As Double, Lat As Double, LatN As Integer
Public Sub MaxnDec(Ymin As Single, Ymax As Single, nDec As Integer, StrMax As String, FormatTMP As String)
Dim ValueMax As Single, Delta As Single, StrYmin As String, StrYmax As String
If (Abs(Ymax) > Abs(Ymin)) Then
ValueMax = Abs(Ymax)
Else
ValueMax = Abs(Ymin)
End If
Delta = Abs(Ymax - Ymin)
If (Delta < 0.001 Or ValueMax < 0.001) Then
nDec = 5
FormatTMP = "######0.00000"
StrYmin = Format(Ymin, "######0.00000")
StrYmax = Format(Ymax, "######0.00000")
ElseIf (Delta < 0.01 Or ValueMax < 0.01) Then
nDec = 4
FormatTMP = "######0.0000"
StrYmin = Format(Ymin, "######0.0000")
StrYmax = Format(Ymax, "######0.0000")
ElseIf (Delta < 0.1 Or ValueMax < 0.1) Then
nDec = 3
FormatTMP = "######0.000"
StrYmin = Format(Ymin, "######0.000")
StrYmax = Format(Ymax, "######0.000")
ElseIf (Delta < 1# Or ValueMax < 1#) Then
nDec = 2
FormatTMP = "######0.00"
StrYmin = Format(Ymin, "######0.00")
StrYmax = Format(Ymax, "######0.00")
ElseIf (Delta < 10# Or ValueMax < 10#) Then
nDec = 1
FormatTMP = "######0.0"
StrYmin = Format(Ymin, "######0.0")
StrYmax = Format(Ymax, "######0.0")
Else
FormatTMP = "######0"
StrYmin = Format(Ymin, "######0")
StrYmax = Format(Ymax, "######0")
nDec = 0
End If
StrMax = StrYmax
If (Len(StrYmin) > Len(StrMax)) Then StrMax = StrYmin
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
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 ContouWrite(value As Single, Key As Integer, LD As Integer, DwX() As Single, DwY() As Single)
Dim I As Integer
If (Key = 2) Then '闭曲线
LD = LD + 1
DwX(LD) = DwX(1)
DwY(LD) = DwY(1)
End If
Print #OutNo, LD, value, CurFillColor, CurForeColor, bFillColor, bMarkColor, iMark
For I = 1 To LD
Print #OutNo, Xmin0p + DwX(I), Ymin0p + DwY(I)
Next I
TotalSquare = TotalSquare + 1
End Sub
'曲线平滑
Private Sub Smooth(value As Single, nDec As Integer, S0 As Single, Key As Integer, K As Integer, LD As Integer, DwX() As Single, DwY() As Single, Zgrid() As Single)
Dim I As Integer, II1 As Integer, J As Integer, M As Integer, N1 As Integer
Dim T As Single, A(2) As Single
Dim Q0() As Single, Q1() As Single
Dim XY0() As Single, XY1() As Single
Dim JS As Integer, Js0 As Integer, S As Single, CS0 As Single
Dim DSx0 As Single, DSy0 As Single, DSx1 As Single, DSy1 As Single
Dim StrValue As String, FMT As String, DS0 As Single
Dim cAscii As Integer
Dim X() As Single, Y() As Single, N As Integer, ObjectLen As Single
Dim V(1 To 3) As Variant
ReDim Q0(1 To LD), Q1(1 To LD), XY0(1 To K * LD), XY1(1 To K * LD)
For I = 1 To LD
II1 = (I + 1) - Fix(I / LD) * LD
Q0(I) = 0.5 * (DwX(I) + DwX(II1))
Q1(I) = 0.5 * (DwY(I) + DwY(II1))
Next I
If (nDec = 0) Then
FMT = "#####0"
Else
FMT = "#####0."
For I = 1 To nDec
FMT = FMT + "0"
Next I
End If
StrValue = Trim(Format(value, FMT))
DS0 = Hslz * Len(StrValue) / XYFact
If (iMark = 1) Then
If (Key = 2) Then
CS0 = S0 * DS0 / 2#
Else
CS0 = S0 * DS0
End If
Else
CS0 = 10000000000#
End If
JS = 0
Js0 = 1
S = 0
If (Key = 2) Then '闭曲线
N = 1 + LD * K
ReDim X(1 To N), Y(1 To N)
X(1) = Xmin0p + Q0(1)
Y(1) = Ymin0p + Q1(1)
N = 1
For I = 1 To LD
II1 = (I + 1) - Fix(I / LD) * LD
For M = 1 To K
T = 1# * M / K
A(0) = F1(T) * Q0(I) + F2(T) * DwX(II1) + F3(T) * Q0(II1)
A(1) = F1(T) * Q1(I) + F2(T) * DwY(II1) + F3(T) * Q1(II1)
N = N + 1
X(N) = Xmin0p + A(0)
Y(N) = Ymin0p + A(1)
Next M
Next I
Else '开曲线
N = 3 + (LD - 2) * K
ReDim X(1 To N), Y(1 To N)
X(1) = Xmin0p + DwX(1)
Y(1) = Ymin0p + DwY(1)
X(2) = Xmin0p + Q0(1)
Y(2) = Ymin0p + Q1(1)
N = 2
N1 = LD - 1
For I = 2 To N1
For M = 1 To K
T = 1# * M / K
A(0) = F1(T) * Q0(I - 1) + F2(T) * DwX(I) + F3(T) * Q0(I)
A(1) = F1(T) * Q1(I - 1) + F2(T) * DwY(I) + F3(T) * Q1(I)
N = N + 1
X(N) = Xmin0p + A(0)
Y(N) = Ymin0p + A(1)
Next M
Next I
N = N + 1
X(N) = Xmin0p + DwX(LD)
Y(N) = Ymin0p + DwY(LD)
End If
Call MIFMID_MakePen(PenWidthT, 2, CurForeColor)
Call MIFMID_CreatePolyLine(X, Y, N, False)
V(1) = Format(value, FMT)
V(2) = ""
Call OutMID(V)
End Sub
Private Function F1(T As Single) As Single
F1 = 1# - 2# * T + T * T
End Function
Private Function F2(T As Single) As Single
F2 = 2# * T - 2# * T * T
End Function
Private Function F3(T As Single) As Single
F3 = T * T
End Function
'绘曲线子程序
Private Sub PlotCurve(X As Single, Y As Single, ipen As Integer)
Dim Xnew As Single, Ynew As Single
If (bPictureMesh = True) Then
Xnew = WcsX0 + X * XYFact
Ynew = WcsY0 - Y * XYFact
If (ipen = 2) Then
PictureMesh.Line (Xold, Yold)-(Xnew, Ynew)
End If
Else
'Xnew = Xmin0p + X
'Ynew = Ymin0p + Y
Xnew = X - Xminp
Ynew = Y - Yminp
If (ipen = 2) Then
Call MIFMID_CreateLine(Xold, Yold, Xnew, Ynew)
End If
End If
Xold = Xnew
Yold = Ynew
End Sub
'三角法绘平面等值线
Public Sub Contou23(ParValue() As Single, nHvalue As Integer, S0 As Single, nDec As Integer)
Dim DwX() As Single, DwY() As Single
Dim Xb() As Single, Yb() As Single, LB() As Integer
Dim X1 As Single, Y1 As Single
Dim Hs As Single, Ht As Single, Hw As Single
Dim C1 As Single, c2 As Single, C3 As Single, C4 As Single
Dim Ida As Integer, mk As Integer, M1 As Integer
Dim I As Integer, J As Integer, K As Integer, LD As Integer
Dim I1 As Integer, I2 As Integer, i3 As Integer, Key As Integer, Key301 As Integer, Key2 As Boolean
Dim nDwXY As Integer, Zgrid() As Single
Dim X0t As Single, Y0t As Single, Yc As Single, Xc As Single
Dim PicSubHeightT As Single, PicSubWidthT As Single
Dim Mk1 As Integer, ScaleHeight As Single, ScaleWidth As Single
K = 10
Xmin0p = 0#
Ymin0p = 0#
'打开MIFMID文件头
Call OutMIFMIDHeader2D(Xmin, Xmax, Ymin, Ymax)
'三角化
Call SJX
nDwXY = 2 * nSJX
ReDim DwX(nDwXY + 1), DwY(nDwXY + 1), LB(nDwXY + 1)
ReDim Xb(nSJX, 2), Yb(nSJX, 2)
Vmin = 999999
Vmax = -999999
For I = 0 To NContou
If (Zcontou(I) > Vmax) Then Vmax = Zcontou(I)
If (Zcontou(I) < Vmin) Then Vmin = Zcontou(I)
Next I
ValueMinCur = ValueMin
ColorMinCur = ColorMin
Mk1 = 0
For mk = 0 To nHvalue
value = ParValue(mk)
iMark = 1
If (value < Vmin Or value > Vmax) Then
Else
'插值
For I = 0 To nSJX
I1 = ID1(I)
I2 = ID2(I)
i3 = ID3(I)
M1 = -1
If (Zcontou(I1) = Zcontou(I2) And Zcontou(I2) = Zcontou(i3)) Then
Else
If (value = Zcontou(I1)) Then Zcontou(I1) = Zcontou(I1) + 0.0001
If (value = Zcontou(I2)) Then Zcontou(I2) = Zcontou(I2) + 0.0001
If (value = Zcontou(i3)) Then Zcontou(i3) = Zcontou(i3) + 0.0001
Hs = value - Zcontou(I1)
Ht = value - Zcontou(I2)
Hw = value - Zcontou(i3)
If (Hs * Ht < 0#) Then
M1 = M1 + 1
Xb(I, M1) = Xcontou(I1) + Hs * (Xcontou(I2) - Xcontou(I1)) / (Zcontou(I2) - Zcontou(I1))
Yb(I, M1) = Ycontou(I1) + Hs * (Ycontou(I2) - Ycontou(I1)) / (Zcontou(I2) - Zcontou(I1))
End If
If (Ht * Hw < 0#) Then
M1 = M1 + 1
Xb(I, M1) = Xcontou(I2) + Ht * (Xcontou(i3) - Xcontou(I2)) / (Zcontou(i3) - Zcontou(I2))
Yb(I, M1) = Ycontou(I2) + Ht * (Ycontou(i3) - Ycontou(I2)) / (Zcontou(i3) - Zcontou(I2))
End If
If (Hw * Hs < 0#) Then
M1 = M1 + 1
Xb(I, M1) = Xcontou(i3) + Hw * (Xcontou(I1) - Xcontou(i3)) / (Zcontou(I1) - Zcontou(i3))
Yb(I, M1) = Ycontou(i3) + Hw * (Ycontou(I1) - Ycontou(i3)) / (Zcontou(I1) - Zcontou(i3))
End If
If (M1 <> 1) Then
M1 = -1
End If
End If
LB(I) = M1
Next I
'搜索线头
For I1 = 0 To nSJX
If (LB(I1) = 1) Then
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -