Hallo Specialisten,
Ik heb een macro geschreven om text en afbeeldingen in een Word document in te voegen. Volgens mij is het in de macro duidelijk omschreven dat afbeelding en text, "0,1,2 en 3" op pagina 1 moeten komen en "4,5,6 en 7" op de volgende.
Bij de text werkt dit wel maar bij de afbeelding niet, de eerste 4 afbeelding worden netjes op pagina 1 geplaatst, de volgende afbeeldingen staan over pagina 1 verspreid.
Iemand een idee wat ik verkeerd heb gedaan in de onderstaande Macro?
Alvast bedankt voor de moeite:
Ik heb een macro geschreven om text en afbeeldingen in een Word document in te voegen. Volgens mij is het in de macro duidelijk omschreven dat afbeelding en text, "0,1,2 en 3" op pagina 1 moeten komen en "4,5,6 en 7" op de volgende.
Bij de text werkt dit wel maar bij de afbeelding niet, de eerste 4 afbeelding worden netjes op pagina 1 geplaatst, de volgende afbeeldingen staan over pagina 1 verspreid.
Iemand een idee wat ik verkeerd heb gedaan in de onderstaande Macro?
Alvast bedankt voor de moeite:
HTML:
Sub convertFormat()
'Hieronder staan alle belangrijke gegevens die gewijzigd kunnen / mogen worden
'Het betreft vooral verwijzingen en basis instellingen
'### Standaard bestandslocatie: waar staat het bestand om in te lezen ###
'### Dit is het bestand wat wordt aangeleverd door Qvision en MOET worden ###
'### hernoemd (Qvision levert een bestand met datum als bestandsnaam ###
'origineleMap = "C:\Users\Bart.digicore-europe\Documents\wsz\"
'origineelBestand = "Advertentiebasis.doc"
maxAantalRegels = 23
paginaHoogte = 500
'imgAchtergrondWoningaanbod = "macro_AG_woningaanbod.jpg"
'imgAchtergrondSpelregels = "macro_AG_spelregels.jpg"
'### Alles hieronder afblijven als je niet bekend bent Visual Basic!!! ###
'### Hieronder begint de echter programmering en wijzigingen kunnen ###
'### onverwachter gevolgen hebben! ###
'###
'### Het eerste deel is het nodige rekenwerk om de gegevens in te lezen
'###
'###
'### Maak alle benodigde variabelen aan
'###
On Error GoTo iets_error
Dim d As FileDialog
Dim arrFileLines()
Dim arrBeginRegels()
Dim VHE()
Dim indexPand
Dim indexItem
Dim indexTotaal
I = 0
l = 0
k = 0
aantalpanden = 0
aantalItems = 0
teller = 0
maxLength = 0
restEmpty = 0
'###
'### Open het originele Word Document en sla het op als platte tekst
'### Dit is erg irritant en omslachtig, maar vooralsnog kan ik niks met het originele document
'###
Set d = Application.FileDialog(msoFileDialogOpen)
d.Title = "Open bestand Woningaanbod"
If d.Show Then
origineelBestand = d.SelectedItems(1)
End If
txtFile = Left(origineelBestand, Len(origineelBestand) - 3) & "txt"
origineleMap = FolderFromFileName(origineelBestand)
MsgBox txtFile
MsgBox origineleMap
Set wdApp = CreateObject("Word.Application")
Set wdDoc = Nothing
If CheckPath(origineelBestand) = False Then
Set wdApp = Nothing
wdApp.Application.Quit
Else
Set wdDoc = wdApp.Documents.Open(origineelBestand)
End If
wdDoc.Range.Tables(1).ConvertToText Separator:=" - "
wdDoc.SaveAs (txtFile), 4
wdDoc.Close
Set wdDoc = Nothing
'###
'### Open het nieuw gemaakte tijdelijke platte tekst bestand
'###
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile(txtFile, 1)
'###
'### Lees alle regels uit het bestand naar een array in het geheugen
'###
Do Until objFile.AtEndOfStream
ReDim Preserve arrFileLines(I)
TempStr = Replace(objFile.ReadLine, "?", "€")
TempStr2 = Replace(TempStr, vbTab, " ")
TempStr = Replace(TempStr2, Chr(13), " ")
Do While (InStr(TempStr, " "))
' if true, the string still contains double spaces,
' replace with single space
TempStr = Replace(TempStr, " ", " ")
Loop
arrFileLines(I) = TempStr
I = I + 1
Loop
'###
'### Tel het aantal unieke panden
'###
For l = 0 To UBound(arrFileLines)
If IsVHEnummer(arrFileLines(l)) = True Then
ReDim Preserve arrBeginRegels(k)
arrBeginRegels(k) = l
k = k + 1
aantalpanden = aantalpanden + 1
End If
Next
'het aantalpanden bevat nu ook de verhuurresultaten, even weghalen
'aantalpanden = aantalpanden - 1
'###
'### Maak een array met regelnummers waar de unieke VHEnummers staan
'###
For l = 0 To aantalpanden - 1
If l = aantalpanden - 1 Then
maxLength = arrBeginRegels(l) - arrBeginRegels(l - 1)
Else
If (arrBeginRegels(l + 1) - arrBeginRegels(l)) > maxLength Then maxLength = arrBeginRegels(l + 1) - arrBeginRegels(l)
End If
Next
'###
'### Pas grootte VHE array aan aan de ingelezen gegevens
'### Vul het 2-dimensionele array VHE met de ingelezen gegevens.
'### VHE() bevat nu alle regels per pand
'###
ReDim VHE(aantalpanden, maxLength)
For indexPand = 0 To aantalpanden - 1
For indexItem = 0 To maxLength - 1
indexTotaal = arrBeginRegels(indexPand) + indexItem
If indexItem = 0 Then
If IsVHEnummer(arrFileLines(indexTotaal)) = True Then
VHE(indexPand, indexItem) = arrFileLines(indexTotaal)
restEmpty = 0
Else
'index 0 en GEEn vhe nummer, dus probleem...? of verhuurrresultaten
End If
Else
If restEmpty = 1 Then
VHE(indexPand, indexItem) = ""
Else
If IsVHEnummer(arrFileLines(indexTotaal)) = True Then
VHE(indexPand, indexItem) = ""
restEmpty = 1
Else
VHE(indexPand, indexItem) = arrFileLines(indexTotaal)
End If
End If
End If
Next
Next
'###
'### Plaatsen van tekstblokken in layout
'###
Selection.GoTo What:=wdGoToBookmark, Name:="Woningaanbod"
Selection.Text = ""
For indexPand = 0 To aantalpanden - 1
'For indexItem = 0 To maxLength - 1
For indexItem = 1 To maxAantalRegels
If indexItem >= maxLength Then
Selection.InsertAfter "" & Chr(13)
Else
Selection.InsertAfter VHE(indexPand, indexItem) & Chr(13)
End If
Next
Next
ActiveDocument.Bookmarks.Add Range:=Selection.Range, Name:="Woningaanbod"
'###
'### Bepaal het aantal pagina's en geef alle pagina's een aparte tekst als voettekst
'### Laatste pagina: disclaimer en contactgegevens
'### laatste pagina woningaanbod: verhuurresultaten
'### Alle eerdere pagina's: leeg
'###
Dim CurrentPage As Integer
NumPages = ActiveDocument.ActiveWindow.Panes(1).Pages.Count
For CurrentPage = 1 To NumPages
Select Case CurrentPage
Case NumPages
'Disclaimer
Case NumPages - 1
'Verhuurresultaten
Case Else
'Niks
End Select
Next CurrentPage
'###
'### Plaatsen VHE foto's bij advertenties
'###
Dim imgFileName As String
Dim paginaOffSet As Integer
For indexPand = 0 To aantalpanden - 1
imgFileName = origineleMap & Trim(VHE(indexPand, 0)) & "_FT_VG.jpg"
Select Case indexPand
Case 0, 1, 2, 3
'Eerste pagina
paginaOffSet = 0
Case 4, 5, 6, 7
'Tweede pagina
paginaOffSet = 1
Case 8, 9, 10, 11
'Derde pagina
paginaOffSet = 2
End Select
'Bepaal hoogte om image te plaatsen
If indexPand Mod 2 = 1 Then
'oneven getal, onder plaatsen
heightPos = 260 + (paginaOffSet * paginaHoogte)
Else
'even getal, boven plaatsen
heightPos = 0 + (paginaOffSet * paginaHoogte)
End If
Select Case indexPand
Case 0, 1, 4, 5, 8, 9
'links plaatsen
leftPos = 140
Case 2, 3, 6, 7, 10, 11
'rechts plaatsen
leftPos = 385
Case Else
'ja wat gaan we hier doen? nu hebben we meer dan 12 panden!!!!
End Select
If CheckPath(imgFileName) = True Then
ActiveDocument.Shapes.AddPicture FileName:=imgFileName _
, LinkToFile:=False, SaveWithDocument:=True, Left:=leftPos, Top:=heightPos, Width:=80, Height:=60
Else
ActiveDocument.Shapes.AddPicture FileName:=origineleMap & "noimg.jpg" _
, LinkToFile:=False, SaveWithDocument:=True, Left:=leftPos, Top:=heightPos, Width:=80, Height:=60
End If
Next
'Te doen: verwijderen tijdelijk bestand
doorgaan:
'Sluit het tekstbestand en geef het geheugen vrij
objFile.Close
Set objFile = Nothing
Set objFSO = Nothing
Set wdDoc = Nothing
Set wdApp = Nothing
Exit Sub
iets_error:
MsgBox Error$
Resume doorgaan
End Sub
