frmslider.frm

gis地图 --- --- --文字1

    m_bDuringInit = True
    
'   track the current classes:
    Set m_pCurrentGroup = pLayer
    Set m_pCurrentLabel = pLBL

    Me.cmbSlider.Clear

'   set location:
    Me.Left = xLeft
    Me.Top = xTop

    Select Case UCase(sType)
        Case "ROTATION"
            Me.cmbSlider.AddItem "X rotation"
            Me.cmbSlider.AddItem "Y rotation"
            Me.cmbSlider.AddItem "Z rotation"
            Me.cmbSlider.ListIndex = 0
            
        Case "OFFSET"
            Me.cmbSlider.AddItem "X offset"
            Me.cmbSlider.AddItem "Y offset"
            Me.cmbSlider.AddItem "Z offset"
            Me.cmbSlider.ListIndex = 0
            
        Case "FONT SIZE"
            Me.cmbSlider.AddItem "Font size"
            Me.cmbSlider.ListIndex = 0
            
        Case "ALL"
            Me.cmbSlider.AddItem "X rotation"
            Me.cmbSlider.AddItem "Y rotation"
            Me.cmbSlider.AddItem "Z rotation"
            Me.cmbSlider.AddItem "X offset"
            Me.cmbSlider.AddItem "Y offset"
            Me.cmbSlider.AddItem "Z offset"
            Me.cmbSlider.ListIndex = 0
            
            
    End Select
    
    InitControls
    
    m_bDuringInit = False
    
    If bComplete Then
        Me.Width = Me.frBasic.Width + Me.frTwo.Width + 50
    Else
        Me.Width = Me.frBasic.Width + 50
    End If
    
    If Len(sCaption) > 0 Then
        Me.Caption = sCaption
    Else
        Me.Caption = "LABEL"
    End If
    
'   run the form:
    Me.Show vbModal
    Unload Me
    
    Exit Function
    
FrmSliderRun_ERR:
    Debug.Assert 0
    Debug.Print "FrmSliderRun_ERR " & Err.Description
    Resume Next
    
    
End Function

Private Sub cmdFont_Click()
On Error Resume Next

    If g_bDuringCommand = True Then Exit Sub

    g_bDuringCommand = True

'   call main font dialog routine:
    SetFontInfo m_pCurrentGroup, m_pCurrentLabel
    g_bDuringCommand = False
    
End Sub


Private Sub cmdMessage_Click()
Dim sMessage As String
Dim sOldLbl As String
On Error GoTo Message_ERR

    
    If Not m_pCurrentLabel Is Nothing Then
        sOldLbl = m_pCurrentLabel.Message
    Else
    '   we should not be here:
        Exit Sub
    End If
        
'   get the new nessage:
    sMessage = InputBox("Label Message?", "Update Label Text", sOldLbl)
        
'   if we got a different message:
    If Len(sMessage) > 0 And sMessage <> sOldLbl Then
    '   set it and refresh:
        If Not m_pCurrentLabel Is Nothing Then
            m_pCurrentLabel.Message = sMessage
            RefreshViewers
        End If

    End If
    
    Exit Sub
    
Message_ERR:
    MsgBox "Message_ERR: " & Err.Description
    
End Sub

Private Sub Form_DblClick()
On Error Resume Next

    m_iStatus = vbCancel
    Me.Hide
End Sub

Private Sub Form_Deactivate()
On Error Resume Next

    m_iStatus = vbCancel
    Me.Hide

End Sub

Private Sub Form_KeyDown(keyCode As Integer, Shift As Integer)
On Error Resume Next

    If keyCode = vbKeyEscape Or keyCode = vbKeyCancel Then
        m_iStatus = vbCancel
        Me.Hide
    End If
    
End Sub

Private Sub Form_KeyPress(KeyAscii As Integer)
On Error Resume Next

    If KeyAscii = vbKeyEscape Or KeyAscii = vbKeyCancel Then
        m_iStatus = vbCancel
        Me.Hide
    End If
End Sub

Private Sub Form_LostFocus()
On Error Resume Next

    m_iStatus = vbCancel
    Me.Hide
End Sub

Private Sub Form_Paint()
On Error Resume Next

    RefreshMe
End Sub

Private Sub UpdateCLS()
Dim sForWhat As String
Dim n As Double
Dim xRot As Double, yRot As Double, zRot As Double
Dim xOff As Double, yOff As Double, zOff As Double
Dim nSet As Double
Dim pPt As IPoint

On Error GoTo UpdateCLS_ERR

'   what are we setting:
    sForWhat = frmSlider.cmbSlider.Text

'   what value:
    n = frmSlider.Slider1.Value

'   if we have increased since last value, get a positive increment:
    If n > m_nValue Then
        nSet = n - m_nValue
    ElseIf m_nValue > n Then
'   else get a negative increment:
        nSet = -(m_nValue - n)
    Else
        
    End If
    
'   track the current value:
    m_nValue = n
    

    Select Case UCase(sForWhat)
        Case "FONT SIZE"
            If Not m_pCurrentGroup Is Nothing Then m_pCurrentGroup.FontSize = n
            If Not m_pCurrentLabel Is Nothing Then m_pCurrentLabel.FontSize = n
            
        Case "X ROTATION"
            
            If Not m_pCurrentGroup Is Nothing Then m_pCurrentGroup.XRotation = n
            If Not m_pCurrentLabel Is Nothing Then
                m_pCurrentLabel.GetAxisRotation xRot, yRot, zRot
                m_pCurrentLabel.SetAxisRotation n, yRot, zRot
            End If
       
        Case "Y ROTATION"
            If Not m_pCurrentGroup Is Nothing Then m_pCurrentGroup.YRotation = n
            If Not m_pCurrentLabel Is Nothing Then
                m_pCurrentLabel.GetAxisRotation xRot, yRot, zRot
                m_pCurrentLabel.SetAxisRotation xRot, n, zRot
            End If
            
        Case "Z ROTATION"
            If Not m_pCurrentGroup Is Nothing Then m_pCurrentGroup.ZRotation = n
            If Not m_pCurrentLabel Is Nothing Then
                m_pCurrentLabel.GetAxisRotation xRot, yRot, zRot
                m_pCurrentLabel.SetAxisRotation xRot, yRot, n
            End If
        Case "X OFFSET"
        
            If Not m_pCurrentGroup Is Nothing Then m_pCurrentGroup.m_nXOff = nSet
            If Not m_pCurrentLabel Is Nothing Then

                Set pPt = New Point
            
                pPt.PutCoords m_pCurrentLabel.Origin.X + nSet, m_pCurrentLabel.Origin.Y
                pPt.z = m_pCurrentLabel.Origin.z
                
                m_pCurrentLabel.Origin.X = pPt.X
                m_pCurrentLabel.Origin.Y = pPt.Y
                m_pCurrentLabel.Origin.z = pPt.z
                m_pCurrentLabel.Message = m_pCurrentLabel.Message
            End If
            
        Case "Y OFFSET"
            If Not m_pCurrentGroup Is Nothing Then m_pCurrentGroup.m_nYOff = nSet
            If Not m_pCurrentLabel Is Nothing Then
                Set pPt = New Point
            
                pPt.PutCoords m_pCurrentLabel.Origin.X, m_pCurrentLabel.Origin.Y + nSet
                pPt.z = m_pCurrentLabel.Origin.z
                
                m_pCurrentLabel.Origin.X = pPt.X
                m_pCurrentLabel.Origin.Y = pPt.Y
                m_pCurrentLabel.Origin.z = pPt.z
                m_pCurrentLabel.Message = m_pCurrentLabel.Message
                
            End If
        Case "Z OFFSET"
            If Not m_pCurrentGroup Is Nothing Then m_pCurrentGroup.m_nZOff = nSet
            If Not m_pCurrentLabel Is Nothing Then

                Set pPt = New Point
            
                pPt.PutCoords m_pCurrentLabel.Origin.X, m_pCurrentLabel.Origin.Y
                pPt.z = m_pCurrentLabel.Origin.z + nSet
                
                m_pCurrentLabel.Origin.X = pPt.X
                m_pCurrentLabel.Origin.Y = pPt.Y
                m_pCurrentLabel.Origin.z = pPt.z
                m_pCurrentLabel.Message = m_pCurrentLabel.Message
                

            End If
        Case Else
            'MsgBox "property " & sForWhat & " not found."
            Exit Sub
            
    End Select
    
    Me.txtValue = Format(n, "##0")
    
    If Not m_pCurrentGroup Is Nothing Then
    '   update all labels in group:
        UpdateLabels m_pCurrentGroup, sForWhat, , , True
    ElseIf Not m_pCurrentLabel Is Nothing Then
    '   just refresh:
        RefreshViewers
    End If
    
    Exit Sub
    
UpdateCLS_ERR:
    Debug.Assert 0
    Debug.Print "UpdateCLS_ERR: " & Err.Description
    MsgBox "UpdateCLS_ERR: " & Err.Description
    Resume Next
    
End Sub

Private Sub frBasic_DblClick()
On Error Resume Next

    m_iStatus = vbCancel
    Me.Hide
    
End Sub

Private Sub frTwo_DblClick()
On Error Resume Next

    m_iStatus = vbCancel
    Me.Hide
    
End Sub

Private Sub Slider1_KeyPress(KeyAscii As Integer)
On Error Resume Next

    If KeyAscii = vbKeyEscape Or KeyAscii = vbKeyCancel Then
        m_iStatus = vbCancel
        Me.Hide
    End If
    
End Sub

Private Sub Slider1_Scroll()
On Error Resume Next

    UpdateCLS
End Sub


Private Sub txtValue_KeyDown(keyCode As Integer, Shift As Integer)
On Error Resume Next
    
    If keyCode = 13 Then
        Dim n As Long
        n = CLng(Me.txtValue)
        
    '   validate:
    
    
    '   update
        frmSlider.Slider1.Value = n
        UpdateCLS
        
    End If
    
    
    
End Sub


Private Sub txtValue_KeyPress(KeyAscii As Integer)
On Error Resume Next

    If KeyAscii = vbKeyEscape Or KeyAscii = vbKeyCancel Then
        m_iStatus = vbCancel
        Me.Hide
    End If
    
    If Not (IsNumeric(Chr(KeyAscii))) And KeyAscii <> vbKeyBack And KeyAscii <> vbKeyReturn And KeyAscii <> vbKeySubtract And KeyAscii <> 46 And Chr(45) <> "-" Then
        KeyAscii = 0
    End If

End Sub