关于OLE拖放的菜鸟问题

给你一个例子，这是两个窗体互相拖放的IMAGEDRAG2.VBPType=Exe
Form=Form1.frm
Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#C:\WINDOWS\System32\stdole2.tlb#OLE Automation
Form=Form2.frm
Module=mMove; mMove.bas
IconForm="Form1"
Startup="Form1"
HelpFile=""
Command32=""
Name="ImageDrag2"
HelpContextID="0"
CompatibleMode="0"
MajorVer=1
MinorVer=0
RevisionVer=0
AutoIncrementVer=0
ServerSupportFiles=0
VersionCompanyName="University of Calgary"
CompilationType=0
OptimizationType=0
FavorPentiumPro(tm)=0
CodeViewDebugInfo=0
NoAliasing=0
BoundsCheck=0
OverflowCheck=0
FlPointCheck=0
FDIVCheck=0
UnroundedFP=0
StartMode=0
Unattended=0
Retained=0
ThreadPerObject=0
MaxNumberOfThreads=1[MS Transaction Server]
AutoRefresh=1============================
form1.frmVERSION 5.00
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   3195
   ClientLeft      =   900
   ClientTop       =   465
   ClientWidth     =   4680
   LinkTopic       =   "Form1"
   OLEDropMode     =   1  'Manual
   ScaleHeight     =   3195
   ScaleWidth      =   4680
   Begin VB.Timer Timer1 
      Left            =   1320
      Top             =   2160
   End
   Begin VB.PictureBox Picture1 
      Appearance      =   0  'Flat
      AutoSize        =   -1  'True
      BackColor       =   &H80000005&
      ForeColor       =   &H80000008&
      Height          =   375
      Index           =   0
      Left            =   1200
      ScaleHeight     =   345
      ScaleWidth      =   225
      TabIndex        =   0
      Top             =   720
      Visible         =   0   'False
      Width           =   255
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'* only thing to do is make a form with a picturebox on it, make the picturebox
'  invisible, make the form's oledragdrop mode 'manual' and then this should work
'  good for draggin' and droppin' images around.' got through trial and error.  This is returned in 'effect' when you drop files
' on the form.
Const vbDropFilesFromExplorer = 7
' got through trial and error.  This is returned if you drag from form to form.
Const vbDropPictureFromForm = 3Dim Moving As Boolean
Dim ActiveIndex As Integer
Dim OldX, NewX As Integer
Dim OldY, NewY As IntegerPrivate Sub Form_Load()
    Moving = False
    mMove.Initialize Timer1
    Form2.Show
End Sub'here's the actual drag'n'drop work
Private Sub Form_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim i As Integer
    Dim NewIndex As Integer    ' check to see source of drop event.
    Select Case Effect
        Case vbDropFilesFromExplorer
            'data.files is a collection of strings that are absolute paths to any files
            'dragged and dropped to the form.
            For i = 1 To Data.Files.Count
                NewIndex = Picture1.Count + 1
                
                'check to see if we've got an image file
                If ImageFileCheck(Data.Files(i)) Then
                    Load Picture1(NewIndex)
                    Picture1(NewIndex).Picture = LoadPicture(Data.Files(i))
                    Picture1(NewIndex).Visible = True
                End If
            Next i
            
        Case vbDropEffectCopy
            If Data.GetFormat(vbCFBitmap) Then
                NewIndex = Picture1.Count + 1
                Load Picture1(NewIndex)
                Picture1(NewIndex).Picture = Data.GetData(vbCFBitmap)
                Picture1(NewIndex).Visible = True
                Picture1(NewIndex).ZOrder
            End If
            
    End Select
End Sub'checks to see if we've got an image file
Function ImageFileCheck(strFileName As String) As Boolean
    Dim strExtention As String
    
    'grab the file's extention
    strExtention = Right(strFileName, 3)
    
    'check the extention for an image type
    If (strExtention = "bmp") Or (strExtention = "jpg") Or _
        (strExtention = "gif") Then
        ImageFileCheck = True
    Else
        ImageFileCheck = False
    End If
        
End Function
Private Sub Picture1_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 1 Then
        Picture1(Index).OLEDrag
    ElseIf Button = 2 Then
        mMove.Begin Me.ActiveControl, Form1, X, Y
    End If
End SubPrivate Sub Picture1_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 2 Then mMove.InProgress X, Y
End SubPrivate Sub Picture1_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 2 Then mMove.EndIt
End SubPrivate Sub Picture1_OLEStartDrag(Index As Integer, Data As DataObject, AllowedEffects As Long)
    Data.SetData Picture1(Index).Picture, vbCFBitmap
    AllowedEffects = vbDropEffectCopy
End SubPrivate Sub Timer1_Timer()
    mMove.ToNewPosition Me.ScaleWidth, 0
End Sub

解决方案 »

  1.   

    form2.frmVERSION 5.00
    Begin VB.Form Form2 
       Caption         =   "Form2"
       ClientHeight    =   3195
       ClientLeft      =   900
       ClientTop       =   4005
       ClientWidth     =   4680
       LinkTopic       =   "Form2"
       OLEDropMode     =   1  'Manual
       ScaleHeight     =   3195
       ScaleWidth      =   4680
       Begin VB.PictureBox Picture1 
          Appearance      =   0  'Flat
          AutoSize        =   -1  'True
          BackColor       =   &H80000005&
          ForeColor       =   &H80000008&
          Height          =   255
          Index           =   0
          Left            =   720
          ScaleHeight     =   225
          ScaleWidth      =   345
          TabIndex        =   0
          Top             =   840
          Visible         =   0   'False
          Width           =   375
       End
    End
    Attribute VB_Name = "Form2"
    Attribute VB_GlobalNameSpace = False
    Attribute VB_Creatable = False
    Attribute VB_PredeclaredId = True
    Attribute VB_Exposed = False
    Option Explicit' got through trial and error.  This is returned in 'effect' when you drop files
    ' on the form.
    Const vbDropFilesFromExplorer = 7
    ' got through trial and error.  This is returned if you drag from form to form.
    Const vbDropPictureFromForm = 3'here's the actual drag'n'drop work
    Private Sub Form_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
        Dim i As Integer
        Dim NewIndex As Integer    ' check to see source of drop event.
        Select Case Effect
            
            Case vbDropFilesFromExplorer
                'data.files is a collection of strings that are absolute paths to any files
                'dragged and dropped to the form.
                For i = 1 To Data.Files.Count
                    NewIndex = Picture1.Count + 1
                    
                    'check to see if we've got an image file
                    If ImageFileCheck(Data.Files(i)) Then
                        Load Picture1(NewIndex)
                        Picture1(NewIndex).Picture = LoadPicture(Data.Files(i))
                        Picture1(NewIndex).Visible = True
                    End If
                Next i
                
            Case vbDropEffectCopy
                If Data.GetFormat(vbCFBitmap) Then
                    NewIndex = Picture1.Count + 1
                    Load Picture1(NewIndex)
                    Picture1(NewIndex).Picture = Data.GetData(vbCFBitmap)
                    Picture1(NewIndex).Visible = True
                    Picture1(NewIndex).ZOrder
                End If
        
        End Select
    End Sub'checks to see if we've got an image file
    Function ImageFileCheck(strFileName As String) As Boolean
        Dim strExtention As String
        
        'grab the file's extention
        strExtention = Right(strFileName, 3)
        
        'check the extention for an image type
        If (strExtention = "bmp") Or (strExtention = "jpg") Or _
            (strExtention = "gif") Then
            ImageFileCheck = True
        Else
            ImageFileCheck = False
        End If
            
    End FunctionPrivate Sub Picture1_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
        If Button = 1 Then
            Picture1(Index).OLEDrag
        ElseIf Button = 2 Then
            mMove.Begin Me.ActiveControl, Form2, X, Y
        End If
    End SubPrivate Sub Picture1_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
        If Button = 2 Then mMove.InProgress X, Y
    End SubPrivate Sub Picture1_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
        If Button = 2 Then mMove.EndIt
    End Sub
    Private Sub Picture1_OLEStartDrag(Index As Integer, Data As DataObject, AllowedEffects As Long)
        Data.SetData Picture1(Index).Picture, vbCFBitmap
        AllowedEffects = vbDropEffectCopy
    End Sub
    ==================================================================mMove.basAttribute VB_Name = "mMove"
    Option Explicit'the Current X and Y position
    Public curX As Single
    Public curY As Single'the last recorded X and Y position
    Private lastX As Single
    Private lastY As Single'the outer move bounds of the scrollbar thingie
    Private minX As Single
    Private maxX As Single'the control being moved
    Private meControl As control
    Private meForm As Form'Whether the control is in the middle of being moved
    Private Moving As Boolean
    Private timer As timer' Begin the move
    Public Sub Begin(control As control, theform As Form, X As Single, Y As Single)
        mMove.Moving = True
        Set mMove.meControl = control
        Set mMove.meForm = theform
        mMove.lastX = X
        mMove.lastY = Y
    End SubPublic Sub InProgress(X As Single, Y As Single)
        If Not mMove.Moving Then Exit Sub
        timer.Enabled = True
        
        mMove.curX = X - mMove.lastX
        mMove.curY = Y - mMove.lastY
    End SubPublic Sub EndIt()
        mMove.Moving = False
        timer.Enabled = False
    End SubPublic Sub ToNewPosition(RightBound As Integer, LeftBound As Integer)
        Dim X As Single
        Dim Y As Single    'Set it to the new position.
        X = mMove.meControl.Left + curX
        Y = mMove.meControl.Top + curY
        
        'Make sure we don't drag it off the screen...
        If X < LeftBound Then
            X = LeftBound
        ElseIf X > (RightBound - mMove.meControl.Width) Then
            X = RightBound - mMove.meControl.Width
        End If
        If mMove.meControl.Top + mMove.curY < 0 Then
            Y = 0
        ElseIf Y > meForm.ScaleHeight - mMove.meControl.Height Then
            Y = meForm.ScaleHeight - mMove.meControl.Height
        End If
        
        mMove.meControl.Move X, Y
    End SubPublic Sub Initialize(tmr As timer)
        tmr.Enabled = False
        tmr.Interval = 30
        Set timer = tmr
    End Sub