VERSION 5.00
Begin VB.UserControl ctValueBoxA 
   BackColor       =   &H80000005&
   BorderStyle     =   1  'Fixed Single
   ClientHeight    =   270
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   705
   ClipBehavior    =   0  'None
   ClipControls    =   0   'False
   EditAtDesignTime=   -1  'True
   FillStyle       =   0  'Solid
   FontTransparent =   0   'False
   HasDC           =   0   'False
   HitBehavior     =   0  'None
   KeyPreview      =   -1  'True
   PaletteMode     =   4  'None
   ScaleHeight     =   18
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   47
   Begin VB.VScrollBar eScroll 
      CausesValidation=   0   'False
      Height          =   255
      Left            =   480
      Max             =   2
      TabIndex        =   1
      TabStop         =   0   'False
      Top             =   0
      Value           =   1
      Width           =   210
   End
   Begin VB.TextBox eText 
      Alignment       =   1  'Right Justify
      Appearance      =   0  'Flat
      BorderStyle     =   0  'None
      CausesValidation=   0   'False
      Height          =   285
      Left            =   0
      TabIndex        =   0
      Text            =   "0"
      Top             =   0
      Width           =   480
   End
End
Attribute VB_Name = "ctValueBoxA"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
' ctMenuA, Light NoScroll Version
' custom usercontrol for Visual Basic 6
' Copyright (C) 2003,2004 Jan Vorel
' This program is free software; you can redistribute it and/or modify
' it under the terms of the GNU General Public License as published by
' the Free Software Foundation; either version 2 of the License, or
' (at your option) any later version.

' This program is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY; without even the implied warranty of
' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
' GNU General Public License for more details.

' You should have received a copy of the GNU General Public License
' along with this program; if not, write to the Free Software
' Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

' This is a shared modul, class modul, usercontrol or form. It is also
' published under the GNU General Public License.

' If you have any questions, suggestions or bug reports about this product,
' contact me: info@ctuser.net; Do not contact me about general B.A.S.I.C.
' language or A.P.I. issues



Option Explicit
Option Base 0

Private xMax As Long
Private xMin As Long
Private xCur As Long
Private xStep As Long
Private xStepLarge As Long
Private xScrollWidth As Long
Private xLocked As Boolean

Public Event ValueChange(ByVal NewValue As Single)

Public Property Let Enabled(ByVal NewValue As Boolean)
  eText.Enabled = NewValue
  eScroll.Enabled = NewValue
  UserControl.Enabled = NewValue
  If NewValue Then
    eText.BackColor = &H80000005
    eText.ForeColor = &H80000008
    Else
    eText.BackColor = &H8000000F
    eText.ForeColor = &H80000012
    End If
  End Property

'Public Property Let Grayed(ByVal NewValue As Boolean)
'If NewValue Then
'  eText.BackColor = &H8000000F
'  eText.ForeColor = &H80000012
'  Else
'  eText.BackColor = &H80000005
'  eText.ForeColor = &H80000008
'  End If
'End Property

Public Property Let ValueMax(ByVal NewValue As Single)
  xMax = NewValue * 1000&
  End Property

Public Property Let ValueMin(ByVal NewValue As Single)
  xMin = NewValue * 1000&
  End Property

Public Property Let Value(ByVal NewValue As Single)
  xCur = NewValue * 1000&
  ReWrite
  End Property

'Public Property Get Value() As Single
'Value = xCur \ 1000&
'End Property

Public Property Let ValueStep(ByVal NewValue As Single)
  xStep = NewValue * 1000&
  ReWrite
  End Property

Public Property Let ValueStepLarge(ByVal NewValue As Single)
  xStepLarge = NewValue * 1000&
  End Property

Private Sub eScroll_Change()
  If Not xLocked Then
    xLocked = True
    Select Case eScroll.Value
      Case 0
        If Not xCur = xMax Then
          xCur = xCur + xStep
          If xCur > xMax Then xCur = xMax
          ReWrite
          End If
        eScroll.Value = 1
        RaiseEvent ValueChange(xCur / 1000&)
      Case 2
        If Not xCur = xMin Then
          xCur = xCur - xStep
          If xCur < xMin Then xCur = xMin
          ReWrite
          End If
        eScroll.Value = 1
        RaiseEvent ValueChange(xCur / 1000&)
      End Select
      xLocked = False
    End If
  End Sub

Private Sub eScroll_Scroll()
  eScroll_Change
  End Sub

Private Sub eText_Change()
  Static xLong1 As Long
  If Not xLocked Then
    xLong1 = Val(eText.Text) * 1000&
    If xLong1 > xMax And xMax > 0 Then
      xCur = xMax
      ReWrite
      ElseIf xLong1 < xMin And xMin < 0 Then
      xCur = xMin
      ReWrite
      End If
    If xLong1 < xMin Then
      xLong1 = xMin
      ElseIf xLong1 > xMax Then
      xLong1 = xMax
      End If
    If Not xLong1 = xCur Then
      xCur = xLong1
      RaiseEvent ValueChange(xCur / 1000&)
      End If
    End If
  End Sub

Private Sub eText_KeyPress(KeyAscii As Integer)
  Select Case KeyAscii
    Case 8
    Case 48 To 57
    Case 45
      If Not xMin < 0 Then KeyAscii = 0
    Case 46
      If xStep = Fix(xStep) Then KeyAscii = 0
    Case Else
      KeyAscii = 0
    End Select
  End Sub

Private Sub UserControl_ExitFocus()
  ReWrite
  End Sub

Private Sub UserControl_Initialize()
  xMax = 100000
  xStep = 1000&
  xStepLarge = 10000&
  xScrollWidth = eScroll.Width
  ReWrite
  End Sub

Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
  Select Case KeyCode
    Case 38 '+1
      If Not xCur = xMax Then
        xCur = xCur + xStep
        If xCur > xMax Then xCur = xMax
        KeyCode = 0
        ReWrite
        RaiseEvent ValueChange(xCur / 1000&)
        End If
    Case 40 '-1
      If Not xCur = xMin Then
        xCur = xCur - xStep
        If xCur < xMin Then xCur = xMin
        KeyCode = 0
        ReWrite
        RaiseEvent ValueChange(xCur / 1000&)
        End If
    Case 33, 36 '+1x
      If Not xCur = xMax Then
        xCur = xCur + xStepLarge
        If xCur > xMax Then xCur = xMax
        KeyCode = 0
        ReWrite
        RaiseEvent ValueChange(xCur / 1000&)
        End If
    Case 34, 35 '-1x
      If Not xCur = xMin Then
        xCur = xCur - xStepLarge
        If xCur < xMin Then xCur = xMin
        KeyCode = 0
        ReWrite
        RaiseEvent ValueChange(xCur / 1000&)
        End If
  '  Case 36 'max
  '    If Not xCur = xMax Then
  '      xCur = xMin
  '      ReWrite
  '      RaiseEvent ValueChange(xCur / 1000&)
  '      End If
  '  Case 35 'min
  '    If Not xCur = xMin Then
  '      xCur = xMin
  '      ReWrite
  '      RaiseEvent ValueChange(xCur / 1000&)
  '      End If
    End Select
  End Sub

Private Sub UserControl_Resize()
  Static xLong1 As Long
  Static xLong2 As Long
  
  xLong1 = UserControl.ScaleWidth
  xLong2 = xLong1 \ 3
  If xLong2 > xScrollWidth Then
    xLong2 = xScrollWidth
    End If
  xLong1 = xLong1 - xLong2
  If xLong1 < 0 Then xLong1 = 0
  eText.Width = xLong1
  eScroll.Left = xLong1
  
  xLong1 = UserControl.ScaleHeight
  If xLong1 < 0 Then xLong1 = 0
  If xLong1 > 6 And xLong1 < 24 Then
    eText.FontSize = xLong1 * 0.65
    End If
  eText.Height = xLong1
  eScroll.Height = xLong1
  End Sub

Private Sub ReWrite()
  Static xLong1 As Long
  Static xLong2 As Long
  Static xLong3 As Long
  
  xLocked = True
  xLong1 = -Int(Log(xStep / 1000&) / Log(10))
  'Debug.Print xCur, xMin, xMax, xStep, xStepLarge
  If xLong1 > 0 Then
    xLong2 = Fix(xCur / 1000&)
    xLong3 = (xCur / 1000& - xLong2) * 10 ^ xLong1
    eText.Text = CStr(xLong2) & "." & Right(String(xLong1, "0") & CStr(xLong3), xLong1)
    Else
    eText.Text = CStr(xCur / 1000&)
    End If
  xLocked = False
  End Sub


