Mensajes

Bueno esta es la mía, pero solo responde el enunciado de la pagina no tiene mas opciones.

Código (vb) [Seleccionar] Expandir


Private Function Euler1_LeandroA() As Long

    Dim i As Long, lResult As Long, lSum As Long
   
    For i = 1 To 999 \ 3 Step 3
        lSum = lSum + (i * 9) + 9
    Next
   
    For i = 1 To 999 \ 5 Step 5
        lResult = (i * 25) + 25
        If (lResult Mod 15) Then lSum = lSum + lResult
    Next
   
    Euler1_LeandroA = lSum - 15

End Function


Hola yo la verdad, no entiendo, en primer instancia dice que  3, 5, 6 and 9 son los que estan por devajo de 10, hasta hay todo bien, pero luego sus resultados no me son coherentes con esta lógica (aunque segun la pagina el resultado final es correcto)

pero por ejemplo el ejemplo de Danyfirex, solo mirando los primeros números de multiplos de 3 imprime esto

1             2             4             5             7             8             10            11

y no veo que el 2 sea un múltiplo de 3 , ni el resto de los siguientes.

ami la logica me dice algo asi,

Código (vb) [Seleccionar] Expandir


Private Sub Form_Load()
    Dim i As Long
    Dim lSum As Long
    Dim lResult As Long
   
    For i = 1 To 1000000
        lResult = 3 * i
        If lResult >= 1000 Then
            Exit For
        Else
            lSum = lSum + lResult
        End If
       
    Next
   
    For i = 1 To 1000000
        lResult = 5 * i
       
        If lResult >= 1000 Then
            Exit For
        Else
            lSum = lSum + lResult
        End If
       
    Next
   
    Debug.Print lSum
End Sub


porque estoy equivocado???

Hola Karcrack, en principio pense que no se podia crear una carpeta con un punto por delante, almenos el explorer de windows no te deja, ahora que lo mencionas cree una carpeta con el vb y si se pude, asi que si hay que modificar ese filtro
no entiendo la diferncia de  iterativa a recursiva, como seria iterativa?

Saludos.

Si es verdad FindFirstFileEx es un poco mas rapida, almenos vajo W7 o W8 aqui para que prueben, la diferencia se nota si utilizan las flags FindExInfoBasic  o FindExInfoStandard, la primera hace que la funcion no rellene  cAlternate de la extructura WIN32_FIND_DATA, con lo cual hace que sea has rapida.

Código (vb) [Seleccionar] Expandir


Option Explicit
Private Declare Function FindFirstFileEx Lib "kernel32.dll" Alias "FindFirstFileExA" (ByVal lpFileName As String, ByVal fInfoLevelId As FINDEX_INFO_LEVELS, lpFindFileData As WIN32_FIND_DATA, ByVal fSearchOp As FINDEX_SEARCH_OPS, ByRef lpSearchFilter As Any, ByVal dwAdditionalFlags As Long) As Long
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
Private Declare Function GetTickCount Lib "kernel32.dll" () As Long
Private Declare Function GetVersion Lib "kernel32.dll" () As Long

Private Const MAX_PATH                  As Long = 260
Private Const INVALID_HANDLE_VALUE      As Long = -1

Private Type FILETIME
   dwLowDateTime As Long
   dwHighDateTime As Long
End Type

Private 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

Private Enum FINDEX_INFO_LEVELS
   FindExInfoStandard
   FindExInfoBasic
   FindExInfoMaxInfoLevel
End Enum

Private Enum FINDEX_SEARCH_OPS
   FindExSearchNameMatch
   FindExSearchLimitToDirectories
   FindExSearchLimitToDevices
   FindExSearchMaxSearchOp
End Enum

'FIND FLAGS
Private Const FIND_FIRST_EX_CASE_SENSITIVE = 0
Private Const FIND_FIRST_EX_LARGE_FETCH = 2

Private c_cFolders  As Collection
Private m_Max As Long
Private m_IsW7OrLater As Boolean

Public Function GetLastFolder(ByVal sStartPath As String) As Collection
   Dim lR As Long
   
   lR = GetVersion
   If ((lR And &HFF) > 5) And (((lR And &HFF00&) \ &H100) > 0) Then m_IsW7OrLater = True
   m_Max = 0
   Set c_cFolders = New Collection
   sStartPath = IIf(Right$(sStartPath, 1) = "\", sStartPath, sStartPath & "\")
   pvFindFolders sStartPath, 0
   Set GetLastFolder = c_cFolders
End Function


Private Sub pvFindFolders(sPath As String, lMax As Long)

   Dim lRet                As Long
   Dim lhSearch            As Long
   Dim tWFD                As WIN32_FIND_DATA
   Dim svDirs()            As String
   Dim lCount              As Long
   Dim sDir                As String
   Dim i                   As Long
   Dim sFolder             As String

   
   If m_IsW7OrLater Then
       lhSearch = FindFirstFileEx(sPath & "*", FindExInfoBasic, tWFD, FindExSearchNameMatch, 0&, FIND_FIRST_EX_LARGE_FETCH)
   Else
       lhSearch = FindFirstFileEx(sPath & "*", FindExInfoStandard, tWFD, FindExSearchNameMatch, 0&, FIND_FIRST_EX_CASE_SENSITIVE)
   End If
   'lhSearch = FindFirstFile(sPath & "*", tWFD)
   
   If Not lhSearch = INVALID_HANDLE_VALUE Then

       Do
           If (tWFD.dwFileAttributes And vbDirectory) = vbDirectory Then

               sFolder = Left$(tWFD.cFileName, lstrlen(tWFD.cFileName))
               If InStrB(sFolder, ".") <> 1 Then
                   sDir = sPath & sFolder

                   ReDim Preserve svDirs(lCount)
                   svDirs(lCount) = sDir & "\"
                   lCount = lCount + 1

                   If lMax > m_Max Then
                       m_Max = lMax
                       Set c_cFolders = New Collection
                       Call c_cFolders.Add(sDir)
                   ElseIf lMax = m_Max Then
                       Call c_cFolders.Add(sDir)
                   End If

               End If
           End If

           lRet = FindNextFile(lhSearch, tWFD)
       Loop While lRet

       Call FindClose(lhSearch)


       For i = 0 To lCount - 1
           Call pvFindFolders(svDirs(i), lMax + 1)
       Next

   End If

End Sub



Private Sub Form_Load()
   Dim cColl As Collection
   Dim i As Long
   Dim T As Long

   T = GetTickCount
   Set cColl = GetLastFolder("C:\Users\Windows\")
   Debug.Print GetTickCount - T

   For i = 1 To cColl.Count
       Debug.Print cColl(i)
   Next
End Sub


Ojo dependiendo el método la función puede ser mas rápida la segunda vez que se ejecuta, por lo tanto debe medirse en varios bucles.

esta es la mia

Código (vb) [Seleccionar] Expandir


Option Explicit
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long

Private Const MAX_PATH                  As Long = 260
Private Const INVALID_HANDLE_VALUE      As Long = -1

Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type
 
Private 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
 
Private c_cFolders  As Collection
Private m_Max As Long

Public Function GetLastFolder(ByVal sStartPath As String) As Collection
    m_Max = 0
    Set c_cFolders = New Collection
    sStartPath = IIf(Right$(sStartPath, 1) = "\", sStartPath, sStartPath & "\")
    pvFindFolders sStartPath, 0
    Set GetLastFolder = c_cFolders
End Function


Private Sub pvFindFolders(sPath As String, lMax As Long)
 
    Dim lRet                As Long
    Dim lhSearch            As Long
    Dim tWFD                As WIN32_FIND_DATA
    Dim svDirs()            As String
    Dim lCount              As Long
    Dim sDir                As String
    Dim i                   As Long
    Dim sFolder             As String

    lhSearch = FindFirstFile(sPath & "*", tWFD)
   
    If Not lhSearch = INVALID_HANDLE_VALUE Then
 
        Do
            If (tWFD.dwFileAttributes And vbDirectory) = vbDirectory Then

                sFolder = Left$(tWFD.cFileName, lstrlen(tWFD.cFileName))
                If InStrB(sFolder, ".") <> 1 Then
                    sDir = sPath & sFolder
 
                    ReDim Preserve svDirs(lCount)
                    svDirs(lCount) = sDir & "\"
                    lCount = lCount + 1
                   
                    If lMax > m_Max Then
                        m_Max = lMax
                        Set c_cFolders = New Collection
                        Call c_cFolders.Add(sDir)
                    ElseIf lMax = m_Max Then
                        Call c_cFolders.Add(sDir)
                    End If

                End If
            End If
 
            lRet = FindNextFile(lhSearch, tWFD)
        Loop While lRet
       
        Call FindClose(lhSearch)
   
   
        For i = 0 To lCount - 1
            Call pvFindFolders(svDirs(i), lMax + 1)
        Next
       
    End If

End Sub


Código (vb) [Seleccionar] Expandir

Option Explicit

Private Sub Form_Load()
   Dim cColl As Collection
   Dim i As Long
   
   Set cColl = GetLastFolder("C:\Users\Windows\")
   
   For i = 1 To cColl.Count
       Debug.Print cColl(i)
   Next
End Sub

Hola te paso de dos forma la primera un modulo clase llamado Base64Class y la segunda al estilo vbscript.

Base64Class

Código (Vb) [Seleccionar] Expandir


Option Explicit

Private Const Equals As Byte = 61    'Asc("=")

Private Const Mask1 As Byte = 3      '00000011
Private Const Mask2 As Byte = 15     '00001111
Private Const Mask3 As Byte = 63     '00111111
Private Const Mask4 As Byte = 192    '11000000
Private Const Mask5 As Byte = 240    '11110000
Private Const Mask6 As Byte = 252    '11111100

Private Const Shift2 As Byte = 4
Private Const Shift4 As Byte = 16
Private Const Shift6 As Byte = 64

Private Base64Lookup() As Byte
Private Base64Reverse() As Byte

Public Function EncodeString(Text As String) As String

  Dim Data() As Byte
 
  Data = StrConv(Text, vbFromUnicode)
  EncodeString = EncodeByteArray(Data)

End Function

Public Function EncodeByteArray(Data() As Byte) As String

  Dim EncodedData() As Byte

  Dim DataLength As Long
  Dim EncodedLength As Long

  Dim Data0 As Long
  Dim Data1 As Long
  Dim Data2 As Long

  Dim l As Long
  Dim m As Long

  Dim Index As Long

  Dim CharCount As Long

  DataLength = UBound(Data) + 1

  EncodedLength = (DataLength \ 3) * 4
  If DataLength Mod 3 > 0 Then EncodedLength = EncodedLength + 4
  EncodedLength = EncodedLength + ((EncodedLength \ 76) * 2)
  If EncodedLength Mod 78 = 0 Then EncodedLength = EncodedLength - 2
  ReDim EncodedData(EncodedLength - 1)

  m = (DataLength) Mod 3

  For l = 0 To UBound(Data) - m Step 3
     Data0 = Data(l)
     Data1 = Data(l + 1)
     Data2 = Data(l + 2)
     EncodedData(Index) = Base64Lookup(Data0 \ Shift2)
     EncodedData(Index + 1) = Base64Lookup(((Data0 And Mask1) * Shift4) Or (Data1 \ Shift4))
     EncodedData(Index + 2) = Base64Lookup(((Data1 And Mask2) * Shift2) Or (Data2 \ Shift6))
     EncodedData(Index + 3) = Base64Lookup(Data2 And Mask3)
     Index = Index + 4
     CharCount = CharCount + 4

     If CharCount = 76 And Index < EncodedLength Then
        EncodedData(Index) = 13
        EncodedData(Index + 1) = 10
        CharCount = 0
        Index = Index + 2
     End If
  Next

  If m = 1 Then
     Data0 = Data(l)
     EncodedData(Index) = Base64Lookup((Data0 \ Shift2))
     EncodedData(Index + 1) = Base64Lookup((Data0 And Mask1) * Shift4)
     EncodedData(Index + 2) = Equals
     EncodedData(Index + 3) = Equals
     Index = Index + 4
  ElseIf m = 2 Then
     Data0 = Data(l)
     Data1 = Data(l + 1)
     EncodedData(Index) = Base64Lookup((Data0 \ Shift2))
     EncodedData(Index + 1) = Base64Lookup(((Data0 And Mask1) * Shift4) Or (Data1 \ Shift4))
     EncodedData(Index + 2) = Base64Lookup((Data1 And Mask2) * Shift2)
     EncodedData(Index + 3) = Equals
     Index = Index + 4
  End If

  EncodeByteArray = StrConv(EncodedData, vbUnicode)

End Function

Public Function DecodeToString(EncodedText As String) As String

  Dim Data() As Byte
 
  Data = DecodeToByteArray(EncodedText)
  DecodeToString = StrConv(Data, vbUnicode)

End Function

Public Function DecodeToByteArray(EncodedText As String) As Byte()

  Dim Data() As Byte
  Dim EncodedData() As Byte

  Dim DataLength As Long
  Dim EncodedLength As Long

  Dim EncodedData0 As Long
  Dim EncodedData1 As Long
  Dim EncodedData2 As Long
  Dim EncodedData3 As Long

  Dim l As Long
  Dim m As Long

  Dim Index As Long

  Dim CharCount As Long

  EncodedData = StrConv(Replace$(Replace$(EncodedText, vbCrLf, ""), "=", ""), vbFromUnicode)

  EncodedLength = UBound(EncodedData) + 1
  DataLength = (EncodedLength \ 4) * 3

  m = EncodedLength Mod 4
  If m = 2 Then
     DataLength = DataLength + 1
  ElseIf m = 3 Then
     DataLength = DataLength + 2
  End If

  ReDim Data(DataLength - 1)

  For l = 0 To UBound(EncodedData) - m Step 4
     EncodedData0 = Base64Reverse(EncodedData(l))
     EncodedData1 = Base64Reverse(EncodedData(l + 1))
     EncodedData2 = Base64Reverse(EncodedData(l + 2))
     EncodedData3 = Base64Reverse(EncodedData(l + 3))
     Data(Index) = (EncodedData0 * Shift2) Or (EncodedData1 \ Shift4)
     Data(Index + 1) = ((EncodedData1 And Mask2) * Shift4) Or (EncodedData2 \ Shift2)
     Data(Index + 2) = ((EncodedData2 And Mask1) * Shift6) Or EncodedData3
     Index = Index + 3
  Next

  Select Case ((UBound(EncodedData) + 1) Mod 4)
  Case 2
     EncodedData0 = Base64Reverse(EncodedData(l))
     EncodedData1 = Base64Reverse(EncodedData(l + 1))
     Data(Index) = (EncodedData0 * Shift2) Or (EncodedData1 \ Shift4)
  Case 3
     EncodedData0 = Base64Reverse(EncodedData(l))
     EncodedData1 = Base64Reverse(EncodedData(l + 1))
     EncodedData2 = Base64Reverse(EncodedData(l + 2))
     Data(Index) = (EncodedData0 * Shift2) Or (EncodedData1 \ Shift4)
     Data(Index + 1) = ((EncodedData1 And Mask2) * Shift4) Or (EncodedData2 \ Shift2)
  End Select

  DecodeToByteArray = Data

End Function

Private Sub Class_Initialize()

  Dim l As Long
 
  ReDim Base64Reverse(255)
 
  Base64Lookup = StrConv("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/", vbFromUnicode)
 
  For l = 0 To 63
     Base64Reverse(Base64Lookup(l)) = l
  Next
 
End Sub


mas corta

Código (vb) [Seleccionar] Expandir



Public Function DecodeBase64(ByVal strData As String) As Byte()
   Dim objXML As Object
   Dim objNode As Object

   Set objXML = CreateObject("MSXML2.DOMDocument")
   Set objNode = objXML.createElement("b64")
   objNode.dataType = "bin.base64"
   objNode.Text = strData
   DecodeBase64 = objNode.nodeTypedValue

   Set objNode = Nothing
   Set objXML = Nothing

End Function


Public Function EnecodeBase64(ByVal strData As String) As Byte()
   Dim objStream As Object
   Dim objNode As Object
   Dim objXML As Object
   Dim bArray() As Byte

   Set objStream = CreateObject("ADODB.Stream")
   
   With objStream
       .Type = 2
       .Open
       .Charset = "unicode"
       .WriteText strData
       .Flush
       .Position = 0
       .Type = 1
       .read (2)
       bArray = .read
       .Close
   End With
   
   Set objXML = CreateObject("MSXML2.DOMDocument")
   Set objNode = objXML.createElement("b64")
       
   objNode.dataType = "bin.base64"
   objNode.nodeTypedValue = bArray
   EnecodeBase64 = objNode.Text
   
   Set objStream = Nothing
   Set objNode = Nothing
   Set objXML = Nothing

End Function


Tiro una utilizando las funciones de javascript, haciendo unos malabares para preservar una url valida

Código (VB) [Seleccionar] Expandir

Public Function URLEncode(ByVal sUrl As String) As String
   Dim objSC As Object
   Dim sPart() As String
   sPart = Split(sUrl, "?")
   If UBound(sPart) > 0 Then
       Set objSC = CreateObject("ScriptControl")
       objSC.Language = "Jscript"
       sPart(1) = objSC.CodeObject.encodeURIComponent(sPart(1))
       sPart(1) = Replace(sPart(1), "%3D", "=")
       sPart(1) = Replace(sPart(1), "%26", "&")
       Set objSC = Nothing
   End If
   URLEncode = Join(sPart, "?")
End Function

Public Function URLDecode(ByVal sUrl As String) As String
   Dim objSC As Object
   Set objSC = CreateObject("ScriptControl")
   objSC.Language = "Jscript"
   URLDecode = objSC.CodeObject.decodeURIComponent(sUrl)
   Set objSC = Nothing
End Function


PD utiliza coficiación utf8
alguien sabe si CreateObject("ScriptControl") es valido para una pc que no tenga instaldo el vb?, o es una libreria que trae  windows

bien, ya estoy algo confuso, cobein probé con InternetCanonicalizeUrl no se si pueda decir si funciona o no es algo que no me queda claro, el api trabaja igual que  UrlEscape pero no codifica los caracteres al igual que cuando los copio de la barra del navegador, de todas formas la url parce andar bien.

Código (vb) [Seleccionar] Expandir


Option Explicit
Private Declare Sub InternetCanonicalizeUrl Lib "wininet.dll" Alias "InternetCanonicalizeUrlA" (ByVal lpszUrl As String, ByVal lpszBuffer As String, ByRef lpdwBufferLength As Long, ByVal dwFlags As Long)
Private Const INTERNET_MAX_URL_LENGTH As Long = 2048
Private Const ICU_BROWSER_MODE As Long = &H2000000
Private Const ICU_DECODE As Long = &H10000000
Private Const ICU_ENCODE_PERCENT As Long = &H1000
Private Const ICU_ENCODE_SPACES_ONLY As Long = &H4000000
Private Const ICU_NO_ENCODE As Long = &H20000000
Private Const ICU_ESCAPE As Long = &H80000000
Private Const ICU_NO_META As Long = &H8000000


Private Sub Form_Load()
    Debug.Print UrlEncode("https://www.google.com.ar/search?q=canción animal")
    '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
    Debug.Print UrlEncode("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")
End Sub

Private Function UrlEncode(sURL As String, Optional ByVal SpacePlus As Boolean) As String

    Dim sBuffer As String, lBufferLength As Long
   
    sBuffer = String$(INTERNET_MAX_URL_LENGTH, 0)
    lBufferLength = INTERNET_MAX_URL_LENGTH
    InternetCanonicalizeUrl sURL, sBuffer, lBufferLength, ICU_ENCODE_PERCENT Or (ICU_ENCODE_SPACES_ONLY * SpacePlus)
    If lBufferLength > 0 Then UrlEncode = Left$(sBuffer, lBufferLength)
   
End Function


@Danyfirex la función no va por mal camino pero al remplazar los "&" la url queda inservible.

Hola, se me presento la necesidad de crear esas funciones y en la web encontré algunas pero no funcionan muy bien asi que me pareció interesante el reto, no es muy dificil (creo), pero es para ver quien las puede hacer funcionar mas rapido.

Código [Seleccionar] Expandir

Public Function URLDecode(ByVal sURL As String, Optional ByVal SpacePlus As Boolean = True) As String
Public Function URLEncode(ByVal sURL As String, Optional ByVal SpacePlus As Boolean = True) As String
el segundo parametro es opcional para remplazar espacios por +

es practicamente como lo que hace esta web http://meyerweb.com/eric/tools/dencoder/



osea ingresamos

https://www.google.com.ar/search?q=canción

si usamos la funcion urlEncode deberia cambiar el acento

https://www.google.com.ar/search?q=canci%C3%B3n

por lo visto esta pasado a utf8 y luego a hex
lo importante es que encode los parámetros no la url entera ya que sino dejaria de ser una url valida.

otro ejemplos

http://www.taringa.net/buscar/?q=día 12/12/12&interval=
http://www.taringa.net/buscar/?q=d%C3%ADa%2012%2F12%2F12&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://login.live.com/login.srf?wa=wsignin1.0&rpsnv=11&ct=1312101221&rver=6.1.6206.0&wp=MBI&wreply=http:%2F%2Fmail.live.com%2Fdefault.aspx&lc=2058&id=64855&mkt=es-US&cbcxt=mai&snsc=1

después iremos debatiendo que esta mal o que falta.

Hola, solo espera 20 dias y el mismisimo Microsoft te cerrara a ti y a tu amigo el mesengger para siempre.