layersymbol.frm

这个是grs源程序,mo在图象显示上很好,所以大家一定要下载

'Build a new tentative class breaks legend
Call PopulateNewCBlegend(cboCB(0).text)
cmdApply.Enabled = True
cmdOK.Enabled = True

End Sub

Private Sub cmdUV_Click()

'Build a new tentative unique values legend
Call PopulateNewUVlegend(cboUV.text)
cmdApply.Enabled = True
cmdOK.Enabled = True

End Sub

Private Sub cmdZR_Click()

'Build a new tentative Z elevation breaks legend
Call PopulateNewZRLegend
cmdApply.Enabled = True
cmdOK.Enabled = True

End Sub

Private Sub cboSSP_Click(Index As Integer)

Dim fnt As New StdFont

Select Case Index

  Case 0  'choose single symbol style
    If Index = 0 Then
      If cboSSP(0).text = "TrueType marker" Then
        Dim i As Integer
        cboSSP(1).Enabled = True
        cboSSP(2).Enabled = True
        lblSSP(3).Enabled = True
        lblSSP(4).Enabled = True
        lblSSP(5).Enabled = True
        lblSSP(7).Enabled = True
        hsbSSP.Enabled = True
        For i = 0 To Screen.FontCount - 1
          cboSSP(1).AddItem Screen.Fonts(i)
        Next i
        cboSSP(1).ListIndex = 0
        fnt.Name = cboSSP(1).text
        Set cboSSP(2).Font = fnt
        cboSSP(2).Clear
        For i = 0 To 255
          cboSSP(2).AddItem Chr(i)
        Next
        
       Else 'if not TT font, then disable controls specific to TT fonts
        cboSSP(1).Clear
        cboSSP(2).Clear
        cboSSP(1).Enabled = False
        cboSSP(2).Enabled = False
        lblSSP(3).Enabled = False
        lblSSP(4).Enabled = False
        lblSSP(5).Enabled = False
        lblSSP(7).Enabled = False
        hsbSSP.Enabled = False
      End If
    End If

  Case 1  'populate combobox list of TT font glyphs in the chosen font
    cboSSP(2).Clear
    fnt.Name = cboSSP(1).text
    Set cboSSP(2).Font = fnt
    For i = 0 To 255
      cboSSP(2).AddItem Chr(i)
    Next
    
End Select

End Sub


Private Sub hsbSSP_Change()

'Sets the rotation on a single symbol point marker
'that is using a TT font
lblSSP(7).Caption = hsbSSP.Value

End Sub

Private Sub hsbSL_Scroll()

'Sets the rotation on standard label text
lblSL(7).Caption = hsbSL.Value

End Sub

Private Sub hsbSL_Change()

'Sets the rotation on standard label text
lblSL(7).Caption = hsbSL.Value

End Sub

Private Sub picCBramp_Click(Index As Integer)

'Sets start and stop ramp colors for class breaks renderer
cdlgLayerProp.ShowColor
picCBramp(Index).BackColor = cdlgLayerProp.color

End Sub

Private Sub picNOL_Click()

'User changes the MaskColor of the LabelPlacer
If colorMask <> moWhite Then
  cdlgLayerProp.color = colorMask
End If
cdlgLayerProp.ShowColor
picNOL.BackColor = cdlgLayerProp.color
colorMask = cdlgLayerProp.color

'Turn on the MaskLabels check box
chkNOL(2).Value = 1

End Sub

Private Sub picSSP_Click(Index As Integer)

'Sets the color for single symbol rendering
cdlgLayerProp.ShowColor
picSSP(Index).BackColor = cdlgLayerProp.color

End Sub

Private Sub vsbUV_Change()

'If the legend preview is too large for its
'frame container, use the VSB to move it up
'and down on demand.
fraUVinner.Top = 200 - (vsbUV.Value * 200)

End Sub

Private Sub sstLayerProp_Click(PreviousTab As Integer)

'When the user clicks one of the renderer tabs, determine
'whether the active layer is already using that type of
'renderer.  Then...
'  ...if it is, then read the properties of that layer and
'     use those properties to load the various option
'     controls on that tab.  Use one of the "Load..." procedures.
'  ...or if it is not, then load the various option controls
'     controls on that tab with some default values.  Use
'     one of the "Init..." procedures.
'

Dim lyrRend As Object
lblPanelDesc.Caption = strPanelDesc(sstLayerProp.Tab)

If lyr.Renderer Is Nothing Then        'Use of the Point class here is arbitrary
  Set lyrRend = New MapObjects2.Point  'and only temporary in use.  VB's "TypeOf"
 Else                                  'keyword has trouble with "Nothing", which
  Set lyrRend = lyr.Renderer           'is what the Layer's Renderer property holds
End If                                 'when drawing the layer with a single symbol.
                                       
If PreviousTab = 2 Then
  If TypeOf lyrRend Is MapObjects2.ValueMapRenderer Then
    Exit Sub
  End If
End If

Select Case sstLayerProp.Tab
  Case 0
    If TypeOf lyrRend Is MapObjects2.Point Then
      Call LoadSingleSymbol
     Else
      Call InitSingleSymbol
    End If
  Case 1
    If TypeOf lyrRend Is MapObjects2.ValueMapRenderer Then
      Call LoadUniqueValues
     Else
      Call InitUniqueValues
    End If
  Case 2
    If TypeOf lyrRend Is MapObjects2.ClassBreaksRenderer Then
      Call LoadClassBreaks
     Else
      Call InitClassBreaks
    End If
  Case 3
    If TypeOf lyrRend Is MapObjects2.LabelRenderer Then
      Call LoadStandardLabels
     Else
      Call InitStandardLabels
    End If
  Case 4
    If TypeOf lyrRend Is MapObjects2.LabelPlacer Then
      Call LoadNoOverlapLabels
     Else
      Call InitNoOverlapLabels
    End If
  Case 5
    If TypeOf lyrRend Is MapObjects2.ZRenderer Then
      Call LoadZRenderer
     Else
      Call InitZRenderer
    End If
End Select

End Sub
'
'
'
'THE SIX PROCEDURES THAT FOLLOW, THAT BEGIN WITH THE WORD "INIT..."
'ARE THOSE THAT RUN WHEN A RENDERER IS CHOSEN WHICH DOES NOT
'COINCIDE WITH THE ACTIVE LAYER'S CURRENT RENDERER.  THE OPTION
'CONTROLS ON THAT TAB ARE LOADED WITH DEFAULT VALUES THAT THE USER
'CAN CHANGE.
'  InitSingleSymbol()
'  InitUniqueValues()
'  InitClassBreaks()
'  InitStandardLabels()
'  InitNoOverlapLabels()
'  InitZRenderer()
'
'
'
Private Sub InitSingleSymbol()

Dim i As Integer
Dim fnt As New StdFont

cboSSP(0).Clear
Select Case lyr.shapeType
  Case moShapeTypePoint
    'set control visibility
    cboSSP(1).Visible = True
    cboSSP(2).Visible = True
    chkSSP.Visible = False
    hsbSSP.Visible = True
    picSSP(1).Visible = False
    lblSSP(3).Visible = True
    lblSSP(4).Visible = True
    lblSSP(5).Visible = True
    lblSSP(6).Visible = False
    lblSSP(7).Visible = True
    'retrieve and display current values
    txtSSP(0).text = 5
    lblSSP(0).Caption = "Marker Color:"
    lblSSP(2).Caption = "Size:"
    For i = 0 To 4
      cboSSP(0).AddItem strMarkerStyle(i)
    Next
    picSSP(0).BackColor = moGreen
    cboSSP(0).text = strMarkerStyle(moSquareMarker)
    cboSSP(0).ListIndex = 1
    hsbSSP.Value = 0
    lblSSP(7).Caption = "0"
      cboSSP(1).Enabled = False
      cboSSP(2).Enabled = False
      lblSSP(3).Enabled = False
      lblSSP(4).Enabled = False
      lblSSP(5).Enabled = False
      lblSSP(7).Enabled = False
      hsbSSP.Enabled = False
    
  Case moShapeTypeMultipoint
    'set control visibility
    cboSSP(1).Visible = True
    cboSSP(2).Visible = True
    chkSSP.Visible = False
    hsbSSP.Visible = True
    picSSP(1).Visible = False
    lblSSP(3).Visible = True
    lblSSP(4).Visible = True
    lblSSP(5).Visible = True
    lblSSP(6).Visible = False
    lblSSP(7).Visible = True
    'retrieve and display current values
    txtSSP(0).text = 5
    lblSSP(0).Caption = "Marker Color:"
    lblSSP(2).Caption = "Size:"
    For i = 0 To 4
      cboSSP(0).AddItem strMarkerStyle(i)
    Next
    picSSP(0).BackColor = moGreen
    cboSSP(0).text = strMarkerStyle(moSquareMarker)
    cboSSP(0).ListIndex = 1
    hsbSSP.Value = 0
    lblSSP(7).Caption = "0"
      cboSSP(1).Enabled = False
      cboSSP(2).Enabled = False
      lblSSP(3).Enabled = False
      lblSSP(4).Enabled = False
      lblSSP(5).Enabled = False
      lblSSP(7).Enabled = False
      hsbSSP.Enabled = False
    
  Case moLine
    'set visibility
    cboSSP(1).Visible = False
    cboSSP(2).Visible = False
    chkSSP.Visible = False
    hsbSSP.Visible = False
    picSSP(1).Visible = False
    lblSSP(3).Visible = False
    lblSSP(4).Visible = False
    lblSSP(5).Visible = False
    lblSSP(6).Visible = False
    lblSSP(7).Visible = False
    'retrieve and display current values
    txtSSP(0).text = 1
    lblSSP(0).Caption = "Line Color:"
    lblSSP(2).Caption = "Line width:"
    For i = 0 To 4
      cboSSP(0).AddItem strLineStyle(i)
    Next
    picSSP(0).BackColor = moBlue
    cboSSP(0).text = strLineStyle(0)
    cboSSP(0).ListIndex = 0
  Case moPolygon
    'set visibility
    cboSSP(1).Visible = False
    cboSSP(2).Visible = False
    chkSSP.Visible = True
    hsbSSP.Visible = False
    picSSP(1).Visible = True
    lblSSP(3).Visible = False
    lblSSP(4).Visible = False
    lblSSP(5).Visible = False
    lblSSP(6).Visible = True
    lblSSP(7).Visible = False
    'retrieve and display current values
    txtSSP(0).text = "1"
    lblSSP(0).Caption = "Fill Color:"
    lblSSP(2).Caption = "Outline width:"
    For i = 0 To 10
      cboSSP(0).AddItem strFillStyle(i)
    Next
    picSSP(0).BackColor = moLightGray
    picSSP(1).BackColor = moBlack
    cboSSP(0).text = strFillStyle(0)
    cboSSP(0).ListIndex = 0
    chkSSP.Value = 1
End Select
cmdApply.Enabled = True
cmdOK.Enabled = True

End Sub

Private Sub InitUniqueValues()

Dim i As Integer

'Load ComboBox with layer field names
cboUV.Clear
For i = 0 To tDesc.FieldCount - 1
  cboUV.AddItem tDesc.FieldName(i)
Next
cboUV.ListIndex = 0

fraUVouter.Caption = "Legend Preview"

'If a legend already exists, unload it
If picUV.count > 1 Then
  For i = (picUV.count - 1) To 1 Step -1
    Unload picUV(i)
    Unload lblUV(i)
  Next
End If
picUV(0).Visible = False
lblUV(0).Visible = False

cmdApply.Enabled = False
cmdOK.Enabled = False
chkUV.Visible = (lyr.shapeType = moShapeTypePolygon)

End Sub

Private Sub InitClassBreaks()

Dim i As Integer
Dim fld As MapObjects2.Field

'Clear and reload ComboBoxes
cboCB(0).Clear
cboCB(0).AddItem "FeatureID"
cboCB(1).ListIndex = 3
For i = 0 To tDesc.FieldCount - 1
  Set fld = flds(tDesc.FieldName(i))
  If fld.Type = moDouble Or fld.Type = moLong Then
    cboCB(0).AddItem fld.Name
  End If
Next
cboCB(0).ListIndex = 0

'If a legend already exists, unload it
If picCBlegend.count > 1 Then
  For i = (picCBlegend.count - 1) To 1 Step -1
    Unload picCBlegend(i)
    Unload lblCBlegend(i)
  Next
End If
picCBlegend(0).Visible = False
lblCBlegend(0).Visible = False

cmdApply.Enabled = False
cmdOK.Enabled = False
chkCB.Visible = (lyr.shapeType = moShapeTypePolygon)

End Sub

Private Sub InitStandardLabels()

Dim i As Integer
For i = 0 To tDesc.FieldCount - 1
  cboSL(0).AddItem tDesc.FieldName(i)
  If tDesc.FieldType(i) = moLong Or _
     tDesc.FieldType(i) = moDouble Then
    cboSL(3).AddItem tDesc.FieldName(i)
    cboSL(4).AddItem tDesc.FieldName(i)
  End If
Next
cboSL(0).ListIndex = 0
cboSL(1).ListIndex = 1
cboSL(2).ListIndex = 1