Drag and Drop in Userform

Ivonne · 2014-06-05T10:32:57+00:00

Hi, habe eine Userform der beim Start 30 Images hinzugefügt und eine Grafik zugefügt werden,außerdem wird im Tag des Images die Bildadresse hinterlegt. Das ist soweit alles in Ordnung. Daneben gibt es noch feste Image (ab Image40) Jetzt möchte ich folgendes erreichen, per Drag and Drop oder wenn nicht möglich per Klick auf eines der 30 Images soll der Tag in eine Variable geschrieben werden und bei Klick auf eines der festen Image soll dort das Bild zugefügt werden. Im Testversuch mit manuell erzeugten Image habe ich das per Klick hinbekommen, nur bei den per Code erzeugten Image haut das nicht hin. Wobei mir wenn möglich Drag and Drop lieber wäre. gruss Ivonne

Hallo,
hier mal ein Beispiel wie das final aussehen würde. Bilder werden nur kopiert, bleiben also in der Auswahl erhalten. Das Ziel-Image hat bei mir den Namen "Image0":

' **********************************************************************
' Modul: clsImage Typ: Klassenmodul
' **********************************************************************

Option Explicit

Private WithEvents mobImage As MSForms.Image

Private Sub Class_Terminate()
    Set Image = Nothing
End Sub

Friend Property Get Image() As MSForms.Image
    Set Image = mobImage
End Property

Friend Property Set Image(ByRef probjImage As MSForms.Image)
    Set mobImage = probjImage
End Property

Private Sub mobImage_BeforeDragOver( _
        ByVal Cancel As MSForms.ReturnBoolean, _
        ByVal Data As MSForms.DataObject, _
        ByVal X As Single, _
        ByVal Y As Single, _
        ByVal DragState As MSForms.fmDragState, _
        ByVal Effect As MSForms.ReturnEffect, _
        ByVal Shift As Integer)

    Cancel = True
    Effect = fmDropEffectCopy

End Sub

Private Sub mobImage_MouseDown( _
        ByVal Button As Integer, _
        ByVal Shift As Integer, _
        ByVal X As Single, _
        ByVal Y As Single)

    Dim objDataObject As DataObject

    If Button = 1 Then

        Set objDataObject = New DataObject
        Call objDataObject.SetText(Text:=Image.Name)
        Call objDataObject.StartDrag(OKEffect:=fmDropEffectCopy)
        Set objDataObject = Nothing

    End If
End Sub

' **********************************************************************
' Modul: UserForm1 Typ: Userform
' **********************************************************************

Option Explicit

Private mobjImageClassCollection As Collection

Private Sub Image0_BeforeDragOver( _
        ByVal Cancel As MSForms.ReturnBoolean, _
        ByVal Data As MSForms.DataObject, _
        ByVal X As Single, ByVal Y As Single, _
        ByVal DragState As MSForms.fmDragState, _
        ByVal Effect As MSForms.ReturnEffect, _
        ByVal Shift As Integer)

    Cancel = True
    Effect = fmDropEffectCopy

End Sub

Private Sub Image0_BeforeDropOrPaste( _
        ByVal Cancel As MSForms.ReturnBoolean, _
        ByVal Action As MSForms.fmAction, _
        ByVal Data As MSForms.DataObject, _
        ByVal X As Single, _
        ByVal Y As Single, _
        ByVal Effect As MSForms.ReturnEffect, _
        ByVal Shift As Integer)

    With Controls(Data.GetText)

        Set Image0.Picture = .Picture

        Repaint

    End With
End Sub

Private Sub Image0_MouseUp( _
        ByVal Button As Integer, _
        ByVal Shift As Integer, _
        ByVal X As Single, _
        ByVal Y As Single)

    'Rechtsklick zum Löschen des Bildes

    If Button = 2 Then

        Set Image0.Picture = Nothing

        Repaint

    End If
End Sub

Private Sub UserForm_Activate()

    Dim lngRow As Long
    Dim sngLeft As Single
    Dim strFile As String, strName As String
    Dim objImage As MSForms.Image
    Dim objImageClass As clsImage

    Set mobjImageClassCollection = New Collection

    With Worksheets("Tabelle2")

        For lngRow = 1 To 30

            strFile = .Cells(lngRow, 1).Value
            strName = .Cells(lngRow, 5).Value

            Set objImage = Controls.Add(bstrProgID:="Forms.Image.1", _
                Name:="Image" & CStr(lngRow))

            With objImage
                .Left = sngLeft
                .Top = 389
                .Width = 30
                .Height = 40
                .PictureSizeMode = fmPictureSizeModeStretch
                Set .Picture = LoadPicture(strFile)
                .Tag = strFile
                .ControlTipText = strName
            End With

            Set objImageClass = New clsImage

            Set objImageClass.Image = objImage

            Call mobjImageClassCollection.Add(Item:=objImageClass)

            sngLeft = sngLeft + 30
        Next
    End With
End Sub

Private Sub UserForm_Terminate()
    Set mobjImageClassCollection = Nothing
End Sub

Gruß
Nepumuk

Hallo,
dann teste mal:

' **********************************************************************
' Modul: clsSourceImage Typ: Klassenmodul
' **********************************************************************

Option Explicit

Private WithEvents mobjImage As MSForms.Image

Private Sub Class_Terminate()
    Set Image = Nothing
End Sub

Friend Property Get Image() As MSForms.Image
    Set Image = mobjImage
End Property

Friend Property Set Image(ByRef probjImage As MSForms.Image)
    Set mobjImage = probjImage
End Property

Private Sub mobjImage_BeforeDragOver( _
        ByVal Cancel As MSForms.ReturnBoolean, _
        ByVal Data As MSForms.DataObject, _
        ByVal X As Single, _
        ByVal Y As Single, _
        ByVal DragState As MSForms.fmDragState, _
        ByVal Effect As MSForms.ReturnEffect, _
        ByVal Shift As Integer)

    Cancel = True
    Effect = fmDropEffectCopy

End Sub

Private Sub mobjImage_MouseDown( _
        ByVal Button As Integer, _
        ByVal Shift As Integer, _
        ByVal X As Single, _
        ByVal Y As Single)

    Dim objDataObject As DataObject

    If Button = 1 Then

        Set objDataObject = New DataObject
        Call objDataObject.SetText(Text:=Image.Name)
        Call objDataObject.StartDrag(OKEffect:=fmDropEffectCopy)
        Set objDataObject = Nothing

    End If
End Sub

' **********************************************************************
' Modul: clsTargetImage Typ: Klassenmodul
' **********************************************************************

Option Explicit

Private WithEvents mobjImage As MSForms.Image

Private mobjChildImage As MSForms.Image
Private mobjUserForm As Object

Private Sub Class_Terminate()
    Set Image = Nothing
    Set ChildImage = Nothing
    Set UserForm = Nothing
End Sub

Friend Property Get Image() As MSForms.Image
    Set Image = mobjImage
End Property

Friend Property Set Image(ByRef probjImage As MSForms.Image)
    Set mobjImage = probjImage
End Property

Friend Property Get ChildImage() As MSForms.Image
    Set ChildImage = mobjChildImage
End Property

Friend Property Set ChildImage(ByRef probjChildImage As MSForms.Image)
    Set mobjChildImage = probjChildImage
End Property

Friend Property Get UserForm() As Object
    Set UserForm = mobjUserForm
End Property

Friend Property Set UserForm(ByRef probjUserForm As Object)
    Set mobjUserForm = probjUserForm
End Property

Private Sub mobjImage_BeforeDragOver( _
        ByVal Cancel As MSForms.ReturnBoolean, _
        ByVal Data As MSForms.DataObject, _
        ByVal X As Single, _
        ByVal Y As Single, _
        ByVal DragState As MSForms.fmDragState, _
        ByVal Effect As MSForms.ReturnEffect, _
        ByVal Shift As Integer)

    Cancel = True
    Effect = fmDropEffectCopy

End Sub

Private Sub mobjImage_BeforeDropOrPaste( _
        ByVal Cancel As MSForms.ReturnBoolean, _
        ByVal Action As MSForms.fmAction, _
        ByVal Data As MSForms.DataObject, _
        ByVal X As Single, _
        ByVal Y As Single, _
        ByVal Effect As MSForms.ReturnEffect, _
        ByVal Shift As Integer)

    With UserForm.Controls(Data.GetText)
        Set Image.Picture = .Picture
        Image.ControlTipText = .ControlTipText
    End With

    UserForm.Repaint

End Sub

Private Sub mobjImage_DblClick(ByVal Cancel As MSForms.ReturnBoolean)

    'Doppelklick zm ein- und ausblenden der Childimages

    If Not ChildImage Is Nothing Then

        With ChildImage

            'Bild beim Ausblenden löschen
            ' If .Visible Then
            '
            ' Set .Picture = Nothing
            ' .ControlTipText = vbNullString
            '
            ' End If

            .Visible = Not .Visible

        End With
    End If
End Sub

Private Sub mobjImage_MouseUp( _
        ByVal Button As Integer, _
        ByVal Shift As Integer, _
        ByVal X As Single, _
        ByVal Y As Single)

    'Rechtsklick zum Löschen des Bildes

    If Button = 2 Then

        With Image
            Set .Picture = Nothing
            .ControlTipText = vbNullString
        End With

        UserForm.Repaint

    End If
End Sub

' **********************************************************************
' Modul: UserForm1 Typ: Userform
' **********************************************************************

Option Explicit

Private mobjSourceImageClassCollection As Collection
Private mobjTargetImageClassCollection As Collection

Private Sub UserForm_Activate()

    Dim ialngIndex As Long
    Dim sngLeft As Single
    Dim avntValues As Variant
    Dim objImage As MSForms.Image
    Dim objSourceImageClass As clsSourceImage
    Dim objTargetImageClass As clsTargetImage

    With Worksheets("Tabelle2")
        avntValues = .Range("A1:E30").Value2
    End With

    Set mobjSourceImageClassCollection = New Collection

    For ialngIndex = 1 To 30

        Set objImage = Controls.Add(bstrProgID:="Forms.Image.1", _
            Name:="Image" & CStr(ialngIndex))

        With objImage
            .Left = sngLeft
            .Top = 389
            .Width = 30
            .Height = 40
            .PictureSizeMode = fmPictureSizeModeStretch
            Set .Picture = LoadPicture(avntValues(ialngIndex, 1))
            .ControlTipText = avntValues(ialngIndex, 5)
        End With

        Set objSourceImageClass = New clsSourceImage

        Set objSourceImageClass.Image = objImage

        Call mobjSourceImageClassCollection.Add(Item:=objSourceImageClass)

        sngLeft = sngLeft + 30

    Next

    Set mobjTargetImageClassCollection = New Collection

    For ialngIndex = 40 To 50

        Set objTargetImageClass = New clsTargetImage

        With objTargetImageClass
            Set .Image = Controls("Image" & CStr(ialngIndex))
            Set .ChildImage = Controls("Image" & CStr(ialngIndex + 11))
            Set .UserForm = Me
        End With

        Call mobjTargetImageClassCollection.Add(Item:=objTargetImageClass)

    Next

    For ialngIndex = 51 To 61

        Set objTargetImageClass = New clsTargetImage

        With objTargetImageClass
            Set .Image = Controls("Image" & CStr(ialngIndex))
            Set .UserForm = Me
        End With

        Call mobjTargetImageClassCollection.Add(Item:=objTargetImageClass)

    Next

    Set objTargetImageClass = Nothing
    Set objSourceImageClass = Nothing
    Set objImage = Nothing

End Sub

Private Sub UserForm_Terminate()
    Set mobjSourceImageClassCollection = Nothing
    Set mobjTargetImageClassCollection = Nothing
End Sub

Gruß
Nepumuk

Forumthread: Drag and Drop in Userform

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Infobox / Tutorial

Drag and Drop in einer Userform mit Excel VBA

Schritt-für-Schritt-Anleitung

Häufige Fehler und Lösungen

Alternative Methoden

Praktische Beispiele

Tipps für Profis

FAQ: Häufige Fragen

Beliebteste Forumthreads (12 Monate)