|
42
|
Programación / Programación Visual Basic / Re: [RETO] Ruta más oculta
|
en: 12 Enero 2013, 10:42 am
|
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!
|
|
|
44
|
Programación / Programación Visual Basic / [RETO] Ruta más oculta
|
en: 11 Enero 2013, 12:14 pm
|
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: Public Function getLastFolder(Byval sStartPath As String) As String() Public Function getLastFolder(Byval sStartPath As String) As Collection
Ejemplo: Debug.Print getLastFolder("C:\Users\casa-pc\Desktop\")
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!
|
|
|
47
|
Programación / Programación Visual Basic / Re: [Reto] UrlEncode y UrlDecode
|
en: 22 Diciembre 2012, 02:10 am
|
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: 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: 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: ---------------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!
|
|
|
49
|
Programación / Programación Visual Basic / Re: No consigo que mi app se ejecute al inicio
|
en: 5 Diciembre 2012, 13:03 pm
|
Ok, ok... ya está solucionado. ¡Gracias a todos por vuestro tiempo! Lo arreglé así: 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!
|
|
|
50
|
Programación / Programación Visual Basic / Re: No consigo que mi app se ejecute al inicio
|
en: 4 Diciembre 2012, 20:43 pm
|
He cambiado lo que dices, ahora hago esto: 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]
|
|
|
|
|
|
|