frmthem.frm

有关geomedia的一个全新的gis工程

VERSION 5.00
Begin VB.Form FrmThem 
   Caption         =   "分类"
   ClientHeight    =   3480
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   6660
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   3480
   ScaleWidth      =   6660
   StartUpPosition =   2  'CenterScreen
   Begin VB.CommandButton CmdAdd 
      Caption         =   "====>>"
      Height          =   375
      Left            =   2760
      TabIndex        =   8
      Top             =   1200
      Width           =   1335
   End
   Begin VB.ListBox LstClass 
      Height          =   2205
      Left            =   4200
      TabIndex        =   4
      Top             =   1200
      Width           =   2415
   End
   Begin VB.CommandButton CmdRange 
      Caption         =   "范围分类"
      Height          =   375
      Left            =   2760
      TabIndex        =   3
      Top             =   2400
      Width           =   1335
   End
   Begin VB.CommandButton CmdUnique 
      Caption         =   "唯一值分类"
      Height          =   375
      Left            =   2760
      TabIndex        =   2
      Top             =   1800
      Width           =   1335
   End
   Begin VB.ListBox LstAvailable 
      Height          =   2205
      Left            =   240
      TabIndex        =   1
      Top             =   1200
      Width           =   2295
   End
   Begin VB.ComboBox CmboFeatures 
      Height          =   315
      Left            =   240
      TabIndex        =   0
      Top             =   360
      Width           =   2295
   End
   Begin VB.Label Label3 
      Caption         =   "分类字段："
      Height          =   255
      Left            =   4200
      TabIndex        =   7
      Top             =   840
      Width           =   1215
   End
   Begin VB.Label Label2 
      Caption         =   "有效字段："
      Height          =   255
      Left            =   240
      TabIndex        =   6
      Top             =   840
      Width           =   1575
   End
   Begin VB.Label Label1 
      Caption         =   "地物类："
      Height          =   255
      Left            =   240
      TabIndex        =   5
      Top             =   120
      Width           =   1455
   End
End
Attribute VB_Name = "FrmThem"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim objUVL As UniqueValueLegendEntry
Dim objRLE As RangeLegendEntry
Dim objColor As ColorScheme, objColors As ColorSchemes
Dim selectRs As GRecordset
Dim iGeometryType As Integer
Dim objExt As Object
Dim ColorNum As Integer
Dim Colors() As Long
Dim objFont As Font
Dim objSFS As SymbolFileService
Dim objSYM As Symbol
Dim objPSS As PointSymbolStyle
Dim strName As String

Private Sub CmboFeatures_Click()
    Dim orgPip As OriginatingPipe
    Dim GField As GField
    LstAvailable.Clear
    gobjConnection.CreateOriginatingPipe orgPip
    orgPip.Table = CmboFeatures.List(CmboFeatures.ListIndex)
    Set selectRs = orgPip.OutputRecordset
    For Each GField In selectRs.GFields
    Select Case GField.Type
            Case gdbByte, gdbInteger, gdbLong, gdbSingle, gdbDouble
                LstAvailable.AddItem GField.Name
            'Ignore all other cases
            Case gdbBoolean
            Case gdbCurrency
            Case gdbDate
            Case gdbText
            Case gdbLongBinary
            Case gdbMemo
            Case gdbSpatial
            Case gdbGraphic
            Case Else
        End Select
    Next GField


End Sub

Private Sub CmdAdd_Click()
    LstClass.AddItem LstAvailable.List(LstAvailable.ListIndex)
    LstClass.ListIndex = 0
    If LstClass.SelCount = 1 Then
    CmdUnique.Enabled = True
    CmdRange.Enabled = True
    Else
    CmdUnique.Enabled = False
    CmdRange.Enabled = False
    End If
End Sub
Private Sub CmdRange_Click()
    Dim clsNum As Double
    clsNum = Val(InputBox("输入范围分类的数目："))
    Dim objColor As ColorScheme
    Dim objColors As ColorSchemes
    Set objColors = CreateObject("Geomedia.ColorSchemes")
    Set objColor = CreateObject("Geomedia.ColorScheme")
    ReDim Colors(clsNum + 1)
    Randomize
    For ColorNum = 0 To clsNum + 1
        Colors(ColorNum) = 16777215 * Rnd()
    Next ColorNum

    With objColor
        .Colors = Colors()
        .Name = "Random"
        .Type = 1 'gmcsRandom
    End With
    objColors.Append objColor
    Set objRLE = CreateObject("Geomedia.RangeLegendEntry")
    Set objRLE.ColorSchemes = objColors
    objRLE.ColorSchemeIndex = objRLE.ColorSchemes.Count
    Set objColors = Nothing
    Set objColor = Nothing

With objRLE
        .GeometryFieldName = "Geometry"
        Set .Recordset = selectRs
        Set objExt = selectRs.GetExtension("ExtendedPropertySet")
        iGeometryType = objExt.GetValue("GeometryType")
        Select Case iGeometryType
               Case gdbPoint
               Set objSFS = CreateObject("Geomedia.SymbolFileService")
               objSFS.FileName = App.Path & "\GISsym.fsm"
               strName = objSFS.SymbolNames.Item(1)
               Set objSYM = objSFS.GetSymbol(strName)
               Set objPSS = CreateObject("GeoMedia.PointSymbolStyle")
               Set objPSS.Symbol = objSYM
               Set .Style = objPSS
               Case gdbAreal
                Set .Style = New AreaStyle
               Case gdbLinear
               Set .Style = New LinearStyle
                Case gdbAnySpatial
                Set .Style = New AnyStyle
        End Select
       
        .Ascending = True
        .ContentsMode = gmalContentsModeDescription
        .Collapsed = False
        .Locatable = True
        .Selected = False
        .StatisticsMode = gmalStatisticsModeRange
        .Visible = True
        .AttributeFieldName = LstClass.List(LstClass.ListIndex)
        .SetRanges gmalRangeByEqualCount, clsNum
End With
    Dim objRange As Range
    For Each objRange In objRLE.Ranges
        objRange.Description = objRange.RangeMinimum & " to " _
               & objRange.RangeMaximum
        objRange.Include = True
    Next
    Set objRange = Nothing
    
    Set objFont = CreateObject("StdFont")
    With objFont
        .Name = "Arial"
        .Size = 10
        .Bold = True
    End With
    
    Set objRLE.TitleFont = objFont
    objRLE.TitleFontColor = RGB(0, 0, 100)
    objRLE.Title = CmboFeatures.List(CmboFeatures.ListIndex)
    Set objFont = Nothing
  
  
    Set objFont = CreateObject("StdFont")
    With objFont
        .Name = "Arial"
        .Size = 8
        .Italic = True
    End With

    Set objRLE.SubtitleFont = objFont
    objRLE.SubtitleFontColor = RGB(0, 0, 200)
    objRLE.Subtitle = "by " + LstClass.List(LstClass.ListIndex)
     Set objFont = Nothing
     
     Set objFont = CreateObject("StdFont")
    With objFont
        .Name = "Arial"
        .Size = 7
        .Italic = True
    End With

    Set objRLE.HeadingFont = objFont
    objRLE.HeadingFontColor = RGB(0, 100, 100)
    Set objFont = Nothing
    
If objRLE.ValidateSource Then
    If FrmMain.GMMapView1.Legend.LegendEntries.Count = 0 Then
           FrmMain.GMMapView1.Legend.LegendEntries.Append objRLE
    Else
        FrmMain.GMMapView1.Legend.LegendEntries.Append objRLE, 1
    End If
        objRLE.LoadData
End If
    FrmMain.GMMapView1.Legend.Fit
    FrmMain.GMMapView1.Legend.Visible = True
    FrmMain.GMMapView1.Fit
    FrmMain.GMMapView1.Refresh True
    Unload Me
Exit Sub

End Sub

Private Sub CmdUnique_Click()
On Error GoTo errhandle
    Dim objColorU As ColorScheme
    Dim objColorsU As ColorSchemes
    Dim DB As GDatabase
    Dim SubRes As GRecordset
    Dim SqlQuery As String
    Set objColorsU = CreateObject("Geomedia.ColorSchemes")
    Set objColorU = CreateObject("Geomedia.ColorScheme")
 
    Set objUVL = CreateObject("Geomedia.UniqueValueLegendEntry")
    Set DB = gobjConnection.Database
    SqlQuery = "select  distinct " & LstClass.List(LstClass.ListIndex) & " from " & CmboFeatures.Text
    Set SubRes = DB.OpenRecordset(SqlQuery, gdbOpenDynaset)
    SubRes.MoveLast
    SubRes.MoveFirst
    ReDim Colors(SubRes.RecordCount)
    Randomize
    For ColorNum = 0 To SubRes.RecordCount
        Colors(ColorNum) = 16777215 * Rnd()
    Next ColorNum

    With objColorU
        .Colors = Colors()
        .Name = "Random"
        .Type = 1 'gmcsRandom
    End With
    objColorsU.Append objColorU
    Set objUVL.ColorSchemes = objColorsU
    objUVL.ColorSchemeIndex = objUVL.ColorSchemes.Count
    Set objColorsU = Nothing
    Set objColorU = Nothing
With objUVL
        .GeometryFieldName = "Geometry"
         Set .Recordset = selectRs
        Set objExt = selectRs.GetExtension("ExtendedPropertySet")
        iGeometryType = objExt.GetValue("GeometryType")
        Select Case iGeometryType
               Case gdbPoint
               Set objSFS = CreateObject("Geomedia.SymbolFileService")
               objSFS.FileName = App.Path & "\GISsym.fsm"
               strName = objSFS.SymbolNames.Item(1)
               Set objSYM = objSFS.GetSymbol(strName)
               Set objPSS = CreateObject("GeoMedia.PointSymbolStyle")
               Set objPSS.Symbol = objSYM
               Set .Style = objPSS
               Case gdbAreal
                Set .Style = New AreaStyle
               Case gdbLinear
               Set .Style = New LinearStyle
                Case gdbAnySpatial
                Set .Style = New AnyStyle
        End Select

        .Ascending = True
        .ContentsMode = gmalContentsModeDescription
        .Collapsed = False
        .Locatable = True
        .AttributeFieldName = LstClass.List(LstClass.ListIndex)
        .SetValues gmalUniqueValueByFieldValues
End With

    Dim objUV As UniqueValue
    For Each objUV In objUVL.UniqueValues
        objUV.Description = objUV.Value
        objUV.Include = True
    Next
    Set objUV = Nothing
    
    Set objFont = CreateObject("StdFont")
    With objFont
        .Name = "Arial"
        .Size = 10
        .Bold = True
    End With
    
    Set objUVL.TitleFont = objFont
    objUVL.TitleFontColor = RGB(0, 0, 100)
    objUVL.Title = CmboFeatures.List(CmboFeatures.ListIndex)
    Set objFont = Nothing
  
  
    Set objFont = CreateObject("StdFont")
    With objFont
        .Name = "Arial"
        .Size = 8
        .Italic = True
    End With

    Set objUVL.SubtitleFont = objFont
    objUVL.SubtitleFontColor = RGB(0, 0, 200)
    objUVL.Subtitle = "by " + LstClass.List(LstClass.ListIndex)
     Set objFont = Nothing
     
     Set objFont = CreateObject("StdFont")
    With objFont
        .Name = "Arial"
        .Size = 7
        .Italic = True
    End With

    Set objUVL.HeadingFont = objFont
    objUVL.HeadingFontColor = RGB(0, 100, 100)
    Set objFont = Nothing
    
If objUVL.ValidateSource And objUVL.Status = gmlEntryValid Then
   If FrmMain.GMMapView1.Legend.LegendEntries.Count = 0 Then
        FrmMain.GMMapView1.Legend.LegendEntries.Append objUVL
    Else
        FrmMain.GMMapView1.Legend.LegendEntries.Append objUVL, 1
    End If
        objUVL.LoadData
End If
    FrmMain.GMMapView1.Legend.Fit
    FrmMain.GMMapView1.Legend.Visible = True
    FrmMain.GMMapView1.Fit
    FrmMain.GMMapView1.Refresh True
    Unload Me
Exit Sub
errhandle:
   If Err.Number = -2147220004 Then
   MsgBox "最大的分类数不能超过300，请选择其它字段分类"
   End If
   
End Sub

Private Sub Form_Load()
    Dim i As Integer
    Dim TableMask As Long
    Dim FeatureTables As Variant
    Dim objMDSrvc As New MetadataService
    Set objMDSrvc.Connection = gobjConnection
    TableMask = gmmtPoint Or gmmtLinear Or gmmtAreal Or gmmtAnySpatial
    objMDSrvc.GetTables TableMask, FeatureTables
    For i = LBound(FeatureTables) To UBound(FeatureTables) - 1
    CmboFeatures.AddItem FeatureTables(i)
    Next i
    CmdUnique.Enabled = False
    CmdRange.Enabled = False
    CmdAdd.Enabled = False
    Set objMDSvc = Nothing
End Sub

Private Sub LstAvailable_Click()
    If LstAvailable.SelCount > 0 Then
    CmdAdd.Enabled = True
    Else
    CmdAdd.Enabled = False
    End If
End Sub