Cow18, Edmoor, HSV, hartelijk dank, ik ben hiermee geweldig geholpen. Hieronder de code die ik nu gebruik. Voor de giga's en senioren onder jullie
thumb
is dit maar hobbyistisch broddelwerk, maar misschien kan iemand anders er op dit forum nog ooit zijn voordeel mee doen. En suggesties om het slimmer of handiger te doen, zijn natuurlijk altijd welkom.
De volgende code in Outlook doet het volgende:
1. na binnenkomst van een specifieke mail, wordt via een regel deze mail opgeslagen in een outlook-map waarna via "run een script" de code wordt uitgevoerd:
2. de bijlage (CSV-bestand) wordt opgeslagen in de map ATTACHMENTS
3. er wordt gekeken of Excel reeds geopend is (code van Edmoor): zo nee, openen Excel-applicatie en openen Workbooks LOGBESTANDEN en REGISTRATIE - zo ja, naar volgende stap
4. kijken of Workbooks LOGBESTANDEN en REGISTRATIE reeds geopend zijn (code van Cow18): zo nee, openen Workbooks - zo ja: Nothing
5. in Workbook REGISTRATIE worden er vervolgens een aantal codes gerund die de gegevens direct verwerken in tabellen en grafieken, daarna slaat een code in Excel het bestand op en alle nieuwe gegevens zijn verwerkt & opgeslagen
Code:
Public Sub Bijlagen_Opslaan (MItem As Outlook.MailItem)
'Uitgangspositie mappen en bestandsnamen waarmee gewerkt moet worden (jaarlijks aanpassen):
Dim LOGBESTANDEN As String
Dim REGISTRATIE As String
Dim sSaveFolder As String
LOGBESTANDEN = "C:\...\Logbestanden.xlsx"
REGISTRATIE = "C:\...\Registratie.xlsm"
SsaveFolder = "C:\...\ATTACHMENTS\"
'Opslaan email-bijlage CSV-bestand in map:
Dim oAttachment As Outlook.Attachment
For Each oAttachment In MItem.Attachments
'MsgBox sSaveFolder & oAttachment.FileName
oAttachment.SaveAsFile sSaveFolder & oAttachment.FileName
'MsgBox oAttachment.DisplayName
'oAttachment.SaveAsFile sSaveFolder & oAttachment.DisplayName
Next
'kijken of Excel al draait, zo niet, dan Excel starten
Dim oExcel As Object
On Error Resume Next
Set oExcel = GetObject(, "Excel.Application")
On Error GoTo 0
If oExcel Is Nothing Then
Dim ExApp As Excel.Application
Set ExApp = New Excel.Application
ExApp.Visible = True
'openen beide mappen:
Set ExWbk1 = ExApp.Workbooks.Open(LOGBESTANDEN)
Set ExWbk2 = ExApp.Workbooks.Open(REGISTRATIE)
GoTo alles_open 'excel en mappen zijn nu geopend
Else
'excel was reeds geopend, je gaat nu kijken of de werkmappen al geopend zijn:
On Error Resume Next
Dim ExWbk1 As Workbook
Dim ExWbk2 As Workbook
Set ExWbk1 = Workbooks(LOGBESTANDEN) 'kijk of je hem kan aanspreken
If ExWbk1 Is Nothing Then Set ExWbk1 = ExApp.Workbooks.Open(LOGBESTANDEN) 'zoniet, is die niet open, dus openen
'nu kijken of REGISTRATIE al open staat:
Set ExWbk2 = Workbooks(REGISTRATIE) 'kijk of je hem kan aanspreken
If ExWbk2 Is Nothing Then Set ExWbk2 = ExApp.Workbooks.Open(REGISTRATIE) 'zoniet, is die niet open, dus openen
GoTo alles_open 'excel en mappen zijn nu geopend
On Error GoTo 0
End If
alles_open:
'Bijwerken gegevens, opslaan bestanden etc. n Excel:
ExWbk2.Application.Run "Module3.Actualiseren"
ExWbk2.Application.Run "Module1.Opslaan"
End Sub
Dankzij deze code gebeurt iedere ochtend bij het binnenkomen van de mail, het opslaan van de bijlagen als tabblad in een Workbook en het verwerken van deze gegevens automatisch.
In Excel wordt de volgende code gebruikt om de email-bijlagen uit een bestandsmap telkens op te slaan als afzonderlijk tabblad (met datum als naam), ook dankzij de bijdrage van Cow18 al eerder op dit forum:
Code:
Sub LOGBESTANDEN()
'Bijwerken Logbestanden.xlsx door alle nieuwe CSV-bestanden als tabblad in te voegen:
Set wb = Workbooks("Logbestanden.xlsx") 'verwijzing naar jouw werkboek, zonder er echt in te staan
c00 = Workbooks("Registratie.xlsm").Sheets("Data").Range("B2") 'bestandslocatie attachments wordt overgenomen uit cel B2 in tabblad DATA
myfiles = Split(CreateObject("Wscript.Shell").Exec("cmd /c dir """ & c00 & "*.csv"" /b").StdOut.ReadAll, vbCrLf) 'array van alle csv-bestanden in je subdirectory
' MsgBox UBound(myfiles) + 1 & " files !!!!!!!!" & vbLf & Join(myfiles, vbLf) 'enkel voor de grap, ze weer samenvoegen met een linefeed (vblf) om ze in een msgbox te tonen, mag straks weg
For I = 0 To UBound(myfiles) 'opgelet !!! begint altijd bij 0
If myfiles(I) = "" Then Exit Sub
' ActiveSheet.Range("A1").Value = "'=ISREF('[" & wb.Name & "]" & Split(myfiles(I), ".")(0) & "'!$A$1)" 'voor de grap, om je te tonen hoe je checkt of een werkblad bestaat in A1
If IsError(Evaluate("ISREF('[" & wb.Name & "]" & Split(myfiles(I), ".")(0) & "'!$A$1)")) Then
' MsgBox "volgende file : " & vbLf & c00 & myfiles(I) 'vervelende boodschap
With GetObject(c00 & myfiles(I))
.Sheets(1).Copy , After:=wb.Sheets(wb.Sheets.Count)
.Close 0
End With
wb.Sheets(wb.Sheets.Count).UsedRange.Replace What:=".", Replacement:="," 'zonet binnengehaald blad vervangen . -> ,
Else
' MsgBox myfiles(I) & " bestond al als werkblad", vbInformation 'vervelende boodschap
End If
Next
End Sub
Ik ben maar een Excel hobbyist, maar dankzij de vele topics op dit forum, geduldig codes knippen, plakken en uitproberen, kom je telkens een stapje verder. Allen, nogmaals hartelijk dank!
