Array koppelen aan een formulier

[KlaasjanBoven]

Hoi ik had het eerst in de verkeerde subcategorie geplaatst dus nu opnieuw:

Ik wil graag met de onderstaande code vanuit Word alle bestanden uit een map halen en deze tonen in een formulier met per bestandsnaam een knopje waar en onclick ofzo aan komt. Ik krijg alleen het koppelen van de bestandsnamen aan een array en daarna aan een formulier niet voor elkaar
Iemand een idee?

Sub maaklad()

' hier moeten de bestanden in
bestanden = Array()
' nog een array
blad = Array()
'exensies die de macro moet laten zien
meegenomen = Array("doc", "docx", "pdf", "txt", "html", "htm", "odf")
'maand
maand_is = Month(Now)
'jaar
jaar_is = Year(Now)

If maand_is = 12 Then
    Maand_Wordt = 1
Else
    Maand_Wordt = maand_is + 1
End If


If Maand_Wordt <> 1 Then
    jaar_wordt = jaar_is
Else
    jaar_wordt = jaar_is + 1
End If

'vul de datum
datum = MonthName(Maand_Wordt) & " " & jaar_wordt
ActiveDocument.Bookmarks("maand_jaar").Select
Selection.InsertBefore datum

'vul het nummer
ActiveDocument.Bookmarks("nummer").Select
Selection.InsertBefore "nummer " & maand_is

'vul de jaargang
ActiveDocument.Bookmarks("jaargang").Select
Selection.InsertBefore jaar_wordt - 2004

'vul de volgende inleverdatum
ActiveDocument.Bookmarks("inleverdatum").Select
Selection.InsertBefore datum

' geef een schermpje om de folder te kiezen
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
    .Title = "Kies de folder waar de documenten staan"
    
    If .Show = -1 Then
        strFolder = .SelectedItems(1) & "\"
    Else
        MsgBox "Je het geen map gekozen."
    'we gaan niet verder
    Stop
    End If
End With

' kijken of de map geplaats al bestaat en zo nee aanmaken
If Len(Dir(strFolfder & "\geplaatst")) = 0 Then

  MsgBox "geplaatst bestaat nog niet en wordt nu gemaakt"

On Error Resume Next
    
    'MkDir strFolder & "\geplaatst"

On Error GoTo 0
End If

'teller op nul zetten
i = 1
' bestanden die meegenomen moeten worden definieeren
strDoc = Dir$(strFolder & "*.*")
' tot alle bestanden aan de beurt zijn geweest
Do While strDoc <> ""
    i = i + 1
        
        
    ' bepalen van de punt
    Puntpositie = InStr(strDoc, ".")
    ' bepalen van de lengte min de punt
    Subgedeelte = Len(strDoc) - Puntpositie
    ' extensie bepalen
    extension = Right(strDoc, Subgedeelte)
    
     GetFileList (strFolder)
    
 
    'vergelijken extensie met array
    If IsInArray(extension, meegenomen) Then
        
        If extension = "doc" Or extension = "docx" Or extension = "odf" Or extension = "html" Or extension = "txt" Then
        
            'hier moet de magie gaan plaatsvindn en ik heb al vanalles geprobeerd
            
            Else
        
                MsgBox "het bestand is geen worddocument maar een " & extension
        
            End If
    
        End If

Loop


Set fd = Nothing

End Sub

 
Public Function IsInArray(FindValue As Variant, arrSearch As _
   Variant) As Boolean

    On Error GoTo LocalError
    If Not IsArray(arrSearch) Then Exit Function
    IsInArray = InStr(1, vbNullChar & Join(arrSearch, _
     vbNullChar) & vbNullChar, vbNullChar & FindValue & _
     vbNullChar) > 0

Exit Function
LocalError:
End Function


Function OpenDocument(Document)
       Documents.Open FileName:=Document
End Function


Function MaakBoekje(Document)
With ActiveDocument.Styles(wdStyleNormal).Font
        If .NameFarEast = .NameAscii Then
            .NameAscii = ""
        End If
        .NameFarEast = ""
    End With
    End Function

Function GetFileList(FileSpec As String) As Variant
'   Returns an array of filenames that match FileSpec
'   If no matching files are found, it returns False

    Dim FileArray() As Variant
    Dim FileCount As Integer
    Dim FileName As String
    
    On Error GoTo NoFilesFound

    FileCount = 0
    FileName = Dir(FileSpec)
    If FileName = "" Then GoTo NoFilesFound
    
'   Loop until no more matching files are found
    Do While FileName <> ""
        FileCount = FileCount + 1
        ReDim Preserve FileArray(1 To FileCount)
        FileArray(FileCount) = FileName
        FileName = Dir()
    Loop
    GetFileList = FileArray
    Exit Function

'   Error handler
NoFilesFound:
    GetFileList = False
End Function

 

[Tilly1987]

Dit zou de bestandtypen in een array moeten laden

Hallo KlaasjanBoven,

Ik heb niet geheel jouw'n code geevalueerd. Ik heb slechts gekeken of ik een array kon laden aan de hand van een opgegeven folder, waarbij het array gevuld zou worden met alle bestandsnamen (+pad naam) van een opgegeven bestandstype (Filter). Deze Array heb ik daarna in een Listbox op het Userform gepompt, maar dat kan natuurlijk op allerlei manieren gebruikt worden.

Hopelijk kun je hier wat mee.

Met vriendelijke groet,

Tilly

Een paar voorgekauwde bijlagen , voor gebruiksgemak.
(bijlage beheer werkt weer eens niet voor mij, dus dan maar via een uploadsite)
http://hotfile.com/dl/137101033/109cfcc/LoadArrayToForm.rar.html

Voorbeeld van de code:
Plaats in een module:
LET OP:
In Word dient gecheckt te worden op (myFile.Name <> ThisDocument.Name)
In Excel dient gecheckt te worden op (myFile.Name <> ThisWorkbook.Name)

Public Function SearchFiles2(myDir As String, _
                             myFileName As String, _
                             n As Long, _
                             ByRef myList()) As Variant

    Dim fso As Object, myFolder As Object, myFile As Object
    Dim Extension As String
    Set fso = CreateObject("Scripting.FileSystemObject")
    For Each myFile In fso.getfolder(myDir).Files
        Extension = Mid(myFile.Name, InStrRev(myFile.Name, "."))
        If (Not myFile.Name Like "~$*") * _
            [COLOR="red"](myFile.Name <> ThisWorkbook.Name)[/COLOR] * _
             (InStr(1, myFileName, Extension, vbTextCompare)) Then
            n = n + 1
            ReDim Preserve myList(1 To n)
            myList(n) = myDir & "\" & myFile.Name
        End If
    Next
    For Each myFolder In fso.getfolder(myDir).subfolders
        SearchFiles2 = SearchFiles2(myFolder.Path, myFileName, n, myList)
    Next
    SearchFiles2 = IIf(n > 0, myList, "")
End Function

In een Userform, waarbij een Listbox, een cmbOK & cmbCancel (commandbuttons) aanwezig zijn.

Private Sub cmbCancel_Click()
Me.Hide
End Sub

Private Sub cmbOpen_Click()
If Not Me.ListBox1.Value = "" Then
    MsgBox "Open " & Me.ListBox1.Value & vbCrLf & vbCrLf & _
            "Hier moet dan code komen om het bestand op te halen." & vbCrLf & _
            "Echter geen zin om het te schrijven :P." & vbCrLf & _
            "Gezien je rekening moet houden met alle mogelijke bestandstypen." & vbCrLf & _
            "Succes!"
End If
End Sub

Private Sub UserForm_Initialize()
Dim Filter As String
Dim myDir As String, myList()

With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show = True Then
        myDir = .SelectedItems(1)
    End If
End With

On Error Resume Next
Filter = "*.xls, *.txt, *.pdf"
Me.Caption = "Toon alle files die voldoen aan de filter:= " & Filter
myList = SearchFiles2(myDir, Filter, 0, myList())

If Err = 0 Then
    For i = LBound(myList) To UBound(myList)
        Me.ListBox1.AddItem myList(i)
    Next i
Else
    MsgBox "No files found"
End If
On Error GoTo 0

End Sub

 

[KlaasjanBoven]

Hoi Tilly super bedankt
Ik ben nu bezig met een switch voor de verschillende bestandstype