Niquet.nl

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:

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:

En deze functie kunt u dan als volgt gebruiken:

 

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

Snelle en elegante code om vanuit Access een query (sql) te exporteren naar Excel

Exporten

Option Compare Database
Option Explicit
Dim fldCount As Integer
Dim recCount As Long

Public Function ExporterenQueryExcel(SQL As String, _
Titel As String, _
bestandsnaam As String)
'declareren variabelen
Dim db As Database
Dim rs As Recordset
Dim xlApp As Excel.Application
Dim xlWb As Excel.Workbook
Dim xlWs As Excel.Worksheet
Dim ArrExp() As Variant

' Open database
Set db = CurrentDb
'Open recordset
Set rs = db.OpenRecordset(SQL)

'vullen variabelen
Dim iCol As Integer
Dim iRow As Integer
Dim rownr As Integer

'Excel openen
Set xlApp = New Excel.Application
Set xlWb = xlApp.Workbooks.Add
Set xlWs = xlWb.Worksheets.Add

'Verbergen van Excel
xlApp.Visible = False
xlApp.UserControl = False

With xlWs
.Activate
'Titel op eerste regel
With .Range("A1", "G1")
.Font.Name = "Arial"
.Merge
.Range("A1", "E1").value = Titel
.Font.Bold = True
.Font.Size = 22
End With

'Plakken veldnamen op regel 4
'Vanwege loop is het aantal velden variabel in te stellen (door bepaling SQL code)
fldCount = rs.Fields.Count
For iCol = 1 To fldCount

With xlWs.Cells(4, iCol)
.Font.Name = "Arial"
.value = rs.Fields(iCol - 1).Name
.Interior.Pattern = xlSolid
.Interior.PatternColorIndex = xlAutomatic
.Interior.ThemeColor = xlThemeColorAccent5
.Interior.TintAndShade = 0.799981688894314
.Interior.PatternTintAndShade = 0
.Font.Size = 12
End With

Next iCol

If rs.RecordCount = 0 Then

recCount = 0
.Cells(5, 1).value = "Geen records gevonden!"

'MsgBox "Er zijn geen records gevonden. Pas de SQL query aan en probeer opnieuw.", vbOKOnly, "EXporteren query naar Excel"
Exit Function

Else
recCount = rs.RecordCount
.Cells(5, 1).CopyFromRecordset rs

End If

.Cells(4, 1).CurrentRegion.EntireColumn.AutoFit
.Cells(4, 1).Select

.Range("A5").Select
.Range("A5").Activate
With xlApp.ActiveWindow
.FreezePanes = False
.ScrollRow = 1
.ScrollColumn = 1
.FreezePanes = True
.ScrollRow = 5
End With

End With

rs.Close

xlApp.Visible = True
xlApp.UserControl = True

Set xlApp = Nothing
Set rs = Nothing
Set db = Nothing

End Function

Fraaie aanvulling

Nog mooier is het om de tabel na export te verfraaien met de mooie tabelstijlen van Excel.
Om dit voor elkaar te krijgen, dan moet je na het plakken van de recordset onderstaande code zetten:

Set r = .Range("a4").CurrentRegion
r.EntireColumn.AutoFit
r.Select

.ListObjects.Add(xlSrcRange, r, , xlYes).Name = "relaties"
.ListObjects("relaties").TableStyle = "TableStyleMedium8"

Dan ziet de gehele code er als volgt uit:

 


Option Compare Database
Option Explicit
Dim fldCount As Integer
Dim recCount As Long

Public Function ExporterenQueryExcel(SQL As String, _
Titel As String, _
bestandsnaam As String)
'declareren variabelen
Dim db As Database
Dim rs As Recordset
Dim xlApp As Excel.Application
Dim xlWb As Excel.Workbook
Dim xlWs As Excel.Worksheet
Dim ArrExp() As Variant
Dim r As Excel.Range

' Open database
Set db = CurrentDb
'Open recordset
Set rs = db.OpenRecordset(SQL)

'vullen variabelen
Dim iCol As Integer
Dim iRow As Integer
Dim rownr As Integer

'Excel openen
Set xlApp = New Excel.Application
Set xlWb = xlApp.Workbooks.Add
Set xlWs = xlWb.Worksheets.Add

' Display Excel and give user control of Excel's lifetime
xlApp.Visible = False
xlApp.UserControl = False

With xlWs
.Activate
'Titel op eerste regel
With .Range("A1", "G1")
.Font.Name = "Arial"
.Merge
.Range("A1", "E1").value = Titel
.Font.Bold = True
.Font.Size = 22
End With

'Plakken veldnamen op regel 4
'Vanwege loop is het aantal velden variabel in te stellen (door bepaling SQL code)
fldCount = rs.Fields.Count
For iCol = 1 To fldCount

With xlWs.Cells(4, iCol)
.Font.Name = "Arial"
.value = rs.Fields(iCol - 1).Name
' .Interior.Pattern = xlSolid
' .Interior.PatternColorIndex = xlAutomatic
' .Interior.ThemeColor = xlThemeColorAccent5
' .Interior.TintAndShade = 0.799981688894314
' .Interior.PatternTintAndShade = 0
.Font.Size = 12
End With

Next iCol

If rs.RecordCount = 0 Then

recCount = 0
.Cells(5, 1).value = "Geen records gevonden!"

'MsgBox "Er zijn geen records gevonden. Pas de SQL query aan en probeer opnieuw.", vbOKOnly, "EXporteren query naar Excel"
Exit Function

Else
recCount = rs.RecordCount
.Cells(5, 1).CopyFromRecordset rs

End If

Set r = .Range("a4").CurrentRegion
r.EntireColumn.AutoFit
r.Select

.ListObjects.Add(xlSrcRange, r, , xlYes).Name = "relaties"
.ListObjects("relaties").TableStyle = "TableStyleMedium8"

'.Cells(4, 1).CurrentRegion.EntireColumn.AutoFit
'.Cells(4, 1).Select

.Range("A5").Select
.Range("A5").Activate
With xlApp.ActiveWindow
.FreezePanes = False
.ScrollRow = 1
.ScrollColumn = 1
.FreezePanes = True
.ScrollRow = 5
End With

End With

rs.Close

xlApp.Visible = True
xlApp.UserControl = True

'xlWb.SaveAs bestandsnaam

Set xlApp = Nothing
Set rs = Nothing
Set db = Nothing

End Function

Genereren HTML mail (vanuit bijv. Access)

Aanmaken HTML mail vanuit Access

Deel 1 - declareren te gebruiken variabelen (Outlook model)

 


Option Compare Database
Option Explicit
Dim olApp As Outlook.Application
Dim olNs As Outlook.NameSpace
Dim olMail As Outlook.MailItem

Sub HTMLMail()

'DECLAREREN VARIABELEN

Dim aan As String
Dim body As String
Dim naamaccount As String

'VULLEN VARIABELEN
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set olMail = olApp.CreateItem(olMailItem)
naamaccount = "andre@vanvlietlogistics.com"

body = "" & vbLf
body = body & "" & vbLf
body = body & "" & vbLf
body = body & "" & vbLf
body = body & "" & vbLf
body = body & "" & vbLf
body = body & "" & vbLf
body = body & "" & vbLf
body = body & "Beste heer, mevrouw,
"

body = body & "
"
body = body & "Middels deze brief verzoek ik u vriendelijk om de zorgverzekering die bij uw maatschappij is afgesloten te betreffende polisnummer is:polisnummer
"
body = body & "beëindigen op 01/01/2020 of de eerstvolgende geschikte datum. Het betreffende polisnummer is:123456
"
body = body & "
"
body = body & "De reden van m’n opzegging is als volgt: overstap naar andere zorgverzekering/veranderde polisvoorwaarden/dekkingsproblemen.
"
body = body & "
"
body = body & "U wordt verzocht mij van de opzegging een bevestiging te zenden.
"
body = body & "
"
body = body & "Met vriendelijke groet,

"

With olMail

.SendUsingAccount = olApp.Session.Accounts.item(BepaalMailAccount(naamaccount))
.Display
.To = "funniq@gmail.com"
.Recipients.ResolveAll
.Subject = "Onderwerp nieuwe mail"
.HTMLBody = body & .HTMLBody

End With

Set olApp = Nothing
Set olNs = Nothing
Set olMail = Nothing

End Sub

Onderstaande functie kan worden gebruikt als er meerdere account zijn aangemaakt en de mail verzonden moet worden van een account die niet als standaard is ingesteld.

Function BepaalMailAccount(naamaccount As String) As Integer

' Dim OutApp As Outlook.Application
Dim i As Long
For i = 1 To olApp.Session.Accounts.Count
If olApp.Session.Accounts.item(i).DisplayName = naamaccount Then
BepaalMailAccount = i

End If

Next i
End Function