AW: Drag and Drop in Userform
05.06.2014 21:56:22
Nepumuk
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