Option Compare Database
Option Explicit

Const cursSplit =  "VE_SPLIT.CUR" 
Const cursLine =  "VE_LINE.CUR" 
Const cursSize =  "VE_SIZEB.CUR" 

Public CursorType As CursType

Public Enum CursType
    csCursSplit =  1 
    csCursLine =  2 
    csCursSize =  3 
End Enum

Public WithEvents s1 As Label
Public WithEvents s2 As Label
Public sMaxWid As Single
Public RightHead As Control

Dim frm As Form
Dim lngV_split_Cursor As Long
Dim lngV_1_Cursor As Long
Dim bMoveX As Boolean
Dim bSplitX As Boolean
Dim bReady As Boolean
Dim sStartWid As Single 'начальная ширина'
Dim lbl As Label        'активный заголовок'
Dim Col As Control      'активное поле'
Dim CheckB As Control
Dim vArLeft() As Variant 'лево всех заголовков'
      'полная ширина всех'
Dim sDif As Single
Dim sX As Single
Dim sLeft As Single



Private Sub Class_Terminate()
    ResetAll
End Sub

Property Set FormToSplit(frmS As Form)
    Set frm = frmS
    spl_Open
End Property


Private Sub spl_Open()
    Dim ctl As Control
    Dim stFunc As String
    Dim sMax As Single    'крайнее лево'
    Dim strCursType As String

    Select Case CursorType
        Case csCursSplit
            strCursType = cursSplit
        Case csCursLine
            strCursType = cursLine
        Case csCursSize
            strCursType = cursSize
    End Select
        
    For Each ctl In frm.Section( 1 ).Controls
        If ctl.Tag =  "colhead"  Then
           stFunc =  "=WithSplitter("  & Chr( 34 ) & ctl.name & Chr( 34 ) &  ")" 
           ctl.OnMouseMove = stFunc
           If ctl.Left > sMax Then
              Set RightHead = ctl
              sMax = ctl.Left
           End If
        End If
    Next
    Set s1 = frm!s1
    Set s2 = frm!s2
    With s1
        .OnMouseMove =  "[event procedure]" 
        .OnMouseDown =  "[event procedure]" 
        .OnMouseUp =  "[event procedure]" 
    End With
    With s2
        .OnMouseMove =  "[event procedure]" 
        .OnMouseDown =  "[event procedure]" 
        .OnMouseUp =  "[event procedure]" 
    End With
    lngV_split_Cursor = LoadCursorFromFile(CurrentProject.Path &  "\imgs\"  & strCursType)
    Screen.MousePointer =  1 
    lngV_1_Cursor = GetCursor
    If lngV_split_Cursor =  0  Then
       Screen.MousePointer =  9 
       lngV_split_Cursor = GetCursor
    End If
    Screen.MousePointer =  0 

End Sub

Public Function GeneralCursor()
    Dim retval As Long
    retval = SetCursor(lngV_1_Cursor)
End Function

Public Sub WithColumnSplitter(stName As String)
    If bMoveX Then Exit Sub
    Set lbl = frm(stName)
    On Error Resume Next
    frm!s1.Left = lbl.Left + lbl.Width -  60 
    If lbl.Left >  64  Then frm!s2.Left = lbl.Left -  60 
    Err.number =  0 
    bReady = True
    M_Pointer ( 0 )
End Sub

Private Sub Form_Activate()
    M_Pointer  1 
End Sub

Private Sub Form_Resize()
    Scrolls
End Sub

Public Sub MMove(X As Single)
    On Error GoTo e
    Dim retval As Long
    Dim sChName  As String
    Dim ch As Control  'checkbox'
    Dim ctlP As Control 'поле для checkbox'
    Dim sWid As Single

    retval = SetCursor(lngV_split_Cursor)
    If bMoveX Then
        If sMaxWid + X >  31600  Then X =  31600  - sMaxWid
        sWid = sStartWid + X
        sLeft = lbl.Left + sWid -  50 
        If sLeft < lbl.Left +  60  Then sLeft = lbl.Left +  60 
        If sLeft <  60  Then sLeft =  60 
        frm!splith.Left = sLeft
        frm!splitd.Left = sLeft +  15 
        sDif = lbl.Left + lbl.Width - sLeft
        sX = X
        bSplitX = True
    End If
ex:
    frm.Painting = True
    Exit Sub
e:
    Select Case Err.number
        Case  2100 
            Resume ex
        Case Else
            MsgBox  "Исключение #"  & Err.number &  ", "  & Err.Description,  "MMove_SmallGrid" 
    End Select
    Resume ex
End Sub

Public Sub MoveAll()
    Dim sLeftCol As Single
    Dim i As Integer
    Dim sStLeft As Single
    Dim ctl As Control
    Dim col1 As Control
    
    frm.Painting = False
    On Error GoTo e
    lbl.Width = sLeft - lbl.Left
    Col.Width = lbl.Width
    On Error Resume Next          'на случай, если есть дополнительные (многоэтажные поля'
    frm(Col.name &  "f" ).Width = lbl.Width
    frm(Col.name &  "k" ).Width = lbl.Width
    Err.number =  0 
    On Error GoTo e
    If Col.Tag =  "colsC"  Then IfChBox Col
    For Each ctl In frm.Section( 1 ).Controls
            If ctl.Tag =  "colhead"  Then
               If ctl.Left > lbl.Left Then
                  For i =  1  To UBound(vArLeft())
                            'здесь читаем начальное лево правых колонок из массива, 
                              записанного при MDown'
                    If vArLeft(i,  0 ) = ctl.name Then
                        sStLeft = vArLeft(i,  1 )
                        Exit For
                    End If
                  Next i
                  sLeftCol = sStLeft - sDif   'новое лево колонки'
                  If sLeftCol <  0  Then sLeftCol =  0 
                  ctl.Left = sLeftCol
                    'новое лево поля(всей колонки)'
                  Set col1 = frm(Left$(ctl.name, Len(ctl.name) -  1 ))
                  col1.Left = sLeftCol
                  On Error Resume Next          'на случай если в примечании есть дополнитеьлные поля'
                  frm(col1.name &  "f" ).Left = sLeftCol
                  frm(col1.name &  "k" ).Left = sLeftCol
                  Err.number =  0 
                  On Error GoTo e
                  If col1.Tag =  "colsC"  Then IfChBox col1
                End If
            End If
        Next
ex:
    Scrolls
    frm.Painting = True
    ResetAll
    Exit Sub
e:
    Select Case Err.number
            Case  2100 
               Resume ex
            Case Else
            MsgBox  "Исключение #"  & Err.number &  ": "  & Err.Description, ,  "MoveAll_SmallGrid" 
    End Select
    Resume ex
End Sub

Private Sub IfChBox(colCh As Control)
    Dim ch As CheckBox
    
    Set ch = frm(colCh.name &  "c" )
    ch.Left = colCh.Left + (colCh.Width /  2  -  80 )
    ch.Visible = (colCh.Width > ch.Width)
    
End Sub

Public Sub Scrolls()
    Dim MaxW As Single
    
    MaxW = RightHead.Left + RightHead.Width
    With frm
        .ScrollBars =  2 
        If MaxW > .InsideWidth -  280  Then .ScrollBars =  3 
        .NewWidth = MaxW
        On Error Resume Next
        .scrollme
        Err.number =  0 
    End With
End Sub


Private Function LeftHead() As Control
        Dim ctl As Control
        Dim ctlLeft As Control
        
        For Each ctl In frm.Section( 1 ).Controls
            If ctl.Tag =  "colhead"  Then
               If ctl.Left + ctl.Width > lbl.Left -  20  _
                   And ctl.Left < lbl.Left Then
                   Set ctlLeft = ctl
                   Exit For
               End If
            End If
        Next
        If Not ctlLeft Is Nothing Then
           Set LeftHead = ctlLeft
        Else
           Set LeftHead = lbl
        End If
End Function

Public Sub MDown(X As Single)
    If Not bReady Then Exit Sub
    Dim retval As Long
    Dim ctl As Control
    Dim ll As Long
    
    retval = SetCursor(lngV_split_Cursor)
    bMoveX = True
    sStartWid = lbl.Width
    Set Col = frm(Left$(lbl.name, Len(lbl.name) -  1 ))
    sMaxWid =  0 
    For Each ctl In frm.Section( 1 ).Controls
        If ctl.ControlType = acLabel Then
           If ctl.Tag =  "colhead"  Then
              sMaxWid = sMaxWid + ctl.Width
              ll = ll +  1 
              ReDim Preserve vArLeft( 20 ,  2 )
              vArLeft(ll,  0 ) = ctl.name
              vArLeft(ll,  1 ) = ctl.Left
           End If
        End If
    Next
    With frm
        !splith.Left = lbl.Left + lbl.Width
        !splitd.Left = !splith.Left
        !splith.Visible = True
        !splitd.Visible = True
    End With
End Sub

Private Sub s1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    MMove X
End Sub

Private Sub s2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    MMove X
End Sub

Private Sub s1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    MDown X
End Sub

Private Sub s2_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    'определить левый head
    If Not bReady Then Exit Sub
    If lbl.Left >  35  Then Set lbl = LeftHead
    MDown X
End Sub

Private Sub s1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If bSplitX Then MoveAll
    ResetAll
End Sub

Private Sub s2_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If bSplitX Then MoveAll
    ResetAll
End Sub

Private Sub ResetAll()
    sDif =  0 
    sX =  0 
    sLeft =  0 
    bMoveX = False
    frm!splith.Visible = False
    frm!splitd.Visible = False
    bSplitX = False
End Sub

'Блок сплиттер==============================================='
Dim Cs As ColumnSplitter

Private Sub spl_Open()
    Set Cs = New ColumnSplitter
    Cs.CursorType = csCursSize
    Set Cs.FormToSplit = Me
End Sub

Private Function WithSplitter(stName As String)
    Cs.WithColumnSplitter stName
End Function

Property Let NewWidth(MaxW As Single) 'передача в форму новой ширины контролов'
'    If MaxW > Me.InsideWidth - 15 Then
'        l1.Width = MaxW
'        l2.Width = MaxW
'        l3.Width = MaxW
'        c1.Width = MaxW - c1.Left
'    End If'
End Property

Private Sub Form_Close()
    Set Cs = Nothing
End Sub

Private Sub Form_Resize()
   If Cs Is Nothing Then Exit Sub
   Cs.Scrolls
End Sub

Private Sub Form_Open(Cancel As Integer)
     spl_Open
End Sub
'конец блока сплиттер===============================================