'// Projeye List1 adında bir adet listbox ekleyin ve scrrun.dll dosyasına bir referans ekleyin
Private Declare Function GetProfilesDirectory Lib "userenv.dll" Alias "GetProfilesDirectoryA" (ByVal lpProfileDir As String, lpcchSize As Long) As Boolean
Private objFSO As FileSystemObject
Private objFolders As Folders, objFolder As Folder

Private Sub Form_Load()
    Dim sBuffer As String
    Dim strPARENT As String
    
    sBuffer = String(255, 0)
    GetProfilesDirectory sBuffer, 255
    
    strPARENT = StripTerminator(sBuffer)
    Set objFSO = New FileSystemObject
    
    'if path is invalid, exit
    If Not objFSO.FolderExists(strPARENT) Then Exit Sub
 
    ' "seed" the loop
    strPaths = IIf(Right(strPARENT, 1) = "\", strPARENT, strPARENT & "\")

    ' Add subfolders, if any, to array
    Set objFolders = objFSO.GetFolder(strPaths).SubFolders
    For Each objFolder In objFolders
        List1.AddItem objFolder.Name
    Next
    
    Set objFSO = Nothing
    Set objFolders = Nothing
    Set objFolder = Nothing

End Sub

Function StripTerminator(sInput As String) As String
    Dim ZeroPos As Long
    ZeroPos = InStr(1, sInput, Chr$(0))
    If ZeroPos > 0 Then
        StripTerminator = Left$(sInput, ZeroPos - 1)
    Else
        StripTerminator = sInput
    End If
End Function