module1.bas

vb+mapxvb+mo二次开发实现鹰眼功能

Attribute VB_Name = "Module1"
Option Explicit
Dim ColumnsN As Integer, Columns() As String, ColumnsType() As String
Dim NoCreateEllipse As Integer
Dim I As Integer
Public TableName As String
Public FeatureTemp As New MapXLib.Feature
Public FeatureFactoryTemp As MapXLib.FeatureFactory
Public PointTemp As New Point, PointsTemp As New Points
Public nField As Integer, nFields As Integer
Public StyleTemp As MapXLib.Style
Public LayerName As String
Public ds As New MapXLib.Dataset
Public RowValueTemp As New MapXLib.RowValue
Public RowValuesTemp As New MapXLib.RowValues

Private Sub Ellips(Xo As Single, Yo As Single, A As Single, B As Single, Al As Single, XX() As Single, YY() As Single, Nxy As Integer)
Dim THS As Double, THE As Double
Dim Ts As Double, Te As Double
Dim CA As Double, Sa As Double
Dim CTS As Double, STS As Double, CTE As Double, STE As Double
Dim Af As Double
Dim XE As Double, YE As Double
Dim X As Double, Y As Double
Dim DA As Double, N As Integer, N1 As Integer
Dim Dt As Double, Cd As Double, SD As Double
Dim A1 As Double, A2 As Double, B1 As Double, B2 As Double
Dim I As Integer, CC As Double, ss As Double
Dim X1 As Double, Y1 As Double

THS = 0#
THE = 0#
Af = Al * 0.0174533
Ts = THS * 0.0174533
Te = THE * 0.0174533
CA = Cos(Af)
Sa = Sin(Af)
CTS = Cos(Ts)
STS = Sin(Ts)
CTE = Cos(Te)
STE = Sin(Te)
XE = Xo + A * CTE * CA - B * STE * Sa
YE = Yo + A * CTE * Sa + B * STE * CA
X = Xo + A * CTS * CA - B * STS * Sa
Y = Yo + A * CTS * Sa + B * STS * CA

'Call Plot(X, Y, 3)
X1 = X
Y1 = Y

''DA = 1# / (A + B)
''N = Fix((Te - Ts) / DA)
''If (N = 0) Then N = Fix(2# * 3.14159 / DA)
N = 360

Dt = (Te - Ts) / N
If (Dt = 0#) Then Dt = 2# * 3.14159 / N
Cd = Cos(Dt)
SD = Sin(Dt)
A1 = A * SD * CA
A2 = A * SD * Sa
B1 = B * SD * CA
B2 = B * SD * Sa
N1 = N - 1
Nxy = N + 1
ReDim XX(1 To Nxy), YY(1 To Nxy)
XX(1) = XE
YY(1) = YE
XX(2) = X
YY(2) = Y
For I = 1 To N1
    CC = CTS
    ss = STS
    STS = ss * Cd + CC * SD
    CTS = CC * Cd - ss * SD
    X = Xo + (X - Xo) * Cd - A1 * ss - B2 * CC
    Y = Yo + (Y - Yo) * Cd - A2 * ss + B1 * CC
    'Call Plot(X, Y, 2)
    'Picture2.Line (X1, Y1)-(X, Y)
    X1 = X
    Y1 = Y
    XX(I + 2) = X
    YY(I + 2) = Y
Next I
'Call Plot(XE, YE, 2)
'Picture2.Line (X1, Y1)-(XE, YE)
''XX(Nxy) = X
''YY(Nxy) = Y

End Sub
Public Sub MapX_CreatePLine(X() As Single, Y() As Single, N As Integer, bSmooth As Boolean, Value() As Variant)
    For I = 1 To N
        PointTemp.Set X(I), Y(I)
        PointsTemp.Add PointTemp, N
    Next I
          
    Set FeatureTemp = FeatureFactoryTemp.CreateLine(PointsTemp, StyleTemp)
    FeatureTemp.Smooth = bSmooth
    
    For nField = 1 To nFields
        RowValueTemp.Field = ds.Fields.Item(nField)
        RowValueTemp.Value = Value(nField)
        RowValuesTemp.Add RowValueTemp
    Next nField
    EditLayer.AddFeature FeatureTemp, RowValuesTemp
End Sub
Public Sub MapX_MakePen(PenWidth As Integer, PenPattern As Integer, PenColor As Long)
    StyleTemp.LineWidth = PenWidth
    StyleTemp.LineStyle = PenPattern
    StyleTemp.LineColor = PenColor
End Sub

'创建多变形区域
Public Sub MapX_CreateRegion(X() As Single, Y() As Single, N As Integer, Value() As Variant)
    For I = 1 To N
        PointTemp.Set X(I), Y(I)
        PointsTemp.Add PointTemp, I
    Next I
    If (X(1) <> X(N) Or Y(1) <> Y(N)) Then '最后一点与第一点不重合
        PointTemp.Set X(1), Y(1)
        PointsTemp.Add PointTemp, N + 1
    End If

    Set FeatureTemp = FeatureFactoryTemp.CreateRegion(PointsTemp, StyleTemp)
    Set RowValueTemp.Field = ds.Fields.Item(1)
    
    For nField = 1 To nFields
        RowValueTemp.Field = ds.Fields.Item(nField)
        RowValueTemp.Value = Value(nField)
        RowValuesTemp.Add RowValueTemp
    Next nField
    EditLayer.AddFeature FeatureTemp, RowValuesTemp
End Sub
Public Sub MapX_MakeBrush(FillPattern As Integer, FillForeGround As Long, FillBackGround As Long, BorderStyle As Integer, BorderColor As Long, BorderWidth As Integer)
    StyleTemp.RegionPattern = FillPattern
    StyleTemp.RegionColor = FillForeGround
    StyleTemp.RegionBackColor = FillBackGround
    StyleTemp.RegionBorderStyle = BorderStyle
    StyleTemp.RegionBorderColor = BorderColor
    StyleTemp.RegionBorderWidth = BorderWidth
End Sub

Public Sub MapX_MakeSymbol(Shape As Integer, Color As Long, Size As Integer)
    StyleTemp.SymbolCharacter = Shape
    StyleTemp.SymbolVectorColor = Color
    StyleTemp.SymbolVectorSize = Size
End Sub

Public Sub MapX_CreateRect(X1 As Single, Y1 As Single, X2 As Single, Y2 As Single, Value() As Variant)
    PointTemp.Set X1, Y1
    PointsTemp.Add PointTemp, 1
            
    PointTemp.Set X2, Y1
    PointsTemp.Add PointTemp, 2
            
    PointTemp.Set X2, Y1
    PointsTemp.Add PointTemp, 2
            
    PointTemp.Set X2, Y2
    PointsTemp.Add PointTemp, 3
          
    PointTemp.Set X1, Y2
    PointsTemp.Add PointTemp, 4
          
    PointTemp.Set X1, Y1
    PointsTemp.Add PointTemp, 5
          
    Set FeatureTemp = FeatureFactoryTemp.CreateRegion(PointsTemp, StyleTemp)
    
    For nField = 1 To nFields
        RowValueTemp.Field = ds.Fields.Item(nField)
        RowValueTemp.Value = Value(nField)
        RowValuesTemp.Add RowValueTemp
    Next nField
    EditLayer.AddFeature FeatureTemp, RowValuesTemp
End Sub
Public Sub MapX_CreateLine(X1 As Single, Y1 As Single, X2 As Single, Y2 As Single, Value() As Variant)
    PointTemp.Set X1, Y1
    PointsTemp.Add PointTemp, 1
            
    PointTemp.Set X2, Y2
    PointsTemp.Add PointTemp, 2
          
    Set FeatureTemp = FeatureFactoryTemp.CreateLine(PointsTemp, StyleTemp)
    
    For nField = 1 To nFields
        RowValueTemp.Field = ds.Fields.Item(nField)
        RowValueTemp.Value = Value(nField)
        RowValuesTemp.Add RowValueTemp
    Next nField
    EditLayer.AddFeature FeatureTemp, RowValuesTemp
End Sub
'创建椭圆
Public Sub MapX_CreateEllipse(Lon As Single, Lat As Single, LongAxis As Single, ShortAxis As Single, Angle As Single, Value() As Variant)
    Dim Loni As Single, Lati As Single
    Dim Pi As Single, Cd As Single
    Dim XX() As Single, YY() As Single, Nxy As Integer

    Pi = 4 * Atn(1#)
    Cd = Pi / 180
    Call Ellips(0#, 0#, LongAxis, ShortAxis, Angle, XX, YY, Nxy)
    For I = 1 To Nxy
        Lati = Lat + YY(I) / 111.199
        Loni = Lon + XX(I) / (111.199 * Cos((Lat + Lati) * 0.5 * Cd))
        PointTemp.Set Loni, Lati
        PointsTemp.Add PointTemp, I
    Next I

    Set FeatureTemp = FeatureFactoryTemp.CreateRegion(PointsTemp, StyleTemp)
    
    For nField = 1 To nFields
        RowValueTemp.Field = ds.Fields.Item(nField)
        RowValueTemp.Value = Value(nField)
        RowValuesTemp.Add RowValueTemp
    Next nField
    EditLayer.AddFeature FeatureTemp, RowValuesTemp
End Sub

Public Sub MapX_CreateTable(FileSpec As String, Columns() As String, ColumnsTypeT() As String, ColumnsNt As Integer)
    Dim I As Integer, J As Integer
    Dim NumWidth As Integer, NumDec As Integer, TmpNum As Integer, TmpStr As Integer
    Dim ColumnsTemp As String, ColumnsTypeTemp As String
    Dim LayerInfo As New MapXLib.LayerInfo, flds As New MapXLib.Fields
    Dim DirFile As String

    ColumnsN = ColumnsNt
    nFields = ColumnsN
    
    FileSpec = Trim(FileSpec)
    I = InStr(FileSpec, ".")
    If (I = 0) Then
        FileSpec = FileSpec + ".TAB"
    End If
    DirFile = Dir(FileSpec)
    If (DirFile <> "") Then
        I = InStr(FileSpec, ".")
        DirFile = Left(FileSpec, I - 1) + "*"
        Kill DirFile
    End If
    
    I = InStrRev(FileSpec, "\")
    LayerName = Right(FileSpec, Len(FileSpec) - I)
    I = InStr(LayerName, ".")
    LayerName = Left(LayerName, I - 1)

    For I = 1 To ColumnsN
        ColumnsTemp = Trim(Columns(I))
        ColumnsTypeTemp = UCase(Trim(ColumnsTypeT(I)))
        If (InStr(ColumnsTypeTemp, "DECIMAL") > 0) Then '十进制型
            J = InStr(ColumnsTypeT(I), ",")
            NumWidth = Val(Mid(ColumnsTypeT(I), 9, J - 9))
            NumDec = Val(Mid(ColumnsTypeT(I), J + 1, 1))
            flds.AddNumericField ColumnsTemp, NumWidth, NumDec
        ElseIf (InStr(ColumnsTypeTemp, "CHAR") > 0) Then '字符型
            J = InStr(ColumnsTypeT(I), ")")
            NumWidth = Val(Mid(ColumnsTypeT(I), 6, J - 6))
            flds.AddStringField ColumnsTemp, NumWidth
        ElseIf (InStr(ColumnsTypeTemp, "INTEGER") > 0) Then '整型
            flds.AddIntegerField ColumnsTemp
        ElseIf (InStr(ColumnsTypeTemp, "SMALLINT") > 0) Then '短整型
            flds.AddSmallIntField ColumnsTemp
        ElseIf (InStr(ColumnsTypeTemp, "DATE") > 0) Then '日期型
            flds.AddDateField ColumnsTemp
        ElseIf (InStr(ColumnsTypeTemp, "LOGICAL") > 0) Then '逻辑型
            flds.AddLogicalField ColumnsTemp
        Else 'If (InStr(ColumnsTypeTemp, "FLOAT") > 0) Then '浮点型
            flds.AddFloatField ColumnsTemp
        End If
    Next I

    LayerInfo.Type = 7 'miLayerInfoTypeNewTab
    LayerInfo.AddParameter "FileSpec", FileSpec
   
    LayerInfo.AddParameter "Name", LayerName
    LayerInfo.AddParameter "Fields", flds
    
    '将新建图层加入到数据集
    LayerInfo.AddParameter "AutoCreateDataset", 1
    LayerInfo.AddParameter "DataSetName", LayerName
    
    frmD.Map1.Layers.Add LayerInfo, 1
    
    Set StyleTemp = frmD.Map1.DefaultStyle
   '若要为新表创建投影，则先要设置Map1.NumericCoorsys.
    FormMain.Map1.NumericCoordSys.Set 1, 0, 13
    FormMain.Map1.MapUnit = FormMain.Map1.NumericCoordSys.Units
    Set ds = frmD.Map1.DataSets(LayerName)
    Set FeatureFactoryTemp = FormMain.Map1.FeatureFactory
    Set EditLayer = FormMain.Map1.Layers.Item(LayerName)
    EditLayer.Editable = True
    StyleTemp.SymbolFont = "Map Symbols"
    Set RowValueTemp.Dataset = FormMain.Map1.DataSets.Item(EditLayer)
End Sub
Public Sub MapX_CreateSymbol(X As Single, Y As Single, V() As Variant)
    PointTemp.Set X, Y
    Set FeatureTemp = FeatureFactoryTemp.CreateSymbol(PointTemp, StyleTemp)
        
    For nField = 1 To nFields
        Set RowValueTemp.Field = ds.Fields.Item(nField)
        
        RowValueTemp.Value = V(nField)
        RowValuesTemp.Add RowValueTemp
    Next nField
    EditLayer.AddFeature FeatureTemp, RowValuesTemp
End Sub

Public Sub MapX_CreateCircle(X As Single, Y As Single, Radius As Single, Value() As Variant)
    PointTemp.Set X, Y
    If frmD.Map1.NumericCoordSys.Type = 0 Then
        Set FeatureTemp = FeatureFactoryTemp.CreateCircularRegion(0, PointTemp, Radius, MapUnit, 32, StyleTemp)
    Else
        Set FeatureTemp = FeatureFactoryTemp.CreateCircularRegion(1, PointTemp, Radius, MapUnit, 32, StyleTemp)
    End If

    Set FeatureTemp = FeatureFactoryTemp.CreateLine(PointsTemp, StyleTemp)
    
    For nField = 1 To nFields
        RowValueTemp.Field = ds.Fields.Item(nField)
        RowValueTemp.Value = Value(nField)
        RowValuesTemp.Add RowValueTemp
    Next nField
    EditLayer.AddFeature FeatureTemp, RowValuesTemp
End Sub