Keskustelu: Koodit: VB6: Dynaaminen kontrollitaulukko tapahtumin

Option Explicit

Private Labels() As Label 'Dynaamista control arrayta varten
Private WithEvents cmdCreate As CommandButton '"Tavallinen" dynaaminen painike

Private Sub Form_Load()

    'Luodaan dynaaminen label-array ensimmäisen kerran
    Call CreateLabels
    'Lisätään dynaaminen buttoni, jolla luodaan labelit uudelleen
    Set cmdCreate = Controls.Add("vb.commandbutton", "cmdCreate")
    With cmdCreate
        .Caption = "Create Label-array?"
        .Visible = True
        .Width = Me.ScaleWidth / 2
        .Move Me.ScaleWidth / 2 - 20, Me.ScaleHeight - .Height
    End With
    'Asemoidaan formi
    Me.Move 2500, 2500
End Sub

Private Sub Form_Unload(Cancel As Integer)
    'Poistetaan muistista käyttämämme kontrollit
    Call DeleteControls
End Sub

Public Sub Label_DragDrop(ByVal MyLabel As Label, _
                          ByVal Source As Control)
    Dim strAbu As String
    Dim strAbu2 As String
    Dim i As Integer        'korjattu kierroslaskuri viimeisen käytössä olevan kentän mukaan
    Dim j As Integer        'viimeinen käytössä oleva kenttä
    Dim k As Integer        'kierroslaskuri

    'Korvataan kohteen Caption lähteen Captionilla
    strAbu = Labels(MyLabel.Index).Control.Caption
    Labels(MyLabel.Index).Control.Caption = Source.Caption
    Source.Caption = strAbu
    'Korvataan myös lähteen ja kohteen välillä olevien Labeleiden Captionit
    If Int(Source.Tag) > MyLabel.Index Then
        'Labeli vedetty ylös päin
        k = Int(Source.Tag) - MyLabel.Index
        i = MyLabel.Index + 1
        j = UBound(Labels)
        Do Until Labels(j).Control.Visible = True
            If Labels(j).Control.Visible = False Then j = j - 1
        Loop
        Do Until k < 1 Or i > j
            strAbu2 = Labels(i).Control.Caption
            Labels(i).Control.Caption = strAbu
            strAbu = strAbu2
            k = k - 1
            i = i + 1
        Loop
    Else
        'Labeli vedetty alas päin
        k = MyLabel.Index - Int(Source.Tag)
        i = MyLabel.Index - 1
        Do Until k < 1 Or i < 0
            strAbu2 = Labels(i).Control.Caption
            Labels(i).Control.Caption = strAbu
            strAbu = strAbu2
            k = k - 1
            i = i - 1
        Loop
    End If

End Sub

Public Sub Label_MouseDown(ByVal MyLabel As Label, _
                           ByVal Button As Integer)
    Dim strAbu As String
    Dim strAbu2 As String
    Dim i As Integer        'korjattu kierroslaskuri
    Dim j As Integer        'viimeinen käytössä oleva kenttä
    Dim k As Integer        'kierroslaskuri

    If Button = 2 Then
        j = UBound(Labels)
        'Korjataan laskuria sen mukaan, onko joitain Labeleita jo Disabloitu
        For i = 0 To j
           If Not Labels(i).Control.Enabled Then j = j - 1
        Next i
        'Siirretään objekti viimeiseksi
        strAbu = Labels(j).Control.Caption
        Labels(j).Control.Caption = Labels(MyLabel.Index).Control.Caption
        k = j - MyLabel.Index
        i = j - 1
        Do Until k < 1 Or i < 0
            strAbu2 = Labels(i).Control.Caption
            Labels(i).Control.Caption = strAbu
            strAbu = strAbu2
            k = k - 1
            i = i - 1
        Loop
        'Disabloidaan objekti
        Labels(j).Control.Enabled = False
        'Tarkistetaan onko kaikki Labelit Disabloit
        j = UBound(Labels)
        For i = 0 To j
            If Not Labels(i).Control.Enabled Then j = j - 1
        Next i
        'Jos on, niin tarkistetaan lopetetaanko ohjelma
        If j = -1 Then
            If MsgBox("Quit?", vbQuestion + vbYesNo + vbDefaultButton1, "All Gone") = vbYes Then
                DeleteControls
                End
            End If
        End If
    End If

End Sub

Private Sub cmdCreate_click()
    Call CreateLabels(1)
End Sub

Private Sub CreateLabels(Optional Mode As Integer = 0)
    Dim i As Long

    Randomize Timer
    'nollataan muuttujat
    If Mode = 1 Then
        For i = LBound(Labels) To UBound(Labels)
            Me.Controls.Remove Labels(i).Control.Name
        Next i
        Erase Labels
    End If
    'luodaan 3-6 dynaamista labelia formille leikittäviksi
    ReDim Labels(0 To (Round(Rnd * 3) + 2))
    For i = LBound(Labels) To UBound(Labels)
        Set Labels(i) = New Label
        With Labels(i)
            'Asetetaan Labelin Parent ja Index, jotka esitelty Label -Class modulessa
            Set .Parent = Me
            .Index = i
            'Tehdään kontrollista Labeli
            Set .Control = Controls.Add("VB.Label", "Label" & i)
            With .Control
                .Visible = True
                .Caption = "Label " & i
                .BorderStyle = 1
                'Tageja käytetty, koska Sourcella ei ole Drag'n'Dropissa indexiä.
                .Tag = i
                .DragMode = 1
                Call .Move(0, (Me.ScaleHeight - 500) * i / (UBound(Labels) + 1), _
                  Me.ScaleWidth, ((Me.ScaleHeight - 500) / (UBound(Labels) + 1) - 60))
            End With
        End With
    Next i

End Sub

Private Sub DeleteControls()
    Dim i As Integer

    'Deletoidaan luomamme kontrollit
    For i = LBound(Labels) To UBound(Labels)
        Me.Controls.Remove Labels(i).Control.Name
    Next i
    Erase Labels
    Me.Controls.Remove cmdCreate
End Sub

Option Explicit

'Esitellään käyttämämme kontrollin ominaisuudet
Public Parent As VB.Form
Public Index As Long
Public WithEvents Control As VB.Label

Private Sub Control_DragDrop(Source As Control, _
                             X As Single, _
                             Y As Single)
    'Kutsutaan formilla määritettyä Drag'n'Drop-tapahtumaa labelille
    Call Parent.Label_DragDrop(Me, Source)
End Sub

Private Sub Control_MouseDown(Button As Integer, _
                              Shift As Integer, _
                              X As Single, _
                              Y As Single)
    'Edellistä vastaava MouseDown-tapahtuma
    Call Parent.Label_MouseDown(Me, Button)
End Sub