|
181
|
Programación / Programación Visual Basic / Re: [Proyecto]Explorador Remoto.
|
en: 11 Octubre 2010, 03:07 am
|
Solucionado, Gracias Raul338 y BlackZeroX , habia que hacerlo con ReadDirectoryChangesW 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
|
|
|
183
|
Programación / Programación Visual Basic / Re: [Solucionado] Como Desbloquear un Array...
|
en: 10 Octubre 2010, 10:24 am
|
BlackZeroX fijate que se puede eliminar sin utilizar el array temporal 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
|
|
|
184
|
Programación / Programación Visual Basic / Re: [Proyecto]Explorador Remoto.
|
en: 10 Octubre 2010, 03:13 am
|
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=629147pero 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.
|
|
|
187
|
Programación / Programación Visual Basic / Drag and Drop, vbCFFiles, conocer la carpeta de destino
|
en: 1 Octubre 2010, 04:34 am
|
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 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?
|
|
|
188
|
Programación / Programación Visual Basic / Re: [RETO] Cuadradro Numerico en de forma "¬"
|
en: 18 Septiembre 2010, 05:07 am
|
ok siempre apurado no leo bien las cosas 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
|
|
|
190
|
Programación / Programación Visual Basic / Re: [RETO] Cuadradro Numerico en de forma "¬"
|
en: 18 Septiembre 2010, 02:37 am
|
hay va el mio 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
|
|
|
|
|
|
|