home *** CD-ROM | disk | FTP | other *** search
- VERSION 4.00
- Begin VB.Form frmDrag
- Caption = "Drag and Drop"
- ClientHeight = 2670
- ClientLeft = 2130
- ClientTop = 3780
- ClientWidth = 6405
- ClipControls = 0 'False
- BeginProperty Font
- name = "MS Sans Serif"
- charset = 1
- weight = 700
- size = 8.25
- underline = 0 'False
- italic = 0 'False
- strikethrough = 0 'False
- EndProperty
- Height = 3075
- Left = 2070
- LinkTopic = "Form2"
- MDIChild = -1 'True
- ScaleHeight = 2670
- ScaleWidth = 6405
- Top = 3435
- Width = 6525
- Begin VB.DriveListBox Drive1
- DragIcon = "DRAG.frx":0000
- BeginProperty Font
- name = "MS Sans Serif"
- charset = 1
- weight = 700
- size = 8.25
- underline = 0 'False
- italic = 0 'False
- strikethrough = 0 'False
- EndProperty
- Height = 315
- Left = 120
- TabIndex = 2
- Top = 120
- Width = 1935
- End
- Begin VB.FileListBox File1
- BeginProperty Font
- name = "System"
- charset = 1
- weight = 700
- size = 9.75
- underline = 0 'False
- italic = 0 'False
- strikethrough = 0 'False
- EndProperty
- Height = 2184
- Left = 2280
- Pattern = "*.txt;*.bmp;*.exe;*.hlp"
- TabIndex = 1
- Top = 120
- Width = 2052
- End
- Begin VB.DirListBox Dir1
- DragIcon = "DRAG.frx":030A
- BeginProperty Font
- name = "System"
- charset = 1
- weight = 700
- size = 9.75
- underline = 0 'False
- italic = 0 'False
- strikethrough = 0 'False
- EndProperty
- Height = 1920
- Left = 120
- TabIndex = 0
- Top = 600
- Width = 1935
- End
- Begin VB.Image Image1
- BorderStyle = 1 'Fixed Single
- Height = 2415
- Left = 4560
- Stretch = -1 'True
- Top = 120
- Width = 1725
- End
- Attribute VB_Name = "frmDrag"
- Attribute VB_Creatable = False
- Attribute VB_Exposed = False
- Private Sub Dir1_Change()
- file1.Path = Dir1.Path
- End Sub
- Private Sub Drive1_Change()
- On Error GoTo DriveErrs
- Dir1.Path = Drive1.Drive
- Exit Sub
- DriveErrs:
- Select Case Err
- Case 68
- MsgBox prompt:="Drive not ready. Please insert disk in drive.", _
- buttons:=vbExclamation
- ' Reset path to previous drive.
- Drive1.Drive = Dir1.Path
- Exit Sub
- Case Else
- MsgBox prompt:="Application error.", buttons:=vbExclamation
- End Select
- End Sub
- Private Sub File1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
- file1.DragIcon = Drive1.DragIcon
- file1.Drag
- End Sub
- Private Sub Form_Load()
- frmDrag.Width = 6525
- frmDrag.Height = 3075
- End Sub
- Private Sub Image1_DragDrop(Source As Control, X As Single, Y As Single)
- ' Get the last three letters of the dragged filename.
- temp = Right$(file1.FileName, 3)
- ' If dragged file is in the root, append filename.
- If Mid(file1.Path, Len(file1.Path)) = "\" Then
- dropfile = file1.Path & file1.FileName
- ' If dragged file is not in root, append "\" and filename.
- Else
- dropfile = file1.Path & "\" & file1.FileName
- End If
-
- image1.Picture = LoadPicture("")
- Select Case temp
- Case "txt"
- X = Shell("Notepad " + dropfile, 1)
- Case "bmp"
- image1.Picture = LoadPicture(dropfile)
- Case "exe"
- X = Shell(dropfile, 1)
- Case "hlp"
- X = Shell("WinHelp " + dropfile, 1)
- Case Else
- nl = Chr$(10) + Chr$(13)
- msg = "Try one of these file types:"
- msg = nl + msg + nl + nl + " .txt, .bmp, .exe, .hlp"
- MsgBox msg
- End Select
- End Sub
- Private Sub Image1_DragOver(Source As Control, X As Single, Y As Single, State As Integer)
- Select Case State
- Case 0
- ' Display a new icon when the source enters the drop area.
- file1.DragIcon = Dir1.DragIcon
- Case 1
- ' Display the original DragIcon when the source leaves the drop area.
- file1.DragIcon = Drive1.DragIcon
- End Select
- ' Note that Dir1.DragIcon and Drive1.DragIcon have been
- ' set at design time. This allows you to load the "Enter"
- ' and "Leave" icons for File1 at run time without requiring
- ' that the user has those icons on disk.
- End Sub
-