frmlabeloptions.frm

这是一个 信息查询的小程序

    chkVisible.Value = vbChecked
Else
    txtLabelZoomMin.Text = ""
    txtLabelZoomMax.Text = ""
    txtLabelZoomMin.Enabled = False
    txtLabelZoomMax.Enabled = False
    txtLabelZoomMin.BackColor = vbButtonFace
    txtLabelZoomMax.BackColor = vbButtonFace
End If

End Sub

Private Sub chkVisible_Click()
If chkVisible.Value = vbChecked Then
   chkLabelZoom.Value = vbChecked
   chkLabelZoom_Click
End If

End Sub

Private Sub cmdCancel_Click()
Unload Me
End Sub

Private Sub cmdLabelStyle_Click()
m_styNew.PickText
End Sub

Private Sub cmdLineStyle_Click()
m_styNew.PickLine

End Sub

Private Sub cmdOk_Click()
Dim intIntemIndex As Integer
Dim i As Integer

'检查视野范围数据
If chkLabelZoom.Value = vbChecked Then
  
  If Not IsNumeric(txtLabelZoomMin.Text) Or (Val(txtLabelZoomMin.Text) < 0) Then
       MsgBox "视野值必须为>0 的数字！！", vbOKOnly + vbExclamation
       txtLabelZoomMin.SetFocus
       txtLabelZoomMin.SelStart = 0
       txtLabelZoomMin.SelLength = Len(txtLabelZoomMin.Text)

       Exit Sub
  End If


 If Not IsNumeric(txtLabelZoomMax.Text) Or (Val(txtLabelZoomMax.Text) < 0) Then
       MsgBox "视野值必须为>0 的数字！！", vbOKOnly + vbExclamation
       txtLabelZoomMax.SetFocus
       txtLabelZoomMax.SelStart = 0
       txtLabelZoomMax.SelLength = Len(txtLabelZoomMax.Text)

       Exit Sub
  End If
End If


'检查最大标注数据
If Not IsNumeric(txtLabelMax.Text) Or (Val(txtLabelMax.Text) < 0) Then
       MsgBox "最大标注数必须为>0 的数字！！", vbOKOnly + vbExclamation
       txtLabelMax.SetFocus
       txtLabelMax.SelStart = 0
       txtLabelMax.SelLength = Len(txtLabelMax.Text)

       Exit Sub
  End If
'检查标注偏移量数据

If Not IsNumeric(txtLabelOffset.Text) Or (Val(txtLabelOffset.Text) < 0) Then
       MsgBox "偏移量必须为>0 的数字！！", vbOKOnly + vbExclamation
       txtLabelOffset.SetFocus
       txtLabelOffset.SelStart = 0
       txtLabelOffset.SelLength = Len(txtLabelOffset.Text)

       Exit Sub
  End If
''检查当前层进入层控制对话框之后之否已经被修改国，若是，得到该层在记录修改信息的数组g_audtdispmodifiedlyr
'中的位置；若是还没被修改过，则扩充数组g_audtlpmodifiedlyr，保存信的修改过的信息记录

intItemIndex = checklayer(m_strCurLayerName)
If intItemIndex = 0 Then
   frmlayerdlg.m_intLPModifiedLyrCount = frmlayerdlg.m_intLPModifiedLyrCount + 1
   intItemIndex = frmlayerdlg.m_intLPModifiedLyrCount
   ReDim Preserve g_audtLPModifiedLyr(intItemIndex)
   g_audtLPModifiedLyr(intItemIndex).layername = m_strCurLayerName

End If

'保存当前层标注修改信息
If cboFields.ListCount > 0 Then
   g_audtLPModifiedLyr(intItemIndex).DataFieldName = cboFields.List(cboFields.ListIndex)
End If
 g_audtLPModifiedLyr(intItemIndex).LabelMax = Val(txtLabelMax)
If chkLabelZoom.Value = vbChecked Then
    g_audtLPModifiedLyr(intItemIndex).Labelzoom = True
    g_audtLPModifiedLyr(intItemIndex).LabelZoomMin = Val(txtLabelZoomMin.Text)
Else

   g_audtLPModifiedLyr(intItemIndex).Labelzoom = False
End If
   
  
  g_audtLPModifiedLyr(intItemIndex).Duplicate = (chkDuplicate.Value = vbChecked)
  g_audtLPModifiedLyr(intItemIndex).LineType = m_ltNew
  g_audtLPModifiedLyr(intItemIndex).Offset = Val(txtLabelOffset.Text)
 g_audtLPModifiedLyr(intItemIndex).Overlap = (chkOverlap.Value = vbChecked)
  g_audtLPModifiedLyr(intItemIndex).Parallel = (chkParallel.Value = vbChecked)
  g_audtLPModifiedLyr(intItemIndex).PartialSegments = (chkPartialSegments.Value = vbChecked)
  g_audtLPModifiedLyr(intItemIndex).Position = m_posNew
  
 Set g_audtLPModifiedLyr(intItemIndex).Style = m_styNew
  g_audtLPModifiedLyr(intItemIndex).Visible = (chkVisible.Value = vbChecked)
  
  
 
Unload Me








End Sub

Private Sub Form_Load()
Dim lpCur As MapXLib.LabelProperties
Dim intSelIndex As Integer
Dim ds As MapXLib.Dataset
Dim fld As MapXLib.Field
Dim fldSel As MapXLib.Field
Dim i As Integer


intSelIndex = frmlayerdlg.Lstlayers.ListIndex
m_strCurLayerName = frmlayerdlg.Lstlayers.List(intSelIndex)
Set m_lyrCur = frmlayerdlg.g_Map.Layers(m_strCurLayerName)
Set lpCur = m_lyrCur.LabelProperties
'图层缩放显示范围的单位为当前地图单位
Select Case frmlayerdlg.g_Map.MapUnit
Case miUnitMile
strUnit = "英里"
Case miUnitKilometer
strUnit = "公里"
Case miUnitInch
strUnit = "英寸"
Case miUnitFoot
strUnit = "英尺"
Case miUnitYard
strUnit = "码"
Case miUnitMillimeter
strUnit = "毫米"
Case miUnitCentimeter
strUnit = "厘米"
Case miUnitMeter
strUnit = "米"
Case miUnitSurveyFoot
strUnit = "测量英尺"
Case miUnitNauticalMile
strUnit = "海里"
Case miUnitTwip
strUnit = "缇"
Case miUnitPoint
strUnit = "磅"
Case miUnitPica
strUnit = "Pica"
Case miUnitDegree
strUnit = "度"
Case miUnitLink
strUnit = "令"
Case miUnitChain
strUnit = "链"
Case miUnitRod
strUnit = "杆"
End Select
lblUnitZoomMin.Caption = strUnit
lblUnitZoomMax.Caption = strUnit

'复制当前层标注样式
Set m_styNew = m_lyrCur.LabelProperties.Style.Clone
'判断当前层标注是否允许文本重复，设置相应复选框
chkDuplicate.Value = IIf(lpCur.Duplicate, vbChecked, vbUnchecked)
chkLabelZoom_Click
'判断当前层标注是否在一定视野范围内显示，设置相应复选框和文本框
chkLabelZoom.Value = IIf(lpCur.Labelzoom, vbChecked, vbUnchecked)
chkLabelZoom_Click

'判断当前层标注是否允许文本重叠，设置相应复选框
chkOverlap.Value = IIf(lpCur.Overlap, vbChecked, vbUnchecked)
'判断当前层标注是否标注部分线段，设置相应复选框
chkPartialSegments.Value = IIf(lpCur.PartialSegments, vbChecked, vbUnchecked)
'判断当前层标注是否沿线标注，设置相应复选框
chkParallel.Value = IIf(lpCur.Parallel, vbChecked, vbUnchecked)
'判断当前层标注是否可见，设置相应复选框
chkVisible.Value = IIf(lpCur.Visible, vbChecked, vbUnchecked)
'判断当前层标注位置，设置相应位置的选中状态
Select Case lpCur.Position
Case miPositionTL
picLabelPos_Click (0)
Case miPositionTC
picLabelPos_Click (1)
Case miPositionTR
picLabelPos_Click (2)
Case miPositionCL
picLabelPos_Click (3)
Case miPositionCC
picLabelPos_Click (4)
Case miPositionCR
picLabelPos_Click (5)
Case miPositionBL
picLabelPos_Click (6)
Case miPositionBC
picLabelPos_Click (7)
Case miPositionBR
picLabelPos_Click (8)
End Select

'判断当前层标注线样式，设置相应选项按钮
Select Case lpCur.LineType
Case miLineTypeNone
optLineType(0).Value = True
Case miLineTypeSimple
optLineType(1).Value = True
Case miLineTypeArrow
optLineType(2).Value = True
End Select

'显示当前层标注偏移量
txtLabelOffset.Text = CStr(lpCur.Offset)
'显示当前层最大标注数
txtLabelMax.Text = CStr(lpCur.LabelMax)
'添加当前层的字段
i = 0
intSelIndex = 0
cboFields.Clear
Set ds = frmlayerdlg.g_Map.DataSets.Add(miDataSetLayer, m_lyrCur)
Set lpCur.Dataset = ds
Set fldSel = lpCur.DataField
   For Each fld In ds.Fields
       If Not fldSel Is Nothing Then
            If fldSel.Name = fld.Name Then
           intcurfield = i
           End If
      End If
     
      
      cboFields.AddItem fld.Name, i
      i = i + 1
  Next
cboFields.ListIndex = intSelIndex
Me.Caption = "标注属性-" & m_strCurLayerName










End Sub

Private Sub Form_Paint()
Dim rect As New MapXLib.Rectangle

picLineStyle.Cls
picLabelStyle.Cls

rect.Set 0, 0, picLabelStyle.ScaleWidth, picLabelStyle.ScaleHeight
m_styNew.DrawTextSample picLabelStyle.hDC, rect, "Text"

rect.Set 0, 0, picLineStyle.ScaleWidth, picLineStyle.ScaleHeight
m_styNew.DrawLineSample picLineStyle.hDC, rect
End Sub
'检查图层的标注样式修改信息是否已经被记录，若有则返回其记录位置，否则返回0
Private Function checklayer(layername As String) As Integer
Dim i As Integer


checklayer = 0
For i = 1 To frmlayerdlg.m_intLPModifiedLyrCount
  If g_audtLPModifiedLyr(i).layername = layername Then
  checklayer = i
  Exit For
End If
Next i

End Function

Private Sub optLineType_Click(index As Integer)
Select Case index
Case 0
m_ltNew = miLineTypeNone
Case 1
m_ltNew = miLineTypeSimple
Case 2
m_ltNew = miLineTypeArrow
End Select
End Sub

Private Sub picLabelPos_Click(index As Integer)
Dim i As Integer

If picLabelPos(index).Appearance = vbFlat Then
picLabelPos(index).Appearance = vb3D
picLabelPos(index).BorderStyle = 1



  For i = 1 To picLabelPos.Count
   If (i - 1) <> index Then
      picLabelPos(i - 1).Appearance = vbFlat
      picLabelPos(i - 1).BorderStyle = 0
   End If
 Next i
End If

'
Select Case index
Case 0
m_posNew = miPositionTL

Case 1
m_posNew = miPositionTC
Case 2
m_posNew = miPositionTR
Case 3
m_posNew = miPositionCL
Case 4
m_posNew = miPositionCC
Case 5
m_posNew = miPositionCR
Case 6
m_posNew = miPositionBL
Case 7
m_posNew = miPositionBC
Case 8
m_posNew = miPositionBR

End Select




End Sub

Private Sub picLabelPos_GotFocus(index As Integer)
picLabelPos(index).BorderStyle = 1

End Sub

Private Sub picLabelPos_KeyDown(index As Integer, KeyCode As Integer, Shift As Integer)

Dim intNextFocusPos As Integer

Select Case KeyCode
Case vbKeyReturn
Call picLabelPos_Click(index)
Case vbleyleft
   If (index = 0) Or (index = 3) Or (index = 6) Then
     intNextFocusPos = index + 2
   Else
      intNextFocusPos = index - 1
   End If
   picLabelPos(intNextFocusPos).SetFocus
Case vbKeyRight
   If (index = 2) Or (index = 5) Or (index = 8) Then
     intNextFocusPos = index - 2
   Else
      intNextFocusPos = index + 1
   End If
picLabelPos(intNextFocusPos).SetFocus
Case vbKeyUp
If index < 3 Then
     intNextFocusPos = index + 6
   Else
      intNextFocusPos = index - 3
   End If
picLabelPos(intNextFocusPos).SetFocus

Case vbKeyDown
If index > 5 Then
     intNextFocusPos = index - 6
   Else
      intNextFocusPos = index + 3
   End If
picLabelPos(intNextFocusPos).SetFocus
End Select
End Sub

Private Sub picLabelPos_LostFocus(index As Integer)
If picLabelPos(index).Appearance <> vb3D Then
    picLabelPos(index).BorderStyle = 0
End If
End Sub