📄 contou.bas
字号:
Attribute VB_Name = "Module5"
Option Explicit
Private Type LOGFONT_TYPE
lfHeight As Long '字符高度(点数)
lfWidth As Long '字符宽度
lfEscapement As Long '转转角度(精度0.1)
lfOrientation As Long '字符基线相对于窗体底边角度（精度0.1）
lfWeight As Long '笔画粗细(0～1000）
lfItalic As Byte '1为斜体
lfUnderline As Byte '1为带下划线
lfStrikeOut As Byte '1为在字符中间划一条线
lfCharSet As Byte '字符集
lfOutPrecision As Byte '输出字体要求与字体的吻合度
lfClipPrecision As Byte '描述如何裁减位于裁减区以外的字符
lfQuality As Byte '逻辑字体与物理字体的匹配程度
lfPitchAndFamily As Byte '描述字库所属簇号
lfFaceName As String * 32 '字体字样
End Type
Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT_TYPE) As Long
Public Type POINTAPI
X As Long
Y As Long
End Type
Public Type ParFillType
value As Single
bFillColor As Integer
FillColor As Long
FillColorInit As Long
bMarkColor As Integer
MarkColor As Long
iMark As Integer
MarkColorInit As Long
End Type
Public Type ParFillTypeT
FillColor As Long
BackColor As Long
End Type
Public Type ParMoveType
TheContouFile As String * 50
Compute As Boolean
ColorMin As Long '底色
ValueMin As Single
Make As Byte '是否已建立参数
DataType As Byte '数据类型,0-网格数据，1-散乱数据
iOptionContou As Byte '图形类型,0-平面等值线，1-立体等值线，2-立体表面图
Xmin As Single 'X最小值
Xmax As Single 'X最大值
Ymin As Single 'Y最小值
Ymax As Single 'Y最大值
Vmin As Single '最小值
Vmax As Single '最大值
Vd As Single '步长
Vn As Integer '等值线数
nDec As Byte '小数位数
iCheckFillColor As Integer '是否填色
lStartColorFill As Long '最小值填充颜色
lEndColorFill As Long '最大值填充颜色
iOptionFill As Byte '填充图例
bFill As Boolean
bPlotLine As Byte '是否画线
iCheckContouMarkColor As Integer '是否绘等值线线
lStartColorCurve As Long '最小值线条颜色
lEndColorCurve As Long '最大值线条颜色
DeltaN As Byte '间隔几条线标注
S0 As Single '等值线上的标注间距
Hslz As Single '标注字符高度(点)
AngXY As Integer '视线方位角(度)
AngZ As Integer '视线俯视角(度)
KZ As Integer 'Z坐标放大系数
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 PaperHeight As Single, PaperWidth 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 ParFill() As ParFillType, bMarkColor As Integer, bFillColor As Integer, iMark As Integer
Public ParFillT() As ParFillTypeT
Public ParMove() As ParMoveType, nMove As Integer, IndexMove 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 TheMapInfoPath As String, TheOutFile As String
Public ThePublicInPath As String, TheInPath As String, TheInFile As String, TheInIndex As String
Public ThePublicOutPath As String, TheInstallPath As String, TheDataBasePath As String
Public ThePublicPicturePath 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 bOKCancel As Boolean
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 iMapType As Integer
Public Sub ClipRegionDLL(TheEarthQuakeName As String, Index As Integer)
Dim MapperInfoCoordSys As String, TableInfoCoordSys As String
Dim TheOutFile As String
Dim N As Integer, M As Integer, nPolyGons As Integer
Dim X1 As Single, Y1 As Single, X2 As Single, Y2 As Single
Dim MinX As Single, MinY As Single, MaxX As Single, MaxY As Single
Dim StrLonLat As String
Dim I As Integer, J As Integer, K As Integer, nLayerName As Integer, Temp As Single
Dim Str As String, DoStr As String, RowID As Integer, ABLR As String * 1, StrLatLon As String
Dim LayerName As String, TableName As String
Dim TempTableName() As String, Col1 As String, ColN As String
Dim bKill As Boolean
Dim TheLabelInfo As String, StrTemp As String
Screen.MousePointer = 11
On Error Resume Next
'获取当前显示投影参数
mapWinID = CLng(MapInfo.Eval("FrontWindow()"))
MapperInfoCoordSys = MapInfo.Eval("MapperInfo(" & mapWinID & ",17)")
nLayerName = CInt(MapInfo.Eval("MapperInfo(" & mapWinID & ",9)"))
'Begin判断经纬网是否存在
TableName = ""
For I = 1 To nLayerName
LayerName = MapInfo.Eval("LayerInfo(" & mapWinID & "," & I & ",1)")
J = InStr(LayerName, Chr(0))
If (J > 0) Then LayerName = Left(LayerName, J - 1)
Col1 = UCase(MapInfo.Eval("ColumnInfo(""" & LayerName & """,""col1"",1)"))
If (InStr(Col1, "经纬度刻度") > 0) Then
MapInfo.do "Select * From " & LayerName & " Where 经纬度刻度=""边框"""
N = Val(MapInfo.Eval("SelectionInfo(3)"))
If (N = 1) Then
MapInfo.do "OBJ_Temp=Selection.OBJ"
MapInfo.do "OBJ_Temp=ConvertToRegion(OBJ_Temp)"
MapInfo.do "OBJ_Temp1=OBJ_Temp"
'删除装饰图层上的全部对象
MapInfo.do "Set Map Layer 0 Editable ON"
MapInfo.do "Delete from Cosmetic1"
MapInfo.do "Insert Into Cosmetic1(Object) values (OBJ_Temp)"
MapInfo.do "Commit Table Cosmetic1 As ""C:\Temp0.TAB"" TYPE NATIVE Charset ""WindowsSimpChinese"" " & MapperInfoCoordSys
MapInfo.do "Open Table ""C:\Temp0.TAB"" as Temp0"
MapInfo.do "Add Map Layer Temp0"
'删除装饰图层上的全部对象
MapInfo.do "Delete from Cosmetic1"
TableName = LayerName
End If
Exit For
End If
Next I
'End判断经纬网是否存在
Screen.MousePointer = 0
If (TableName = "") Then Exit Sub
Screen.MousePointer = 11
nLayerName = 1
ReDim TempTableName(0 To 2, 1 To nLayerName)
Kill "c:\临时文件*.*"
MapInfo.do "Rename Table " & TheEarthQuakeName & " As """ & "C:\临时文件" & """"
I = 1
LayerName = "临时文件"
TheOutFile = TheEarthQuakeName
TempTableName(0, I) = LayerName
TempTableName(1, I) = TheMapInfoPath + TheOutFile + ".TAB"
TempTableName(2, I) = TheOutFile
'Begin确保数据投影与显示投影相同
bKill = False
LayerName = TempTableName(0, I)
'当显示投影与数据投影不一致时,改变数据投影方式
TableInfoCoordSys = MapInfo.Eval("TableInfo(" & LayerName & ",29)")
If (TableInfoCoordSys <> MapperInfoCoordSys) Then
'按当前显示投影参数存放临时文件
TempTableName(0, I) = "TempLSL" + Format(I, "##0")
TheOutFile = "C:\" + TempTableName(0, I) + ".TAB"
MapInfo.do "Commit Table " & LayerName & " As """ & TheOutFile & """ TYPE NATIVE Charset ""WindowsSimpChinese"" " & MapperInfoCoordSys
'打开改变投影后的新表
MapInfo.do "Open Table """ & TheOutFile & """ as " & TempTableName(0, I)
MapInfo.do "Add Map Layer " & TempTableName(0, I)
'关闭原表
MapInfo.do "Close Table """ & LayerName & """"
bKill = True
End If
'End确保数据投影与显示投影相同
'Begin把完全在剪裁区域内或部分在剪裁区域内的对象留下
MapInfo.do "Select * From " & TempTableName(0, I) & " Where Obj Contains Part OBJ_Temp"
If (Val(MapInfo.Eval("SelectionInfo(3)")) > 0) Then
MapInfo.do "Commit Table Selection As """ & TempTableName(1, I) & """"
Else
TempTableName(1, I) = ""
End If
'End把完全在剪裁区域内或部分在剪裁区域内的对象留下
If (TempTableName(1, I) <> "") Then
MapInfo.do "Open Table """ & TempTableName(1, I) & """ as " & TempTableName(2, I)
'把裁减区域全部对象设置为目标
MapInfo.do "Select * From """ & TempTableName(2, I) & """"
MapInfo.do "Set Target On"
'设置裁减区域
MapInfo.do "Select * From Temp0"
N = Val(MapInfo.Eval("TableInfo(" & TempTableName(2, I) & ",4)"))
ColN = ""
For J = 1 To N
Col1 = MapInfo.Eval("ColumnInfo(""" & TempTableName(2, I) & """,""col" & J & """,1)")
K = InStr(Col1, Chr(0))
If (K > 0) Then Col1 = Left(Col1, K - 1)
ColN = ColN + " " + Col1 + "=" + Col1 + ","
Next J
ColN = Left(ColN, Len(ColN) - 1)
'删除裁减区域外部对象
MapInfo.do "Objects Intersect Into Target Data " & ColN
'存储表
MapInfo.do "Commit Table " & TempTableName(2, I)
'压缩表
MapInfo.do "Pack Table " & TempTableName(2, I) & " Graphic Data"
'关闭表
MapInfo.do "Close Table """ & TempTableName(2, I) & """"
End If
'删出旧图层
MapInfo.do "Close Table """ & TempTableName(0, I) & """"
'添加新图层
MapInfo.do "Open Table """ & TempTableName(1, I) & """ as " & TempTableName(2, I)
MapInfo.do "Add Map Layer " & TempTableName(2, I)
'删出备份装饰图层
MapInfo.do "Close Table ""Temp0"""
'删除装饰图层上的矩形
MapInfo.do "Delete from Cosmetic1"
If (bKill = True) Then
'删除临时文件
Kill "C:\TempLSL*.*"
End If
'新图层放位置
If (Index > 1) Then
MapInfo.do "Set Map redraw off"
nLayerName = CInt(MapInfo.Eval("MapperInfo(" & mapWinID & ",9)"))
StrTemp = "Set Map Order "
For I = 2 To nLayerName
StrTemp = StrTemp + Format(I, "##0") + ","
Next I
StrTemp = StrTemp + "1"
MapInfo.do StrTemp
MapInfo.do "Set Map redraw on"
End If
mmPaperHeight = Screen.Height / 56.7
mmPaperWidth = Screen.Width / 56.7
FileType = "BMP"
TheOutFile = ThePublicPicturePath + TheEarthQuakeName
J = InStr(TheOutFile, ".")
If (J > 0) Then
TheOutFile = Left(TheOutFile, J) + "BMP"
Else
TheOutFile = TheOutFile + ".BMP"
End If
MapInfo.do "Save Window " & mapWinID & " As """ & TheOutFile & """ Type """ & FileType & """ Width " & mmPaperWidth & " units ""mm"" Height " & mmPaperHeight & " units ""mm"""
If (nSelected > 1) Then
MapInfo.do "Close Table """ & TheEarthQuakeName & """"
MapInfo.do "Close Table """ & TheEarthQuakeName & "图例"""
End If
Screen.MousePointer = 0
End Sub
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
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -