Mensajes

[vb.net]

Propongo esto pues cada dos por tres entra gente despistada poniendo dudas y códigos de vb.net, el cual ya tiene foro específico.
Creo que si se cambiara el nombre a Programación Visual Basic 6 ahorraría trabajo a los moderadores, que están moviendo temas constantemente y contribuiría a la limpieza del foro.

¿Qué os parece?

DoEvents!

[ATENCIÓN]

ATENCIÓN: He añadido un detalle en la explicación del reto.



La forma que se me había ocurrido es similar a la de seba123neo... Pero estoy convencido de que se puede hacer sin guardar todas las carpetas, se ahorraría muchísimo tiempo. Sigo pensando.

Cometi el error de copypastear tu codigo en una CMD.

CUIDADO CON EL PESO DEL TXT!

DoEvents!

Claro, hay que sacar la ruta más profunda.

DoEvents!

Pues eso, consiste en encontrar la manera más rápida de obtener la última carpeta accesible a partir de una ruta, los formatos válidos son estos:

Código (vb) [Seleccionar] Expandir

Public Function getLastFolder(Byval sStartPath As String) As String()
Public Function getLastFolder(Byval sStartPath As String) As Collection

Ejemplo:

Código (vb) [Seleccionar] Expandir


Debug.Print getLastFolder("C:\Users\casa-pc\Desktop\")


Código [Seleccionar] Expandir

C:\Users\casa-pc\Desktop\Música\Sonido\Programas\Video\VLC\data\res

Consiste en encontrar la carpeta más profunda, en caso de haber más de una la función devolverá el resultado en una collection o en un array.

¡Suerte!

[CTiming]

Ok, se me escapó. Gracias, ya lo he corregido.
Ahora tan sólo queda hacer los test con CTiming.

DoEvents!

[expresiones regulares]

Las expresiones regulares pueden facilitarte mucho las cosas.

DoEvents!

[LeandroA]

Bueno, aquí dejo mi forma de hacerlo.
Lo he planteado de una manera un poco diferente y es bastante rápido. Aún así, quizás se podría agilizar aún más con algo de magia negra, pero como la cadena de la url va a ser relativamente corta supongo que no habrá una diferencia muy notable.
Si veis cosas a añadir o a mejorar decirlo, aunque creo que se adapta a lo que pide LeandroA en el primer post.



Módulo:

Código (vb) [Seleccionar] Expandir

Option Explicit
'============================================================================
' º Module     : mFastUrlEncode.bas
' º Author     : Psyke1
' º Mail       : psyke1@elhacker.net
' º Date       : 22/12/2012
' º Recommended Websites :
'       http://foro.h-sec.org
'       http://infrangelux.sytes.net
'============================================================================

'// msvbvm60.dll
Private Declare Sub PutMem4 Lib "msvbvm60.dll" (ByVal Ptr As Long, ByVal Value As Long)

'// oleaut32.dll
Private Declare Function SysAllocStringByteLen Lib "oleaut32.dll" (ByVal Ptr As Long, ByVal Length As Long) As Long

'// kernel32.dll
Private Declare Function WideCharToMultiByte Lib "kernel32.dll" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpDefaultChar As String, ByVal lpUsedDefaultChar As Long) As Long
Private Declare Function MultiByteToWideChar Lib "kernel32.dll" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long

Private Const CP_UTF8                           As Long = &HFDE9&
Private Const STR_VALID_CHARS                   As String = "QWERTYUIOPASDFGHJKLZXCVBNMqwertyuiopasdfghjklzxcvbnm1234567890-_.:~%&="

Public Static Function URLEncode(ByVal sUrl As String, _
                                Optional ByVal bSpacePlus As Boolean, _
                                Optional ByVal bUTF8 As Boolean = True) As String
                               
Dim Q                                           As Long
Dim sHex                                        As String
Dim sChr                                        As String * &H1
Dim lRet                                        As Long
Dim lLen                                        As Long
Dim lStart                                      As Long
Dim sBuffer                                     As String
   
   lLen = LenB(sUrl)
   If lLen Then
       lStart = InStrB(&H1, sUrl, "=", vbBinaryCompare) - &H1
       
       If lStart > -&H1 Then
           lRet = lLen - lStart
           URLEncode = RightB$(sUrl, lRet)
           
           If bUTF8 Then
               PutMem4 VarPtr(sBuffer), SysAllocStringByteLen(&H0, (lRet + lRet))
               
               lRet = WideCharToMultiByte(CP_UTF8, &H0, _
                                          StrPtr(URLEncode), (lRet \ &H2), _
                                          StrPtr(sBuffer), lRet, _
                                          vbNullString, &H0)
               
               URLEncode = LeftB$(StrConv(sBuffer, vbUnicode), (lRet + lRet))
           End If
           
           Q = &H3
           
           Do While Q < lLen
               sChr = MidB$(URLEncode, Q, &H2)
               
               If sChr = "%" Then
                   Q = Q + &H6
               ElseIf InStrB(&H1, STR_VALID_CHARS, sChr, vbBinaryCompare) = &H0 Then
                   sHex = Hex$(AscW(sChr))
                   If LenB(sHex) < &H4 Then sHex = "0" & sHex
                   
                   URLEncode = Replace$(URLEncode, sChr, ("%" & sHex), , , vbBinaryCompare)
                   
                   lLen = LenB(URLEncode)
                   Q = Q + &H6
               Else
                   Q = Q + &H2
               End If
           Loop
           
           If bSpacePlus Then
               URLEncode = Replace$(URLEncode, "%20", "+", , , vbBinaryCompare)
           End If
           
           URLEncode = (LeftB$(sUrl, lStart) & URLEncode)
       Else
           URLEncode = sUrl
       End If
   End If
End Function

Public Static Function URLDecode(ByVal sUrl As String, _
                                Optional ByVal bSpacePlus As Boolean, _
                                Optional ByVal bUTF8 As Boolean = True) As String
                               
Dim sHex                                        As String
Dim lPos                                        As Long
Dim lLen                                        As Long
Dim lStart                                      As Long
Dim sBuffer                                     As String

   If LenB(sUrl) Then
       lStart = InStrB(&H1, sUrl, "=", vbBinaryCompare) + &H2
       URLDecode = sUrl

       If lStart > &H2 Then
           lPos = InStrB(lStart, URLDecode, "%", vbBinaryCompare)

           Do While lPos
               lPos = lPos + &H2
               sHex = MidB$(URLDecode, lPos, &H4)
               If LenB(sHex) = &H0 Then Exit Do

               URLDecode = Replace$(URLDecode, ("%" & sHex), ChrW$("&H" & sHex), , , vbBinaryCompare)
               lPos = InStrB(lPos, URLDecode, "%", vbBinaryCompare)
           Loop

           If bSpacePlus Then
               URLDecode = Replace$(URLDecode, "+", " ", , , vbBinaryCompare)
           End If
           
           If bUTF8 Then
               lLen = LenB(URLDecode) \ &H2
               PutMem4 VarPtr(sBuffer), SysAllocStringByteLen(&H0, lLen + lLen)
               
               lLen = MultiByteToWideChar(CP_UTF8, &H0, _
                      StrPtr(StrConv(URLDecode, vbFromUnicode)), lLen, _
                      StrPtr(sBuffer), lLen)
                     
               URLDecode = LeftB$(sBuffer, (lLen + lLen))
           End If
       End If
   End If
End Function




Pruebas:

Código (vb) [Seleccionar] Expandir

Option Explicit

Private Sub Form_Load()
Dim vURL                                    As Variant
Dim vArr()                                  As Variant
Dim sEncodedURL                             As String

   vArr() = Array("https://www.google.com.ar/search?q=canción del caballo", _
                  "http://www.taringa.net/buscar/?q=día 12/12/12&interval=", _
                  "https://login.live.com/login.srf?wa=wsignin1.0&rpsnv=11&ct=1312101221&rver=6.1.6206.0&wp=MBI&wreply=http://mail.live.com/default.aspx&lc=2058&id=64855&mkt=es-US&cbcxt=mai&snsc=1", _
                  "https://www.google.com.ar/search?q=casa duplex&num=10&hl=es&safe=off&biw=1680&bih=925&sa=X&ei=mS7RUIqvHYjW8gSA9oHABg&ved=0CBkQpwUoAw&source=lnt&tbs=cdr:1,cd_min:5/12/2012,cd_max:18/12/2012&tbm=isch")

   Debug.Print
   Debug.Print String$(15, "-"); Time$; String$(227, "-")

   For Each vURL In vArr
       Debug.Print String$(250, "=")
       Debug.Print "Original :", vURL

       sEncodedURL = URLEncode(vURL)
       Debug.Print "Enc&Dec  :", URLDecode(sEncodedURL)
       Debug.Print "Enc      :", sEncodedURL

       sEncodedURL = URLEncode(vURL, True)
       Debug.Print "Enc&Dec+ :", URLDecode(sEncodedURL, True)
       Debug.Print "Enc+     :", sEncodedURL
   Next vURL

   Debug.Print String$(250, "=")
End Sub



Resultado:

Código [Seleccionar] Expandir


---------------01:55:53-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
==========================================================================================================================================================================================================================================================
Original :    https://www.google.com.ar/search?q=canción del caballo
Enc&Dec  :    https://www.google.com.ar/search?q=canción del caballo
Enc      :    https://www.google.com.ar/search?q=canci%C3%B3n%20del%20caballo
Enc&Dec+ :    https://www.google.com.ar/search?q=canción del caballo
Enc+     :    https://www.google.com.ar/search?q=canci%C3%B3n+del+caballo
==========================================================================================================================================================================================================================================================
Original :    http://www.taringa.net/buscar/?q=día 12/12/12&interval=
Enc&Dec  :    http://www.taringa.net/buscar/?q=día 12/12/12&interval=
Enc      :    http://www.taringa.net/buscar/?q=d%C3%ADa%2012%2F12%2F12&interval=
Enc&Dec+ :    http://www.taringa.net/buscar/?q=día 12/12/12&interval=
Enc+     :    http://www.taringa.net/buscar/?q=d%C3%ADa+12%2F12%2F12&interval=
==========================================================================================================================================================================================================================================================
Original :    https://login.live.com/login.srf?wa=wsignin1.0&rpsnv=11&ct=1312101221&rver=6.1.6206.0&wp=MBI&wreply=http://mail.live.com/default.aspx&lc=2058&id=64855&mkt=es-US&cbcxt=mai&snsc=1
Enc&Dec  :    https://login.live.com/login.srf?wa=wsignin1.0&rpsnv=11&ct=1312101221&rver=6.1.6206.0&wp=MBI&wreply=http://mail.live.com/default.aspx&lc=2058&id=64855&mkt=es-US&cbcxt=mai&snsc=1
Enc      :    https://login.live.com/login.srf?wa=wsignin1.0&rpsnv=11&ct=1312101221&rver=6.1.6206.0&wp=MBI&wreply=http%3A%2F%2Fmail.live.com%2Fdefault.aspx&lc=2058&id=64855&mkt=es-US&cbcxt=mai&snsc=1
Enc&Dec+ :    https://login.live.com/login.srf?wa=wsignin1.0&rpsnv=11&ct=1312101221&rver=6.1.6206.0&wp=MBI&wreply=http://mail.live.com/default.aspx&lc=2058&id=64855&mkt=es-US&cbcxt=mai&snsc=1
Enc+     :    https://login.live.com/login.srf?wa=wsignin1.0&rpsnv=11&ct=1312101221&rver=6.1.6206.0&wp=MBI&wreply=http%3A%2F%2Fmail.live.com%2Fdefault.aspx&lc=2058&id=64855&mkt=es-US&cbcxt=mai&snsc=1
==========================================================================================================================================================================================================================================================
Original :    https://www.google.com.ar/search?q=casa duplex&num=10&hl=es&safe=off&biw=1680&bih=925&sa=X&ei=mS7RUIqvHYjW8gSA9oHABg&ved=0CBkQpwUoAw&source=lnt&tbs=cdr:1,cd_min:5/12/2012,cd_max:18/12/2012&tbm=isch
Enc&Dec  :    https://www.google.com.ar/search?q=casa duplex&num=10&hl=es&safe=off&biw=1680&bih=925&sa=X&ei=mS7RUIqvHYjW8gSA9oHABg&ved=0CBkQpwUoAw&source=lnt&tbs=cdr:1,cd_min:5/12/2012,cd_max:18/12/2012&tbm=isch
Enc      :    https://www.google.com.ar/search?q=casa%20duplex&num=10&hl=es&safe=off&biw=1680&bih=925&sa=X&ei=mS7RUIqvHYjW8gSA9oHABg&ved=0CBkQpwUoAw&source=lnt&tbs=cdr%3A1%2Ccd_min%3A5%2F12%2F2012%2Ccd_max%3A18%2F12%2F2012&tbm=isch
Enc&Dec+ :    https://www.google.com.ar/search?q=casa duplex&num=10&hl=es&safe=off&biw=1680&bih=925&sa=X&ei=mS7RUIqvHYjW8gSA9oHABg&ved=0CBkQpwUoAw&source=lnt&tbs=cdr:1,cd_min:5/12/2012,cd_max:18/12/2012&tbm=isch
Enc+     :    https://www.google.com.ar/search?q=casa+duplex&num=10&hl=es&safe=off&biw=1680&bih=925&sa=X&ei=mS7RUIqvHYjW8gSA9oHABg&ved=0CBkQpwUoAw&source=lnt&tbs=cdr%3A1%2Ccd_min%3A5%2F12%2F2012%2Ccd_max%3A18%2F12%2F2012&tbm=isch
==========================================================================================================================================================================================================================================================


DoEvents!

LeandroA hizo esto hace tiempo:

Código [Seleccionar] Expandir

http://leandroascierto.com/blog/explorador-remoto-proyecto-en-marcha/
http://leandroascierto.com/blog/proyecto-en-marcha-parte-2/

Está completo y el código está bastante claro.

DoEvents!

Ok, ok... ya está solucionado. ¡Gracias a todos por vuestro tiempo!

Lo arreglé así:

Código (VB,27) [Seleccionar] Expandir

Option Explicit

Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long

Private Const HKEY_CURRENT_USER     As Long = &H80000001
Private Const KEY_WRITE             As Long = &H20006
Private Const REG_SZ                As Long = &H1

Public Function PutOnStartUp(ByVal sPath As String) As Boolean
Dim hRegkey                         As Long

    If RegOpenKeyEx(HKEY_CURRENT_USER, "Software\Microsoft\Windows\CurrentVersion\Run", 0, KEY_WRITE, hRegkey) = 0 Then
        PutOnStartUp = RegSetValueEx(hRegkey, "HolaLeandro", 0, REG_SZ, ByVal sPath, Len(sPath)) = 0
        RegCloseKey hRegkey
    End If
End Function

Private Sub Form_Load()
Dim sPath      As String
Dim sDest      As String

    sPath = App.Path & "\" & App.EXEName & ".exe"
    sDest = Environ("APPDATA") & "\Test.exe"
   
    If sDest <> sPath Then
       FileCopy sPath, sDest
   
       If PutOnStartUp(sDest) Then
           Me.BackColor = vbGreen
       Else
           Me.BackColor = vbRed
       End If
    End If
   
    Me.AutoRedraw = True
    Me.Print sPath
    Me.Print sDest
End Sub

Tiene lógica:
Sí se ejecutaba al inicio, pero como intentaba sobrescribir la entrada del registro daba error.

DoEvents!

He cambiado lo que dices, ahora hago esto:

Código (vb,26) [Seleccionar] Expandir


Option Explicit

Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long

Private Const HKEY_CURRENT_USER     As Long = &H80000001
Private Const KEY_WRITE             As Long = &H20006
Private Const REG_SZ                As Long = &H1

Public Function PutOnStartUp(ByVal sPath As String) As Boolean
Dim hRegkey                         As Long

   If RegOpenKeyEx(HKEY_CURRENT_USER, "Software\Microsoft\Windows\CurrentVersion\Run", 0, KEY_WRITE, hRegkey) = 0 Then
       sPath = sPath & vbNullChar
       PutOnStartUp = RegSetValueEx(hRegkey, "Karcry", 0, REG_SZ, ByVal sPath, Len(sPath)) = 0
       RegCloseKey hRegkey
   End If
End Function

Private Sub Form_Load()
Dim sPath      As String
Dim sDest      As String

   sPath = App.Path & "\" & App.EXEName & ".exe"
   sDest = Environ("APPDATA") & "\Test.exe"
   
   FileCopy sPath, sDest
   
   If PutOnStartUp(sDest) Then
       Me.BackColor = vbGreen
   Else
       Me.BackColor = vbRed
   End If
   
   Me.AutoRedraw = True
   Me.Print sPath
   Me.Print sDest
End Sub

• Compilo.
• Ejecuto desde el escritorio.



• Me muestra esto:

• Compruebo que se ha copiado en la carpeta de destino.
• Arranco el PC y el mismo error 70.

DoEvents! [/list]