Niquet.nl

Betalingsherinneringen mailen via Outlook (HTML mail)

Uiteraard is dit op zoveel manieren in te richten, maar hieronder volgt een uitleg hoe ik dit heb gedaan.

Let op: niet alle HTML styling werkt standaard voor alle e-mail clients. Dus sommige HTML ziet er prima uit in je browser, maar absoluut niet in Outlook of ander mail client.

We hebben – afgezien van Access en Outlook – het volgende nodig:

  1. Een tabel/query met alle openstaande facturen per debiteur (detailinfo)
  2. Een tabel/query met de aan te manen debiteuren (afgeleid van tabel / query genoemd bij ‘1’ incl. Emailadres en taalcode
  3. Een VBA procedure 
  4. Een macro die deze procedure start
  5. Een  Access-rapport kan heel goed ‘automatisch’ gestart kan worden vanuit de Windows taakplanner (Scheduler), mits je zeker weet dat alle gegevens zijn bijgewerkt. 
    Voor het sturen van betalingsherinnering – zoals in dit voorbeeld – is dit een stuk lastiger omdat je uiteraard wel wilt dat alle verzonden verkoopfacturen op je herinnering staan EN dat alle bankmutaties (i.c. ontvangsten) zijn ingeboekt.
  6. Mailbody bestaande uit 3 secties:
    1. tekst VOOR tabel (incl CSS styling –> VBA object converteert dit naar inline styling)
    2. Tabel met openstaande posten
    3. Mailbody / tekst NA tabel

Voor het gemak heb ik een tabel aangemaakt waarin ik twee velden heb aangemaakt van het type ‘Grote tekst” of “Memo” genaamd: “TekstVoorTabel” en “TekstNaTabel”.

Tip: Het beste is – zeker als je de teksten wilt wijzigen in deze tabel – om een formulier te maken en in te stellen dat je met de enter toets naar de volgende regel gaat i.p.v. naar het volgende veld.

Hierin type of plak je de HTML code/script/tekst die je later in je VBA code kunt oproepen met de DLOOKUP functie bijvoorbeeld.

Een voorbeeld van een “TekstVoorTabel”:

Lijst bijwerken op basis van knop

Met een knop een listbox (formulier control) vullen met waarden op basis van een SQL query gefilterd op een waarde in een tekstveld elders in het formulier.

Datumveld genaamd “BetaalDatum”
Lijst control genaamd “lstCred”

Lijst moet gevuld worden met alle betaalde crediteuren op de datum ingevuld in veld ‘BetaalDatum’.

Hiervoor heb ik een private sub aangemaakt die ik aanroep zodra datum geselecteerd is met 

‘CALL Lijstupdate(datum)

 

 


Private Sub LijstUpdate(dat As Date)

Dim SQL As String
Dim BetaalDatum As String

Dim aant As Integer
Dim ctl As Control

DoCmd.Echo False

'Betaaldatum converteren naar tekst
BetaalDatum = Format(dat, "yyyy-mm-dd")

'Eerst checken of die dag überhaupt betalingen waren
aant = DCount("*", "_Betaalspecificatie_Betaalbaar", "[BetaalDatum] = #" & BetaalDatum & "#")

If aant > 0 Then

    SQL = "SELECT Betaaldatum, Crediteurnummer, Emailadres,   zoeknaam, naam, Aantal, Betaald " & _
    "FROM _Betaalspecificatie_Betaalbaar " & _
    "WHERE Betaaldatum = #" & BetaalDatum & "# " & _
    "ORDER BY zoeknaam;"

    Else
    
    SQL = "select distinct 'Geen' as CDCREDITEUR, 'Geen' AS ZOEKNAAM,  'Geen' AS 
    NAAM, 'Geen' as Email FROM _Betaalspecificatie_Betaalbaar"


End If


Me.lstCred.RowSource = SQL
Me.lstCred.Requery


DoCmd.Echo True

MsgBox "Lijst bijgewerkt."


De onderliggende query is zo opgebouwd dat als er geen e-mailadres bekend is, dat dan m’n eigen e-mailadres wordt getoond.

Met onderstaande code loop ik door alle crediteuren heen en selecteer alleen de crediteuren waarvan een e-mailadres bekend is.

Het e-mailadres staat in derde kolom van de lijst,en aangezien de lijst zero-based is, is index van het veld 2:

 


Private Sub knpSelecteerJuisteEmail_Click()

Dim lijst As ListBox
Set lijst = Me.lstCred
Dim itm As Object
Dim i As Integer
Dim msg As String

   For i = 0 To lijst.ListCount - 1
       If lijst.Column(2, i) = "eigen@emailadres.com" Then
            lijst.Selected(i) = False
       Else
           lijst.Selected(i) = True
       End If
   Next i

End Sub

Tonen lijst met alle aanwezige drives (Filesystemobject)

Met de volgende code genereer je een berichtenvenster met alle drives:

Sub drives()

    Dim fso As FileSystemObject
    Dim driveColl As drives
    Dim drive As drive
    
    txtDrives = ""
    
    Set fso = New FileSystemObject
    Set driveColl = fso.drives
    
    For Each drive In driveColl
        txtDrives = txtDrives & "Drive Letter: " & drive.DriveLetter '& vbCrLf
        
        If drive.IsReady Then
            txtDrives = txtDrives & " / Ready: " & drive.VolumeName
            
        Else
            txtDrives = txtDrives & " / Not ready" & vbCrLf
        End If
        txtDrives = txtDrives & vbCrLf
    Next

    MsgBox txtDrives

End Sub

Inlezen handtekening in (Outlook)mail

Als je een Outlook-mailitem aanmaakt op een account waar een default handtekening is ingesteld dan kan je door het inrichten van de mailitem deze handtekening opnemen door de olMailItem.HTMLbody te vullen door de evt gegenereerde bodytekst + olMailItem.HTMLbody.

Maar je kunt de handtekening ook inlezen door gebruik te maken van het inlezen van de html – file.

De reeds aangemaakte handtekeningen staan waarschijnlijk in je Roaming directory,  bijv:

“c:\users\<gebruikersnaam>\AppData\Roaming\Microsoft\Signatures\”

Maar je kunt uiteraard een handtekening inlezen die elders staat. 

Allereerst moet je refereren naar “Microsoft Scripting Runtime” om gebruik te kunnen maken van de “Filesystemobject”.

Maak dan de volgende module / code aan:

 


Dim olApp as outlook.Application
Dim olMail as Outlook.Mailitem
Dim olMailTekst as string
Dim FSO as Scripting.FileSystemObject
Dim tsTextIn as Scripting.TextStream
Dim strTextIn as String
Dim strFile as string

'Inlezen handtekening
strFile = "C:\Users\\AppData\Roaming\Microsoft\Signatures\Standaard.htm"
Set FSO= New Scripting.FileSystemObject
Set tsTextIn = FSO.OpenTextFile(strFile)
strTextIn = tsTextIn.ReadAll

'Ingelezen HTML script van Handtekening plakken onder de gewenste bodytekst
olMailTekst = "

Dit is een test

Lekker veel tekst

" olMailTekst = olMailTekst & vbLf & strTextIn 'Initiëren Outlook mail set olApp = new Outlook.Application set olMail = olApp.CreateItem(0) With olMail .to = "test@mail.nl" .Subject = "Testonderwerp" .HTMLBody = olMailTekst .display End With

Relink gelinkte tabellen in Access

Als je een Access database gebruikt op meerdere PC’s en deze wordt gesynchroniseerd met Onedrive, dan kan het zijn dat een gekoppelde bestand op een ander pad staat. 

Dan werkt onderstaande code om te relinken:

 


Public Function reLinkTables() As Boolean
On Error GoTo ErrorRoutine
Dim sMyConnectString        As String
Dim tdf                     As TableDef
Dim db_name                 As String
    ' The Main Answer is by Martin Thompson
    ' Modified by Dr. Mohammad Elnesr
    'We will link all linked tables to an accdb Access file located in the same folder as this file.
    'Replace the DATA file name in the following statement with the name of your DATA file:
    sMyConnectString = ";DATABASE=" & CurrentProject.Path & "\"
    For Each tdf In CurrentDb.TableDefs
        If Len(tdf.Connect) > 0 Then
            'It's a linked table, so re-link:
            'First, get the database name
            db_name = GetFileName(tdf.Connect)
            ' Then link the table to the current path
            If tdf.Name = "Tbl_CorrectieInkoopEindejaar" Then
            
            tdf.Connect = sMyConnectString & db_name
            tdf.RefreshLink
            End If
            
        End If
    Next tdf


ExitRoutine:
 '   MsgBox "All tables were relinked successfully"
    Exit Function
ErrorRoutine:
  '  MsgBox "Error in gbLinkTables: " & Err.Number & ": " & Err.Description
    Resume ExitRoutine
End Function

Aanmaken afspraak/meeting in Outlook vanuit Excel

Stappen:

  1. Maak een Excel bestand aan en sla deze op als een Macro enabled workbook, bijv. “Outlouk-agenda vanuit Excel.xlsm”
  2. Maak in eerste tabblad (hernoem deze naar ‘agenda’) op de eerste regel de volgende kolomkoppen aan:
    • Agenda – account
    • Onderwerp
    • Locatie
    • Body
    • Datum
    • start
    • eind
    • Hele dag
    • Categorie

Het ziet er dan als volgt uit:

 

Sub MakenOutlookAfspraak()
    
    Dim olApp As Outlook.Application
    Dim olNS As Outlook.Namespace
    Dim calFld As Outlook.Folder
    Dim olAppItem As Outlook.AppointmentItem
    Dim r As Long
    
    On Error Resume Next
    Worksheets("agenda").Activate
    Set olApp = New Outlook.Application

    On Error GoTo 0
    'Checken of Outlook is geïnstalleerd / beschikbaar is
    If olApp Is Nothing Then
        On Error Resume Next
        Set olApp = New Outlook.Application
        On Error GoTo 0
        If olApp Is Nothing Then
            MsgBox "Outlook is not available!"
            Exit Sub
        End If
    End If
    
    Set olNS = olApp.GetNamespace("MAPI")
    
    r = 2 ' eerste rij waar een afspraak is vastgelegd / moet vastgelegd zijn
    Dim account, onderwerp, Start, Einde, kalender, locatie, omschrijving
    
    
    While Len(Cells(r, 1).Text) <> 0
        account = Cells(r, 1) 
        Set calFld = olNS.Folders(account).Folders("Agenda")
        Set olAppItem = calFld.Items.Add(olAppointmentItem)
            
        With olAppItem
            .Subject = Cells(r, 2) & ", " & Cells(r, 3)
            Start = DateValue(Cells(r, 5).Value) + Cells(r, 6).Value
            .Start = Start
            
            Einde = DateValue(Cells(r, 5).Value) + Cells(r, 7).Value
            .End = Einde
            .Location = Cells(r, 3)
            .Body = Cells(r, 4)
            .Categories = Cells(r, 9)
            If Cells(r, 8) = "Ja" Then
                .AllDayEvent = True
            Else
                .AllDayEvent = False
            End If
            
            'Evt overige opties:
            '            .ReminderSet = True
            '            .BusyStatus = olFree
            '            '.Attachments.Add ("c:\temp\somefile.msg")
            '            .ReminderSet = True
            '            .BusyStatus = olBusy
            On Error GoTo 0
            .Save ' saves the new appointment to the default folder
        End With
        r = r + 1
    Wend
    Set olAppItem = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
    MsgBox "Done !"
End Sub


 

Maak op de tabblad ‘agenda’ een knop die bovenstaande module/macro activeert en voila …klaar

Aanmaken Outlook e-mailbericht

Reserveren variabelen

dim olApp as outlook.Application
dim olMail as Outlook.Mailitem

Initiëren Outlook

set olApp = New Outlook.Application
set olNs = olApp.GetNamespace("MAPI")
set olMail = olApp.CreateItem(olMailItem)

Of:

set olMail = Application.CreateItem(olMailItem)
set olNs = Application.GetNamespace("MAPI")

E-mailbericht vullen

With olmail
   .SendUsingAccount = olApp.Session.Accounts.Item(x)
   .Display
   .subject = "Onderwerp"
   .HTMLbody = html tekst & .HTMLbody
   


End with

Handige en eenvoudige manier om Windows Product Key te achterhalen (OEM installatie)

Stel nou dat je - om wat voor reden dan ook - je licentie key wilt achterhalen van je Windows installatie omdat deze niet te zien is op een stickertje van Microsoft aan de zijkant  van je PC, dan heb ik hier een hele makkelijke tip.

Natuurlijk zijn er gratis tools voor te vinden om dit te achterhalen maar met de korte edoch slimme truc die ik hieronder zal uitleggen hoef je NIETS te installeren. Mooi toch? 🙂

  1. Stap 1: toets op je toetsenbord tegelijkertijd in: je Windows key + de letter 'R' (van 'Run')
  2. Een dialoogscherm met de titel  'Uitvoeren' komt in beeld met een invoervak.
  3. Tik hier in 'cmd' en klik vervolgens op OK / of druk op de 'Enter-toets'. Hiermee wordt de zgn. DOS-prompt geopend
  4. Plak de volgende tekst in deze DOS-prompt:   wmic path softwareLicensingService get OA3xOriginalProductKey
  5. Druk vervolgens op de ENTER-toets en voila ... de Windows Product Key wordt getoond

Alternatief

Mocht het bovenstaande niet het gewenste resultaat geven dan hier een alternatief. Ook nu hoef je niets te installeren.

Het enige wat je hoeft te doen is onderstaande code in een nieuw tekstbestand te plakken, op te slaan met een bepaalde naam+extensie en vervolgens deze script uit te voeren.


Option Explicit

Dim objshell,path,DigitalID, Result
Set objshell = CreateObject("WScript.Shell")
'Set registry key path
Path = "HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\"
'Registry key value
DigitalID = objshell.RegRead(Path & "DigitalProductId")
Dim ProductName,ProductID,ProductKey,ProductData
'Get ProductName, ProductID, ProductKey
ProductName = "Product Name: " & objshell.RegRead(Path & "ProductName")
ProductID = "Product ID: " & objshell.RegRead(Path & "ProductID")
ProductKey = "Installed Key: " & ConvertToKey(DigitalID)
ProductData = ProductName & vbNewLine & ProductID & vbNewLine & ProductKey
'Show messbox if save to a file
If vbYes = MsgBox(ProductData & vblf & vblf & "Save to a file?", vbYesNo + vbQuestion, "BackUp Windows Key Information") then
Save ProductData
End If

'Convert binary to chars
Function ConvertToKey(Key)
Const KeyOffset = 52
Dim isWin8, Maps, i, j, Current, KeyOutput, Last, keypart1, insert
'Check if OS is Windows 8
isWin8 = (Key(66) \ 6) And 1
Key(66) = (Key(66) And &HF7) Or ((isWin8 And 2) * 4)
i = 24
Maps = "BCDFGHJKMPQRTVWXY2346789"
Do
Current= 0
j = 14
Do
Current = Current* 256
Current = Key(j + KeyOffset) + Current
Key(j + KeyOffset) = (Current \ 24)
Current=Current Mod 24
j = j -1
Loop While j >= 0
i = i -1
KeyOutput = Mid(Maps,Current+ 1, 1) & KeyOutput
Last = Current
Loop While i >= 0

If (isWin8 = 1) Then
keypart1 = Mid(KeyOutput, 2, Last)
insert = "N"
KeyOutput = Replace(KeyOutput, keypart1, keypart1 & insert, 2, 1, 0)
If Last = 0 Then KeyOutput = insert & KeyOutput
End If

ConvertToKey = Mid(KeyOutput, 1, 5) & "-" & Mid(KeyOutput, 6, 5) & "-" & Mid(KeyOutput, 11, 5) & "-" & Mid(KeyOutput, 16, 5) & "-" & Mid(KeyOutput, 21, 5)

End Function
'Save data to a file
Function Save(Data)
Dim fso, fName, txt,objshell,UserName
Set objshell = CreateObject("wscript.shell")
'Get current user name
UserName = objshell.ExpandEnvironmentStrings("%UserName%")
'Create a text file on desktop
fName = "C:\Users\" & UserName & "\Desktop\WindowsKeyInfo.txt"
Set fso = CreateObject("Scripting.FileSystemObject")
Set txt = fso.CreateTextFile(fName)
txt.Writeline Data
txt.Close
End Function

Werkwijze

  1. Selecteer bovenstaande tekst en druk op je toetsenbord op CTRL-C (kopiëren)
  2. Start Windows Notepad
  3. Plak de geselecteerde tekst met CTRL-V in dit nieuwe document
  4. Sla dit document ergens op (bijv. op je bureaublad) onder bijvoorbeeld de naam "GetWindowsKey.vbs". De naam op zich is niet van belang, wel de extensie 'vbs' (dan weet Windows dat dit een script is).
  5. Sluit het document af en ga met je verkenner naar de locatie waar je dit bestand hebt opgeslagen.
  6. Dubbelklik op dit bestand
  7. Je krijgt vervolgens een dialoogscherm met hierin je Licentie code.

Voorbeeld:

E-mailbericht exporteren als PDF bestand

Met Windows 10 kwam de mooie functie waarmee je alle documenten die je naar de printer kunt sturen ook opslaan als PDF bestand.  Dus ook e-mailtjes in Outlook.
In VBA kom je dit echter niet tegen vreemd genoeg in de Outlook class. Deze vind je wel terug in MS-Word, dus via een omweg kan je via VBA toch een e-mailbericht opslaan als PDF bestand:

Sub SaveMessageAsPDF()
     
    Dim Selection As Selection
    Dim obj As Object
    Dim Item As MailItem
     Dim tmpfilename
     Dim MyDocs
     
    Dim wrdApp As Word.Application
    Dim wrdDoc As Word.Document
    Set wrdApp = CreateObject("Word.Application")
    Set Selection = Application.ActiveExplorer.Selection

For Each obj In Selection
 
    Set Item = obj
    
    Dim FSO As Object, TmpFolder As Object
    Dim sName As String
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set tmpfilename = FSO.GetSpecialFolder(2)
    
    sName = Item.subject
    ReplaceCharsForFileName sName, "-"
    tmpfilename = tmpfilename & "\" & sName & ".mht"
    
    Item.SaveAs tmpfilename, olMHTML
    
    
Set wrdDoc = wrdApp.Documents.Open(fileName:=tmpfilename, Visible:=True)
  
    Dim WshShell As Object
    Dim SpecialPath As String
    Dim strToSaveAs As String
    Set WshShell = CreateObject("WScript.Shell")
    MyDocs = WshShell.SpecialFolders(16)
       
strToSaveAs = MyDocs & "\" & sName & ".pdf"
 
' Controleren of er al een bestand is met dezelfde naam
' als dit het geval is, dan wordt de tijd erachter gezet
If FSO.FileExists(strToSaveAs) Then
   sName = sName & Format(Now, "hhmmss")
   strToSaveAs = MyDocs & "\" & sName & ".pdf"
End If
  
wrdApp.ActiveDocument.ExportAsFixedFormat OutputFileName:= _
    strToSaveAs, ExportFormat:=wdExportFormatPDF, _
    OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, _
    Range:=wdExportAllDocument, From:=0, To:=0, Item:= _
    wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
    CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
    BitmapMissingFonts:=True, UseISO19005_1:=False
             
Next obj
    wrdDoc.Close
    wrdApp.Quit
    Set wrdDoc = Nothing
    Set wrdApp = Nothing
    Set WshShell = Nothing
    Set obj = Nothing
    Set Selection = Nothing
    Set Item = Nothing
 
End Sub

Bovengenoemde code slaat het uiteindelijke PDF bestand op in de ‘default’ documenten-map.

Als je dit wilt vragen aan de gebruiker kan je onderstaande functie gebruiken:

Function SelecteerMap(Optional OpenAt As Variant) As Variant
  Dim ShellApp As Object
  Set ShellApp = CreateObject("Shell.Application"). _
 BrowseForFolder(0, "Selecteer de map waar u het PDF bestand wilt opslaan AUB", 0, OpenAt)
 
 On Error Resume Next
    SelecteerMap = ShellApp.self.Path
 On Error GoTo 0
 
 Set ShellApp = Nothing
    Select Case Mid(SelecteerMap, 2, 1)
        Case Is = ":"
            If Left(SelecteerMap, 1) = ":" Then GoTo Invalid
        Case Is = "\"
            If Not Left(SelecteerMap, 1) = "\" Then GoTo Invalid
        Case Else
            GoTo Invalid
    End Select
 Exit Function
 
Invalid:
 SelecteerMap = False
End Function



En deze functie kunt u dan als volgt gebruiken:

MyDocs = SelecteerMap
    
strToSaveAs = MyDocs & "\" & sName & ".pdf"
 
' Controleren of er al een bestand is met dezelfde naam
' als dit het geval is, dan wordt de tijd erachter gezet
If FSO.FileExists(strToSaveAs) Then
   sName = sName & Format(Now, "hhmmss")
   strToSaveAs = MyDocs & "\" & sName & ".pdf"
End If
'Verkenner openen en bestand selecteer  
Shell "C:\Windows\explorer.exe /select," & strToSaveAs, vbMaximizedFocus

 

Functie om een tekstveld te strippen van bepaalde tekens

Private Sub ReplaceCharsForFileName(sName As String, sChr As String)
sName = Replace(sName, "/", sChr)
sName = Replace(sName, "\", sChr)
sName = Replace(sName, ":", sChr)
sName = Replace(sName, "?", sChr)
sName = Replace(sName, Chr(34), sChr)
sName = Replace(sName, "<", sChr)
sName = Replace(sName, ">", sChr)
sName = Replace(sName, "|", sChr)
sName = Replace(sName, "&", sChr)
sName = Replace(sName, "%", sChr)
sName = Replace(sName, "*", sChr)
sName = Replace(sName, " ", sChr)
sName = Replace(sName, "{", sChr)
sName = Replace(sName, "[", sChr)
sName = Replace(sName, "]", sChr)
sName = Replace(sName, "}", sChr)
sName = Replace(sName, "!", sChr)
End Sub