KlaasjanBoven
Gebruiker
- Lid geworden
- 6 dec 2011
- Berichten
- 6
Hoi
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?
Met php kom ik een heel end maar met vb dus (nog) niet
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?
Code:
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
.
