Hoi allen,
Ik ben bezig met het schrijven van een programma waarbij het volgende wordt uitgevoerd: Op basis van een Excel lijst wordt een template geopend en wordt er een artikelnummer in die template geplakt. Vervolgens worden de templates opgeslagen in een map (op basis van bestelnummer) en moeten de templates aan een zip bestand worden toegevoegd. Als laatste moet het zip bestand naar een e-mailadres worden verstuurd.
Er zijn twee problemen bij het programma dat ik geschreven heb:
1. Niet alle templates worden toegevoegd aan het zip bestand. Ik zie in de map bijvoorbeeld 10 templates staan en in het zip bestand zitten er vervolgens maar 9. Op de een of andere manier wordt het laatste artikelnummer uit de loop overgeslagen bij het toevoegen aan het zip bestand.
2. Als ik het zip bestand wil toevoegen aan de e-mail dan lijkt het alsof dit goed gaat (in de bijlage zie ik een zip bestand met de goede naam), alleen is het bestand leeg. Hij voegt dus geen inhoud aan het zip bestand toe. Hieronder mijn code:
Hopelijk kunnen jullie me helpen, alvast bedankt!
Ik ben bezig met het schrijven van een programma waarbij het volgende wordt uitgevoerd: Op basis van een Excel lijst wordt een template geopend en wordt er een artikelnummer in die template geplakt. Vervolgens worden de templates opgeslagen in een map (op basis van bestelnummer) en moeten de templates aan een zip bestand worden toegevoegd. Als laatste moet het zip bestand naar een e-mailadres worden verstuurd.
Er zijn twee problemen bij het programma dat ik geschreven heb:
1. Niet alle templates worden toegevoegd aan het zip bestand. Ik zie in de map bijvoorbeeld 10 templates staan en in het zip bestand zitten er vervolgens maar 9. Op de een of andere manier wordt het laatste artikelnummer uit de loop overgeslagen bij het toevoegen aan het zip bestand.
2. Als ik het zip bestand wil toevoegen aan de e-mail dan lijkt het alsof dit goed gaat (in de bijlage zie ik een zip bestand met de goede naam), alleen is het bestand leeg. Hij voegt dus geen inhoud aan het zip bestand toe. Hieronder mijn code:
Code:
Sub Rapporten()
Dim Artikelnummer As String
Dim Artikelnummer_def As String
Dim Artikelnummer2 As String
Dim Bestelnummer As String
Dim Bestelnummer_def As String
Dim Crediteurnr As String
Dim Crediteurnaam As String
Dim Mapnaam As String
Dim Mapnaam_def As String
Dim Bestandsnaam As String
Dim Aantal As Integer
Dim Aantal_def As String
Dim Template_Elektra As Workbook
Dim Database_Elektra As Workbook
Dim objOL As Object
Dim Sender As String
Dim StrDate As String
Dim Emailadres As String
Dim Emailadres_def As String
Dim EmStart As String
Dim strDestFileName As String
Dim strSourceFileName As String
Dim str7ZipPath As String
Dim strPassword As String
Dim strCommand As String
Dim Bijlage As String
Dim Counter As Integer
Sender = "bmvnk@hotmail.com"
Set fs = CreateObject("scripting.filesystemobject")
cnt = 0
nr = 0
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Set currentWb = ThisWorkbook
Set Template_Elektra = Workbooks.Open("G:\Quality_Report_Electra.xls", True, True)
Set Database_Elektra = Workbooks.Open("G:\Kwaliteitsdatabase Electra Verre Oosten.xls", True, True)
With currentWb.Worksheets(1)
Counter = 0
Do While currentWb.Worksheets(1).Cells(2 + cnt, 3).Value <> "Einde"
Artikelnummer = currentWb.Worksheets(1).Cells(2 + cnt, 3).Value
If Artikelnummer <> "" Then
'Hier worden de e-mailadressen opgehaald uit de database
Do While Database_Elektra.Worksheets(1).Cells(3 + nr, 2).Value <> ""
Artikelnummer2 = Database_Elektra.Worksheets(1).Cells(3 + nr, 2).Value
Emailadres = Database_Elektra.Worksheets(1).Cells(3 + nr, 8).Value
If Artikelnummer2 = Artikelnummer Then
'Hier wordt het e-mailadres uit de text gefilterd zodat de string alleen het e-mailadres bevat
Emailadres_def = InStr(1, Emailadres, "@")
EmStart = InStrRev(Emailadres, " ", Emailadres_def)
If EmStart = 0 Then EmStart = 1
EmEnd = InStr(Emailadres_def, Emailadres, " ")
If EmEnd = 0 Then EmEnd = Len(Emailadres) + 1
mailid = Trim(Mid(Emailadres, EmStart, EmEnd - EmStart))
If Right(mailid, 1) = "." Then
Getmailid = Left(mailid, Len(mailid) - 1)
Else
Getmailid = mailid
End If
If currentWb.Worksheets(1).Cells(1 + cnt, 1).Value <> "" Then
currentWb.Worksheets(1).Cells(2 + cnt, 7).Value = mailid
End If
nr = 0
Exit Do
Else
End If
nr = nr + 1
Loop
'Hier wordt gecontroleerd of er een artikelnummer in het veld staat of een crediteurnaam. Als er geen punt wordt gevonden is het een crediteurnaam, anders een artikelnummer.
If currentWb.Worksheets(1).Cells(2 + cnt, 3).Value <> "" Then
If InStr(Artikelnummer, ".") = 0 Then
Crediteurnaam = Artikelnummer
Else
Artikelnummer_def = Artikelnummer
End If
Else
Exit Do
End If
'Hier wordt het Crediteur en Bestelnummer opgehaald zodat deze straks kunnen worden gebruikt bij het opslaan van het rapport.
If currentWb.Worksheets(1).Cells(2 + cnt, 1).Value <> "" Then
Crediteurnr = currentWb.Worksheets(1).Cells(2 + cnt, 1).Value
End If
If currentWb.Worksheets(1).Cells(2 + cnt, 2).Value <> "" Then
Bestelnummer = currentWb.Worksheets(1).Cells(2 + cnt, 2).Value
End If
'Daarna worden de controle aantallen in kolom C gezet
Aantal = currentWb.Worksheets(1).Cells(2 + cnt, 4).Value
Aantal = Replace(Aantal, ".", "")
If Aantal >= 2 And Aantal < 16 Then
Cells(2 + cnt, 5).Value = "2"
ElseIf Aantal >= 16 And Aantal < 51 Then
Cells(2 + cnt, 5).Value = "3"
ElseIf Aantal >= 51 And Aantal < 151 Then
Cells(2 + cnt, 5).Value = "5"
ElseIf Aantal >= 151 And Aantal < 501 Then
Cells(2 + cnt, 5).Value = "8"
ElseIf Aantal >= 501 And Aantal < 3201 Then
Cells(2 + cnt, 5).Value = "13"
ElseIf Aantal >= 3201 And Aantal < 35001 Then
Cells(2 + cnt, 5).Value = "20"
ElseIf Aantal >= 35001 And Aantal < 500001 Then
Cells(2 + cnt, 5).Value = "32"
ElseIf Aantal > 500001 Then
Cells(2 + cnt, 5).Value = "50"
End If
'De crediteurnaam en nummer worden aan elkaar geplakt zodat dit de totale naam van de map vormt.
Mapnaam = Crediteurnaam + " " + Crediteurnr
Aantal_def = currentWb.Worksheets(1).Cells(2 + cnt, 5).Value
StrDate = Format(Now, "dd-mm-yyyy")
'Plak de waarden artikelnummer en controle aantal in de rapport template
Template_Elektra.Worksheets(1).Cells(6, 10).Value = Artikelnummer_def
Template_Elektra.Worksheets(1).Cells(8, 10).Value = Aantal_def
Template_Elektra.Worksheets(1).Cells(2, 10).Value = StrDate
'Hier wordt gecontroleerd of de crediteurmap al bestaat. Zo niet, dan wordt de map aangemaakt
Mapnaam_def = "G:\" + Mapnaam + "\"
If Len(Dir("G:\" + Mapnaam, vbDirectory)) = 0 Then
MkDir "G:\" + Mapnaam
End If
'Hier wordt het rapport opgeslagen in de juiste map
If Artikelnummer_def <> "" Then
Bestandsnaam = Mapnaam_def + " " + Bestelnummer + " " + Artikelnummer_def + " " + "Quality Report Electra D.v.D" & ".xls"
Template_Elektra.SaveAs fileName:=Bestandsnaam, FileFormat:=xlNormal
End If
'De onderstaande code zorgt ervoor dat de naam van het zip bestand en het pad alvast in een veld worden gezet
Do While Counter < 1
currentWb.Worksheets(1).Cells(3 + cnt, 8).Value = Mapnaam_def + Bestelnummer + ".zip"
Bijlage = currentWb.Worksheets(1).Cells(3 + cnt, 8).Value
Counter = Counter + 1
Loop
Else
'Hier worden de verschillende rapporten opgeslagen in één zip bestand per bestelnummer
strDestFileName = Mapnaam_def + Bestelnummer + ".zip"
strSourceFileName = Mapnaam_def
str7ZipPath = "C:\Program Files\7-Zip\7z.exe"
strPassword = "test123"
strCommand = str7ZipPath & " a -tzip """ & strDestFileName & """ """ & strSourceFileName & """"
Shell strCommand
'De onderstaande regel gebruikt een wachtwoord voordat iemand het zip bestand kan uitpakken
'strCommand = str7ZipPath & " -p" & strPassword & " a -tzip """ & strDestFileName & """ """ & strSourceFileName & """"
'Artikelnummer wordt hier op leeg gezet, omdat het laatste artikelnummer anders bij het volgende bestelnummer wordt meegenomen
Artikelnummer_def = ""
'Hier wordt het rapport als bijlage toegevoegd aan de mail en verstuurd naar het bijbehorende e-mailadres
Set olApp = CreateObject("Outlook.Application")
Set olMail = olApp.CreateItem(olMailItem)
With olMail
.SentOnBehalfOfName = "Peter Stultiens"
.To = "" + mailid + ""
.Subject = "Reports for ordernumber " + Bestelnummer
.Body = "In the attachment you fill find the quality reports for ordernumber " + Bestelnummer + " ."
.Attachments.Add Bijlage
.Send
End With
Set olApp = Nothing
Counter = 0
End If
cnt = cnt + 1
nr = 0
Loop
End With
Template_Elektra.Close False
Set Template_Elektra = Nothing
Database_Elektra.Close False
Set Database_Elektra = Nothing
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End SubHopelijk kunnen jullie me helpen, alvast bedankt!
