Ejemplos usando el Api de windows para Visual basic

34 - Drag and drop de ficheros y directorios mediante algunas funciones Api

Contenido:

Ejemplo 1 ( Usando el Api )
Ejemplo 2 ( Sin Api )
Relacionados

Ejemplo 1 ( Con Apis )

Este ejemplo muestra como podemos arrastrar tanto archivos individuales como directorios completos desde Windows hacia un control Listbox para poder mostrar el path de estos ficheros.

Las principales funciones Api para realizar Drag&Drop son: FindFirstFile, FindNextFile, PathIsDirectory, DragAcceptFiles, DragQueryFile, SetWindowLong y CallWindowProc.

Controles

Colocar un ListBox llamado List1 en el formulario

Código fuente en el form

Private Sub Form_Load() 'DragAcceptFiles permite registrar el drag de 'archivos, el segundo parametr lo habilita y False lo deshabilita DragAcceptFiles hwnd, True ' get ready to accept files lProcOld = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf FileDropHandler) End Sub Private Sub Form_Unload(Cancel As Integer) 'Lo deshabilitamos DragAcceptFiles hwnd, False SetWindowLong hwnd, GWL_WNDPROC, lProcOld End Sub

Código en un módulo bas

' Funciones Api para buscar archivos y listarlos Public Declare Function FindFirstFile _ Lib "kernel32" _ Alias "FindFirstFileA" ( _ ByVal lpFileName As String, _ lpFindFileData As WIN32_FIND_DATA) As Long Public Declare Function FindNextFile _ Lib "kernel32" _ Alias "FindNextFileA" ( _ ByVal hFindFile As Long, _ lpFindFileData As WIN32_FIND_DATA) As Long Public Declare Function GetFileAttributes _ Lib "kernel32" _ Alias "GetFileAttributesA" ( _ ByVal lpFileName As String) As Long Public Declare Function FindClose _ Lib "kernel32" ( _ ByVal hFindFile As Long) As Long ' Declaración de constantes Const MAX_PATH = 260 Const MAXDWORD = &HFFFF Const INVALID_HANDLE_VALUE = -1 Const FILE_ATTRIBUTE_ARCHIVE = &H20 Const FILE_ATTRIBUTE_DIRECTORY = &H10 Const FILE_ATTRIBUTE_HIDDEN = &H2 Const FILE_ATTRIBUTE_NORMAL = &H80 Const FILE_ATTRIBUTE_READONLY = &H1 Const FILE_ATTRIBUTE_SYSTEM = &H4 Const FILE_ATTRIBUTE_TEMPORARY = &H100 ' Declaración de estructura para información de los archivos Public Type FILETIME dwLowDateTime As Long dwHighDateTime As Long End Type Public Type WIN32_FIND_DATA dwFileAttributes As Long ftCreationTime As FILETIME ftLastAccessTime As FILETIME ftLastWriteTime As FILETIME nFileSizeHigh As Long nFileSizeLow As Long dwReserved0 As Long dwReserved1 As Long cFileName As String * MAX_PATH cAlternate As String * 14 End Type 'Declaración de Apis para el drag and drop de los archivos Private Declare Function PathIsDirectory _ Lib "shlwapi.dll" _ Alias "PathIsDirectoryA" ( _ ByVal pszPath As String) As Long Private Declare Function PathIsDirectoryEmpty _ Lib "shlwapi.dll" _ Alias "PathIsDirectoryEmptyA" ( _ ByVal pszPath As String) As Long Public Declare Sub DragAcceptFiles _ Lib "shell32.dll" ( _ ByVal hWnd As Long, _ ByVal fAccept As Long) Private Declare Function DragQueryFile _ Lib "shell32.dll" _ Alias "DragQueryFileA" ( _ ByVal hDrop As Long, _ ByVal UINT As Long, _ ByVal lpStr As String, _ ByVal ch As Long) As Long Public Declare Function SetWindowLong _ Lib "user32" _ Alias "SetWindowLongA" ( _ ByVal hWnd As Long, _ ByVal nIndex As Long, _ ByVal dwNewLong As Long) As Long Private Declare Function CallWindowProc _ Lib "user32" _ Alias "CallWindowProcA" ( _ ByVal lpPrevWndFunc As Long, _ ByVal hWnd As Long, _ ByVal Msg As Long, _ ByVal wParam As Long, _ ByVal lParam As Long) As Long ' Constantes para el drag and drop Public Const WM_DROPFILES = &H233 Public Const GWL_WNDPROC = -4 Public lProcOld As Long Public Function FileDropHandler( _ ByVal hWnd As Long, _ ByVal iMsg As Long, _ ByVal wParam As Long, _ ByVal lParam As Long) As Long Dim FileName As String * 128 If iMsg = WM_DROPFILES Then 'Este bucle determina cuantos archivos se estàn arrastrando 'El -1 le indicamos que nos retorne todos los archivos que se arrastran Anzahl = DragQueryFile(wParam, -1, FileName, 127) 'Luego se hace un bucle For X = 1 To Anzahl 'Esta llamada a dragqueryfile nos devuelve el nombre DragQueryFile wParam, X - 1, FileName, 127 FileName = StripNulls(FileName) If ComprobarDirectorio(FileName) Then Buscar Trim$(FileName) Else Form1.List1.AddItem FileName End If 'lo agregamos al List 'Form1.List1.AddItem (FileName) Next X Exit Function End If FileDropHandler = CallWindowProc(lProcOld, hWnd, iMsg, wParam, lParam) End Function 'Esta función comprueba si un path es un _ directorio y devuelve true en caso verdadero Private Function ComprobarDirectorio(Path As String) As Boolean Path = Trim$(Path) If CBool(PathIsDirectory(Path)) Then ComprobarDirectorio = True End If End Function 'Esta función elimina los espacios nulos de los nombres y paths Function StripNulls(OriginalStr As String) As String If (InStr(OriginalStr, Chr(0)) > 0) Then OriginalStr = Left(OriginalStr, InStr(OriginalStr, Chr(0)) - 1) End If StripNulls = OriginalStr End Function Function FindFilesAPI( _ Path As String, _ SearchStr As String, _ FileCount As Integer, _ DirCount As Integer) Dim FileName As String ' Walking filename variable... Dim DirName As String ' SubDirectory Name Dim dirNames() As String ' Buffer for directory name entries Dim nDir As Integer ' Number of directories in this path Dim i As Integer ' For-loop counter... Dim hSearch As Long ' Search Handle Dim WFD As WIN32_FIND_DATA Dim Cont As Integer If Right(Path, 1) <> "\" Then Path = Path & "\" ' buscar subdirectorios. nDir = 0 ReDim dirNames(nDir) Cont = True hSearch = FindFirstFile(Path & "*", WFD) If hSearch <> INVALID_HANDLE_VALUE Then Do While Cont DirName = StripNulls(WFD.cFileName) If (DirName <> ".") And (DirName <> "..") Then If GetFileAttributes(Path & DirName) And FILE_ATTRIBUTE_DIRECTORY Then dirNames(nDir) = DirName DirCount = DirCount + 1 nDir = nDir + 1 ReDim Preserve dirNames(nDir) End If End If Cont = FindNextFile(hSearch, WFD) 'Get next subdirectory. Loop Cont = FindClose(hSearch) End If hSearch = FindFirstFile(Path & SearchStr, WFD) Cont = True If hSearch <> INVALID_HANDLE_VALUE Then While Cont FileName = StripNulls(WFD.cFileName) If (FileName <> ".") And (FileName <> "..") Then FindFilesAPI = FindFilesAPI + _ (WFD.nFileSizeHigh * MAXDWORD) + WFD.nFileSizeLow FileCount = FileCount + 1 Form1.List1.AddItem Path & FileName End If Cont = FindNextFile(hSearch, WFD) ' Get next file Wend Cont = FindClose(hSearch) End If If nDir > 0 Then For i = 0 To nDir - 1 FindFilesAPI = FindFilesAPI + FindFilesAPI(Path & dirNames(i) & _ "\", SearchStr, FileCount, DirCount) Next i End If End Function 'Procedimiento que busca archivos en los directorios Public Sub Buscar(Path As String) Dim SearchPath As String, FindStr As String Dim FileSize As Long Dim NumFiles As Integer, NumDirs As Integer Screen.MousePointer = vbHourglass SearchPath = Path FindStr = "*.*" FileSize = FindFilesAPI(SearchPath, FindStr, NumFiles, NumDirs) Screen.MousePointer = vbDefault End Sub

Ejemplo 2 - Sin el Api

Este ejemplo es igual al anterior pero sin utilizar funciones Apis. Se utiliza el evento oleDragDrop para recibir los datos al arrastrar los archivos, y luego recorrer la colección Files del objeto Data en un bucle For-Next para agregar los archivos

Nota. La propiedad OLEDropMode del control que recibirá los datos, en este caso del listbox , debe estar con el valor 1-Manual

Código fuente en el formulario con un control List1

Option Explicit Private Sub Form_Load() With List1 ' habilitar el drag drop para el control .OLEDropMode = 1 End With MsgBox "Arrastrar archivos hacia el listbox", vbInformation End Sub 'Código fuente del evento OLEDragDrop ' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub List1_OLEDragDrop( _ Data As DataObject, _ Effect As Long, _ Button As Integer, _ Shift As Integer, X As Single, Y As Single) On Error GoTo error_handler With Data ' Comprobar el formato de los datos que sean archivos If .GetFormat(vbCFFiles) Then ' Recorrer la colección de archivos dentro del objeto Data.files Dim i As Integer For i = 1 To .Files.Count List1.AddItem .Files(i) ' agregar la ruta Next End If End With ' errores Exit Sub error_handler: MsgBox Err.Description, vbCritical End Sub

Recursos vb - Enalces Relacionados

Buscar en Recursos vb