Mensajes

Solucionado, Gracias Raul338 y BlackZeroX , habia que hacerlo con ReadDirectoryChangesW

Código (Vb) [Seleccionar] Expandir


Option Explicit

Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function ReadDirectoryChangesW Lib "kernel32.dll" (ByVal hDirectory As Long, ByVal lpBuffer As Long, ByVal nBufferLength As Long, ByVal bWatchSubtree As Boolean, ByVal dwNotifyFilter As Long, lpBytesReturned As Long, ByVal lpOverlapped As Long, ByVal lpCompletionRoutine As Long) As Long
Private Declare Function GetLogicalDriveStrings Lib "kernel32" Alias "GetLogicalDriveStringsA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)

Private Const FILE_SHARE_DELETE             As Long = &H4
Private Const FILE_SHARE_READ               As Long = &H1
Private Const FILE_SHARE_WRITE              As Long = &H2
Private Const FILE_LIST_DIRECTORY           As Long = &H1
Private Const OPEN_EXISTING                 As Long = &H3
Private Const FILE_FLAG_BACKUP_SEMANTICS    As Long = &H2000000
Private Const FILE_FLAG_OVERLAPPED          As Long = &H40000000
Private Const INVALID_HANDLE_VALUE          As Long = (-1)
Private Const FILE_NOTIFY_CHANGE_ALL        As Long = &H17F


Private Type OVERLAPPED
    Internal                        As Long
    InternalHigh                    As Long
    offset                          As Long
    OffsetHigh                      As Long
    hEvent                          As Long
End Type

Private Type FILE_NOTIFY_INFORMATION
    dwNextEntryOffset               As Long
    dwAction                        As Long
    dwFileNameLength                As Long
    wcFileName(1023)                As Byte
End Type


Private Type DriveChange
    hDrive                          As Long
    sDrive                          As String
    Buff(0 To 1024 * 9 - 1)         As Byte
End Type


Private aChange()           As DriveChange

Private MyFileName          As String

Private Sub Form_Load()
    MyFileName = "RemoteImagen.bmp"
    Picture1.OLEDragMode = 1
End Sub

Private Sub Picture1_OLECompleteDrag(Effect As Long)
    Debug.Print GetDestination(MyFileName)
    Kill App.Path & "\" & MyFileName
End Sub


Private Sub Picture1_OLEStartDrag(Data As DataObject, AllowedEffects As Long)
    Open App.Path & "\" & MyFileName For Binary As #1: Close #1
   
    Call StartWatching
    Data.SetData , vbCFFiles
    Data.Files.Add App.Path & "\" & MyFileName
    AllowedEffects = vbDropEffectCopy
End Sub

Public Sub StartWatching()
    Dim lRet As Long
    Dim sBuff As String * 255
    Dim arrDrive() As String
    Dim lPos As Long
    Dim i As Long
    Dim tOLAP As OVERLAPPED
   
    lRet = GetLogicalDriveStrings(255, sBuff)

    arrDrive = Split(Left$(sBuff, lRet - 1), Chr$(0))

    For i = 0 To UBound(arrDrive)
        lRet = CreateFile(arrDrive(i), FILE_LIST_DIRECTORY, FILE_SHARE_READ Or FILE_SHARE_DELETE Or FILE_SHARE_WRITE, 0&, OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS Or FILE_FLAG_OVERLAPPED, 0&)
   
        If lRet <> INVALID_HANDLE_VALUE Then
            ReDim Preserve aChange(lPos)
            aChange(lPos).hDrive = lRet
            aChange(lPos).sDrive = arrDrive(i)
            lPos = lPos + 1
        End If
    Next
   
    For i = 0 To UBound(aChange)
        Call ReadDirectoryChangesW(aChange(i).hDrive, VarPtr(aChange(i).Buff(0)), 9216, True, FILE_NOTIFY_CHANGE_ALL, 0&, VarPtr(tOLAP), 0&)
    Next
   
End Sub

Private Function GetDestination(ByVal sName As String) As String
    Dim i As Long
    Dim sData As String
    Dim lPos As Long
    Dim lRet As Long
    Dim tFNI As FILE_NOTIFY_INFORMATION
    Dim tOLAP As OVERLAPPED
   
    Dim SafeCounter As Long
   
    Do While SafeCounter < 1000

        For i = 0 To UBound(aChange)
            lPos = 0
           
            Do
                Call CopyMemory(VarPtr(tFNI), VarPtr(aChange(i).Buff(lPos)), Len(tFNI))
   
                sData = Left$(tFNI.wcFileName, tFNI.dwFileNameLength / 2)
     
                If InStr(sData, sName) Then
                    GetDestination = aChange(i).sDrive & sData
                    GoTo StopWatching
                End If
               
                If tFNI.dwNextEntryOffset = 0 Then Exit Do
               
                lPos = lPos + tFNI.dwNextEntryOffset
            Loop
           
            Call ReadDirectoryChangesW(aChange(i).hDrive, VarPtr(aChange(i).Buff(0)), 9216, True, FILE_NOTIFY_CHANGE_ALL, 0&, VarPtr(tOLAP), 0&)
       
            DoEvents
        Next
        SafeCounter = SafeCounter + 1
       
    Loop
   
    Debug.Print "Error or Cancel"
   
StopWatching:

    For i = 0 To UBound(aChange)
        Call CloseHandle(aChange(i).hDrive)
    Next
   
    Erase aChange
   
End Function



si de echo yo pensaba lo mismo, pero no lo intente, Cobein hizo una clase FileSystemWatcher para vb6

Saludos.

BlackZeroX fijate que se puede eliminar sin utilizar el array temporal

Código [Seleccionar] Expandir


Function RemoveInArrayLong(ByVal Index As Long, ByRef ThisArray() As Long) As Boolean
    Dim LenArray As Long
    LenArray = UBound(ThisArray)
    If Index < 0 Or Index > LenArray Then Exit Function
    If Not (Index = LenArray) Then
        Call CopyMemory(VarPtr(ThisArray(Index)), VarPtr(ThisArray(Index + 1)), (LenArray - Index) * 4)
    End If
    If LenArray - 1 >= 0 Then
        ReDim Preserve ThisArray(LenArray - 1)
        RemoveInArrayLong = True
    Else
        Erase ThisArray()
    End If
End Function


Gracias raul338 por reportar el bugs, ya lo estoy corrigiendo, en cuanto a lo del drag a drop que me pasaste el otro día, bueno mala educación la mía no responder ejej, pero igualmente no me sirve por el tema de que el archivo no existe en la pc, osea para poder hacerlo de esa forma primero deberia descargar el archivo y como este no trabaja de una forma sincronizada, no puedo, yo lo que necesitaria saber es el destino donde se soltó el item para luego hacer una descarga normal.
no importa que el uclistview no tenga los eventos del drag and drop yo se los agrego.
una solución no muy elegante que me salio
http://www.vbforums.com/showthread.php?t=629147
pero no esta bien ya que no funciona con el escritorio, con subitems del listview de la carpeta y menos con el treview del explorer, osea una cagada.
pero no importa ya fue.

saludos. y gracias a todos por sus comentarios.

aja si es cierto 76 kb, es mucho mas interesante, porque en la primera etapa pesa 120 kb voy mal .

Saludos.

Hola es un poco mas de lo mismo, por el momento es un explorador remoto de archivos y carpetas realizado en vb, tiene unas cuantas herramientas.
si les interesa saber un poco mas de que se trata y descargarlo abajo esta el link.





Descargar.

Hola, como podria hacer un drag and drop sobre una carpeta y poder conocer el destino de esta carpeta, para poder abrir un archivo en forma binarya.

si yo utilizo este metodo

Código [Seleccionar] Expandir

Private Sub ListView1_OLEStartDrag(Data As ComctlLib.DataObject, AllowedEffects As Long)
    Dim i As Long
   
    For i = 1 To ListView1.ListItems.Count
   
        If ListView1.ListItems.Item(i).Selected = True Then
       
            Data.Files.Add ListView1.ListItems(i).Tag
            Data.SetData , vbCFFiles
           
        End If
       
    Next

End Sub

es nesesario que el archivo ya exista (ListView1.ListItems(i).Tag) pero esto me obliga a no poder continuar modificandolo.

mi nececidad es crearlo luego de haber hecho el drag and drop.

Es posible esto?

ok siempre apurado no leo bien las cosas 

Código [Seleccionar] Expandir


Option Explicit

Private Declare Function GetTickCount Lib "kernel32.dll" () As Long

Private Sub Form_Load()
    Dim arr() As Long, lNum As Long
    Dim t As Long
   
   
    t = GetTickCount
   
    lNum = 1000
   
    CuadradoArray arr, lNum

    Debug.Print ArrToString(arr, lNum)
   
    MsgBox GetTickCount - t
End Sub


Private Sub CuadradoArray(arr() As Long, lNum As Long)
    Dim x As Long, y As Long, n As Long
    Dim i As Long, lCount As Long
   
    ReDim arr(lNum - 1, lNum - 1)
   
    For n = 0 To lNum - 1
   
        y = i
        i = i + 1
       
        For x = 0 To lNum - i
            lCount = lCount + 1
            arr(x, y) = lCount
        Next
   
        x = x - 1
       
        For y = i To lNum - 1
            lCount = lCount + 1
            arr(x, y) = lCount
        Next
       
    Next
End Sub


Private Function ArrToString(arr() As Long, ByVal lNum As Long) As String
    Dim x As Long, y As Long
    Dim LenFormat As Long
    Dim sVal As String
    Dim i As Long

    LenFormat = Len(CStr(lNum * lNum))

    ArrToString = String((lNum * lNum) * (LenFormat + 1), "0")

    lNum = lNum - 1

    For y = 0 To lNum
        For x = 0 To lNum
            sVal = arr(x, y)
            i = i + 1
            If x = lNum Then
                Mid$(ArrToString, (i * LenFormat) - Len(sVal) + i) = sVal & vbCr
            Else
                Mid$(ArrToString, (i * LenFormat) - Len(sVal) + i) = sVal & vbTab
            End If
        Next
    Next
End Function


y que hace la LocalAppData (?)

hace esto

Código [Seleccionar] Expandir


Option Explicit

Private Sub Form_Load()
    MsgBox GetLocalAppData
End Sub

Public Function GetLocalAppData() As String
    GetLocalAppData = CreateObject("Shell.Application").NameSpace(28).Self.Path
End Function


hay va el mio

Código [Seleccionar] Expandir


Option Explicit

Private Sub Form_Load()
    Dim Arr() As Long, lNum As Long
   
    lNum = 10
   
    CuadradoArray Arr, lNum
   
    PrintArr Arr, lNum
End Sub


Private Sub CuadradoArray(Arr() As Long, lNum As Long)
    Dim x As Long, y As Long, n As Long
    Dim i As Long, lCount As Long
   
    ReDim Arr(lNum - 1, lNum - 1)
   
    For n = 0 To lNum - 1
   
        y = i
        i = i + 1
       
        For x = 0 To lNum - i
            lCount = lCount + 1
            Arr(x, y) = lCount
        Next
   
        x = x - 1
       
        For y = i To lNum - 1
            lCount = lCount + 1
            Arr(x, y) = lCount
        Next
       
    Next
End Sub

Private Sub PrintArr(Arr() As Long, lNum As Long)
    Dim x As Long, y As Long, sFormat As String
   
    sFormat = String(Len(CStr(lNum * lNum)), "0")
   
    For y = 0 To lNum - 1
        For x = 0 To lNum - 1
            Debug.Print Format(Arr(x, y), sFormat),
        Next
        Debug.Print
    Next
End Sub