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

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

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,

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.

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

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
 

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

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

 
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

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.

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.

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

si usamos la funcion urlEncode deberia cambiar el acento
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


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.