layersymbol.frm

用于河南省主体功能区区划的一个小地理信息系统

            Select Case True
            Case TypeOf gr.Renderer(0) Is MapObjects2.ValueMapRenderer
                Set lyr.Renderer = gr.Renderer(0)
                sstLayerProp.Tab = 1
            Case TypeOf gr.Renderer(0) Is MapObjects2.ClassBreaksRenderer
                Set lyr.Renderer = gr.Renderer(0)
                sstLayerProp.Tab = 2
            End Select
        End If
    End If
Case 3
   If TypeOf lyr.Renderer Is MapObjects2.GroupRenderer Then
        Set gr = lyr.Renderer
        For i = 0 To gr.Count - 1
        If TypeOf gr.Renderer(i) Is MapObjects2.LabelPlacer Then
            gr.Remove (i)
            txtgr(3).Text = ""
        End If
        Next i
        If gr.Count = 1 Then
            Select Case True
            Case TypeOf gr.Renderer(0) Is MapObjects2.ValueMapRenderer
                Set lyr.Renderer = gr.Renderer(0)
                sstLayerProp.Tab = 1
            Case TypeOf gr.Renderer(0) Is MapObjects2.ClassBreaksRenderer
                Set lyr.Renderer = gr.Renderer(0)
                sstLayerProp.Tab = 2
            End Select
        End If
    End If
    
End Select
 'Rename the layer with the contents of txtLayerName.Text
    lyr.Name = txtLayerName.Text
    frmmain.legend1.LoadLegend
    'Redraw the map
    frmmain.Map1.Refresh
End Sub

Private Sub Form_Load()

Dim i As Integer
Dim fnt As New StdFont

'Position this form into the top right
'corner of the screen
Me.Top = 0
Me.Left = Screen.Width - Me.Width

colorText = moBlack
colorMask = moWhite

'picLayerProp.Picture = LoadPicture(App.path & "\bitmaps\class.bmp")
Set lyr = frmmain.g_activelayer

If lyr Is Nothing Then
 MsgBox "lyr is nothing"
End If

Set recs = lyr.Records
Set tDesc = recs.TableDesc
Set flds = recs.Fields

'frmLayerSymbol.Caption = UCase(lyr.name) & "层" & "符号性质 "
strPanelDesc(0) = "用同一符号表示某层中所有特征"
strPanelDesc(1) = "根据字段中各值分别以不同符号表示图层特征"
strPanelDesc(2) = "根据一系列离散点值分类表示图层特征"
strPanelDesc(3) = "根据字段中各值标注图层特征"
strPanelDesc(4) = "根据字段中各值标注图层特征，并试图解决标注间相互覆盖、拥挤等现象"
strPanelDesc(5) = "自定义分类区间表示图层特征"
txtLayerName = lyr.Name

strMarkerStyle(0) = "圆"
strMarkerStyle(1) = "正方形"
strMarkerStyle(2) = "三角形"
strMarkerStyle(3) = "十字"
strMarkerStyle(4) = "TrueType字体"
strLineStyle(0) = "实线"
strLineStyle(1) = "虚线"
strLineStyle(2) = "点线"
strLineStyle(3) = "点划线"
strLineStyle(4) = "划点点线"
strFillStyle(0) = "实体"
strFillStyle(1) = "透明"
strFillStyle(2) = "水平线"
strFillStyle(3) = "垂直线"
strFillStyle(4) = "向上对角线"
strFillStyle(5) = "向下对角线"
strFillStyle(6) = "十字线"
strFillStyle(7) = "对角十字线"
strFillStyle(8) = "淡灰色"
strFillStyle(9) = "灰色"
strFillStyle(10) = "深灰色"

justOpened = True

'Read the contents of the active layer's Renderer property.
'Run one of the "Load..." procedures to populate the appropriate
'tab with the current renderer's properties.
Select Case True
  Case lyr.Renderer Is Nothing
    sstLayerProp.Tab = 0
    Call LoadSingleSymbol
  Case TypeOf lyr.Renderer Is MapObjects2.ValueMapRenderer
    sstLayerProp.Tab = 1
    Call LoadUniqueValues
  Case TypeOf lyr.Renderer Is MapObjects2.ClassBreaksRenderer
    sstLayerProp.Tab = 2
    Call LoadClassBreaks
  Case TypeOf lyr.Renderer Is MapObjects2.LabelRenderer
    sstLayerProp.Tab = 3
    Call LoadStandardLabels
  Case TypeOf lyr.Renderer Is MapObjects2.LabelPlacer
    sstLayerProp.Tab = 4
    colorMask = lyr.Renderer.MaskColor
    Call LoadNoOverlapLabels
  Case TypeOf lyr.Renderer Is MapObjects2.GroupRenderer
    sstLayerProp.Tab = 5
    Call Loadgr
  Case Else
    sstLayerProp.Tab = 0
    Call LoadSingleSymbol
End Select

'If the active layer does not support Z shapes, disable
'the "Elevation" rendering tab.
'If (InStr(lyr.Tag, "[SHAPEFILZ]") = 0) And (InStr(lyr.Tag, "[SDEZ]") = 0) Then
'  sstLayerProp.TabEnabled(5) = False
'End If

End Sub

Private Sub cmdApply_Click()

'When the user hits the Apply button (or the OK button)
'read the option controls on the active tab, and use
'them to build a new renderer with which to draw the layer.
Select Case sstLayerProp.Tab
  Case 0: Call ApplySingleSymbol
  Case 1: Call ApplyUniqueValues
  Case 2: Call ApplyClassBreaks
  Case 3: Call ApplyStandardLabels
  Case 4: Call ApplyNoOverlapLabels
'>>>>  Case 5: Call applygr
End Select

'Rename the layer with the contents of txtLayerName.Text
lyr.Name = txtLayerName.Text

'Refresh the map legend
frmmain.TuLi.LoadLegend

'Redraw the map
frmmain.Map1.Refresh

End Sub

Private Sub Cmdcancel_Click()

'Throw away all work on this form.
'Layer retains original rendering information.
Unload frmLayerSymbol

End Sub
Private Sub Cmdok_Click()

'Use Apply, then unload
Call cmdApply_Click
Unload frmLayerSymbol
TXTchange = False
End Sub

Private Sub cmdNOL_Click()

'Choose font properties for the LabelPlacer
cdlgLayerProp.Color = colorText
cdlgLayerProp.Flags = cdlCFEffects Or cdlCFBoth
cdlgLayerProp.ShowFont
txtNOL.ForeColor = cdlgLayerProp.Color
txtNOL.Text = cdlgLayerProp.FontName
colorText = cdlgLayerProp.Color

End Sub

Private Sub cmdSL_Click()

'Choose font properties for the LabelRenderer
cdlgLayerProp.Flags = cdlCFEffects Or cdlCFBoth
cdlgLayerProp.ShowFont
txtSL.ForeColor = cdlgLayerProp.Color
txtSL.Text = cdlgLayerProp.FontName

End Sub

Private Sub cmdCB_Click()
TXTchange = False
'Build a new tentative class breaks legend
Call PopulateNewCBlegend(cboCB(0).Text)
cmdApply.Enabled = True
cmdOK.Enabled = True
TXTchange = 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 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 lblsizeuv_Click(Index As Integer)

End Sub



Private Sub picCBlegend_Click(Index As Integer)
On Error GoTo cancel
   CommonDialog1.Color = picCBlegend(Index).BackColor
   CommonDialog1.ShowColor
   picCBlegend(Index).BackColor = CommonDialog1.Color
   cbr.Symbol(Index).Color = picCBlegend(Index).BackColor
cancel:
End Sub

Private Sub picCBramp_Click(Index As Integer)

'Sets start and stop ramp colors for class breaks renderer
cdlgLayerProp.Color = picCBramp(Index).BackColor
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
  cdlgLayerProp.Flags = 1
End If
cdlgLayerProp.Color = picNOL.BackColor
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.Color = picSSP(Index).BackColor
cdlgLayerProp.ShowColor
picSSP(Index).BackColor = cdlgLayerProp.Color

End Sub

Private Sub picUV_Click(Index As Integer)
On Error GoTo cancel
   CommonDialog1.Color = picUV(Index).BackColor
   CommonDialog1.ShowColor
   picUV(Index).BackColor = CommonDialog1.Color
   vmr.Symbol(Index).Color = picUV(Index).BackColor
cancel:
End Sub

Private Sub txtcblegend_Change(Index As Integer)
If TXTchange = True And Index < cboCB(1).Text - 1 Then


txtcblegend(Index).Text = Format(txtcblegend(Index).Text, "#0.00")
   lblcblegend(Index + 1).Caption = txtcblegend(Index).Text

End If

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
Dim i As Integer

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
    
    If TypeOf lyrRend Is MapObjects2.GroupRenderer Then
      justOpened = True
      For i = 0 To lyrRend.Count - 1
        If TypeOf lyrRend.Renderer(i) Is MapObjects2.ValueMapRenderer Then
          Call LoadUniqueValues