Get user profile from Azure AD using VBA

First, you need to register your app on Azure Active Directory tenant. Then, is mandatory to provide a client secret for the application. You should at least grant access to User.Read for both Delegated permission and Application permission. You can do this in API permissions tab of the Azure AD tenant. 

Then, here you go:

Sub AnyName()

    Const clientId = "{cid}" 'this is application Id

    Const tenantId = "{tid}"

    Const clientSecret = "{cs}"

    Const userPrincipalName = "{upn}"

    Debug.Print GetUserProfile(GetToken(clientId, tenantId, clientSecret), userPrincipalName)

End Sub

Public Function GetToken(clientId As String, tenantId As String, clientSecret As String) As String

    Dim objPost  As Object

    Dim urltoken As String

    

    Const graphResource = "https://graph.microsoft.com"

    

    Set objPost = CreateObject("MSXML2.XMLHTTP")

    urltoken = "https://login.microsoftonline.com/" & tenantId & "/oauth2/token"

    objPost.Open "POST", urltoken, False

    

    objPost.Send ("grant_type=client_credentials&client_id=" & clientId & "&client_secret=" & clientSecret & "&resource=" & graphResource)

    

    If objPost.ReadyState = 4 And objPost.Status = 200 Then

        GetToken = ReadSimpleJson(objPost.ResponseText, "access_token")

    Else

        MsgBox "Error" & vbNewLine & "Ready state: " & objPost.ReadyState & _

        vbNewLine & "HTTP request status: " & objPost.Status

    End If

    Set objPost = Nothing

End Function

Public Function ReadSimpleJson(jsonString As String, labelValue As String) As String

Dim sSplitJson() As String

Dim j            As Integer

Dim sSplit()     As String

jsonString = Replace(jsonString, "{", "")

jsonString = Replace(jsonString, "}", "")

sSplitJson = Split(jsonString, ",")

For j = 0 To UBound(sSplitJson)

    sSplit = Split(sSplitJson(j), """:""")

    

    If Replace(sSplit(LBound(sSplit)), """", "") = labelValue Then

       ReadSimpleJson = Replace(sSplit(UBound(sSplit)), """", "")

    End If

Next j

End Function

Public Function GetUserProfile(accessToken As String, userId As String) As String

    Dim objPost  As Object

    Dim urlgraph As String

    

    Set objPost = CreateObject("MSXML2.XMLHTTP")

    urlgraph = "https://graph.microsoft.com/v1.0/users/" & userId 'or userPrincipalName

    objPost.Open "GET", urlgraph, False

    

    objPost.SetRequestHeader "Authorization", "Bearer " & accessToken

    objPost.Send

    

    If objPost.ReadyState = 4 And objPost.Status = 200 Then

        GetUserProfile = objPost.ResponseText

    Else

        MsgBox "Error" & vbNewLine & "Ready state: " & objPost.ReadyState & _

        vbNewLine & "HTTP request status: " & objPost.Status

    End If

    Set objPost = Nothing

End Function

 

See Graph Explorer | Try Microsoft Graph APIs - Microsoft Graph for other request addresses.

Oferte 2003

 Cine se obosește să îmi citească profilul pe LinkedIn va citi aceasta: 

From 2003 to present I have designed several VBA Access applications of which the most important - "Oferte 2003" - has worked and/or still works for the following companies: Universul Juridic, Niculescu Publishing House, Solomon Publishing House, Book-land Store, Cartex Publishing, Craft Concept, Andreas Publishing House. "Oferte 2003" is a complete management, billing, primary accounting and business management software, compatible with the Daisy, Eltrade, Datecs cash registers.

“Oferte 2003” - is now commercialized by Lead-IT Expert Consulting.

Voi adăuga câteva amănunte: partea de facturare conține și gestiunea de consignație. Nu sunt multe aplicații care să poată face corect partea de consignație și partea de facturare obișnuită în același timp. Oferte 2003 nu se încurcă. 

Oferte 2003 permite unui operator de facturare să introducă peste 1800 de rânduri în facturi într-o zi de muncă (verificat !). Asta înseamnă sub 16 secunde pentru selecție, identificare și introducere într-un act (factură sau aviz) a unui articol (+ identificare client, + discount pe produs, + listare factura etc.), timp de 8 ore fără pauză nici de cafea, nici de toaletă, în condițiile a peste 50000 (cincizeci de mii) de articole diferite și peste 1300000 (un million trei sute de mii) înregistrări în baza de date (și aici vorbesc de baze de date MS Access, pentru cunoscători).

Dar, poate că nu e cazul să obosim un operator de facturare în asemenea hal. Oferte 2003 poate automatiza procesul de facturare/avizare. Se pot construi acte-matriță care rămân salvate și pot fi apelate oricând e nevoie, având o modalitate ușoară de modificare astfel încât să corespundă nevoii imediate.  Oferte 2003 poate aloca pe fiecare client în parte articole anumite, la preturi speciale și – opțional – pe perioade limitate astfel încât se limitează aria de căutare a articolelor ce urmează a fi livrate la specificul fiecărui client. Oferte 2003 poate crea produse speciale de tip abonament și poate emite automat acte către unul sau toți abonații în funcție de câte produse din abonament a primit anterior abonatul. Este suficient ca periodic să fie actualizat conținutul abonamentului.

Oferte 2003 rezervă produsele puse în facturile Pro-Forma.

Oferte 2003 îi ajută pe cei care au și producție, pe lângă partea comercială. Este suficient să fie întroduse într-o gestiune separată (recomandat) materiile prime – cu intrări de la furnizori și NIR-uri, desigur – și se poate folosi modulul de creare de produse. Este sugerat inclusiv prețul final de vânzare.

Oferte 2003 îi ajută pe detailiști. Produsele se pot descompune (și compune la loc după aceeași rețetă). Astfel, intrările pot fi containere dar se pot vinde/livra treptat în baxuri, sau subsecvent, în cutii, topuri etc. până la 9 împărțiri. Produsele împărțite se pot recompune la loc la nevoie în limita stocurilor rămase disponibile, pentru fiecare nivel de împărțire. Produsele rezultate din astfel de împărțiri pot face parte din produse noi, după modelul de producție. Orice produs nou creat, fie prin compunere fie prin împărțire are același nivel și statut ca orice alt articol din nomenclator și se poate factura/aviza împreună cu oricare alt articol.

Oferte 2003 nu lucrează doar cu obiecte purtătoare de stoc în gestiune. Oferte 2003 facturează și servicii. Serviciile pot fi incluse in facturile care conțin gestiune sau pot fi facturate separat. Serviciile pot face parte dintr-un nomenclator de servicii si se pot selecta de acolo sau – la nevoie – se pot trece ad-hoc in facturi. Factura în sine este un obiect compus care poate conține obiecte din mai multe clase.

Și ar mai fi. Actele se pot transforma în pdf nativ și se pot trimite direct pe e-mail către clienți. În cazul în care compania care folosește programul Oferte 2003 tine evidența clienților pe fiecare agent de vânzări, Oferte 2003 știe să facă și asta. 

Și ar mai fi. Comunicarea cu baze de date din cloud, pentru a descărca și factura automat comenzile de pe site-uri, sau adaugarea de produse noi în magazinele on-line.

Close an open Microsoft Excel file from Microsoft Access

Let's say you need to delete or replace a certain Microsoft Excel file from a Microsoft Access application. 

Many times Microsoft Access need to report in Microsoft Excel files, so you need to generate them. But once a Microsoft Excel file was generated and even opened, you may loose control on that file. The user can modify it, and let it opened without saving it and after a while the user may need to see a fresh report in that file. So, Microsoft Access need to generate again that certain file, but is not that simple.

First, Microsoft Access need to see if that Excel file is opened.

Then Microsoft Access need to close it, without pending in a title bar blink and a message displayed, asking if you want to save any loaded files. Then it may need to delete it and generate it again with the new data.

All the manuals appeal to API functions. Below is how you may do it without them.

Sub ExcelGenerate()

Dim fso As Object

Dim strLoc As String

'choose the place where to generate the file:

strLoc = Application.CurrentProject.Path

Set fso = CreateObject("Scripting.FileSystemObject")

If fso.FileExists(strLoc & "/SomeXLFile.xlsx") Then

   'see ActivateXLFile below

   If ActivateXLFile("SomeXLFile.xlsx") = True Then

      MsgBox "The Excel File is open and cannot be closed!", vbInformation

   Else

       fso.DeleteFile strLoc & "/SomeXLFile.xlsx"

       'then generate a new Microsoft Excel file

       '.....

   End If

Else

    'if the file doesn't exists, then there is no problem to generate it...

End If

End Sub

Public Function ActivateXLFile(DenFile As String) As Boolean

Dim appExcel As Excel.Workbook

ActivateXLFile = False 'it's False by default anyway, but is good to mention

On Error Resume Next

'asume that the file is open and try to activate it

AppActivate DenFile, False

If Err = 0 Then

   'if the file is open and activate, err is zero

   On Error GoTo Exi

   Set appExcel = GetObject(Application.CurrentProject.Path & "/" & DenFile)

   'functional version: Set appExcel = CreateObject(Application.CurrentProject.Path & "/" & DenFile)

   With appExcel

       .Save 'save the file; you don't need any blinking message from Excel, you will replace it, anyway...

       .Close

   End With

Else

    'if the file isn't open, it cannot be activate and close. Clear the error.

    Err.Clear

End If

Exit Function

Exi:

'just to be sure: if there anything happen and the file cannot be closed...

ActivateXLFile = True

End Function

ByVal, ByRef. The real use, beyond the lesson. VBScript

...but is also valid for all members of VB family.

Dim varA, strMsg 

varA = Int(InputBox ("Input the initial value:"))
strMsg ="'varA' initial: " & varA & Chr(13) & Chr(10)

varA = TransAVal(varA) 'varA ia valoarea functiei / varA it takes the function's value
strMsg = strMsg & "'varA' after TransAVal: " & varA & Chr(13) & Chr(10)

varA = TransARef(varA) 'varA ia valoarea functiei / varA it takes the function's value
strMsg = strMsg & "'varA' after TransARef: " & varA & Chr(13) & Chr(10)

ValA varA 'varA isi pastreaza valoarea / varA keeps its value
strMsg = strMsg & "'varA' after ValA: " & varA & Chr(13) & Chr(10)

RefA varA 'varA ia valoarea finala a parametrului din functia RefA / varA it takes the final value of the RefA function parameter
strMsg = strMsg & "'varA' after RefA: " & varA 
WScript.Echo strMsg

Function TransARef(ByRef x)
TransARef = x + 1
End Function

Function TransAVal(ByVal x) 
TransAVal = x + 1
End Function

Sub ValA(ByVal x)
x = x + 1
End Sub

Sub RefA(ByRef x)
x = x + 1
End Sub

Conclusion:
ByRef and BvVal have no influence if you return the function to assign it to a value. This is the most common situation.

Extracting from a string. VBA

Something easy for today:
If you have a text string with numbers within (let say you are interested only in those numbers, it's just an example), and you want to pick up those numbers from the text, you need a function to do it.


Option Explicit

'source code: https://code-for-vb.blogspot.com/2020/02/extracting-from-string-vba.html
'please to mention


Function NumbersFromText() As String
Dim i As Integer
Const a = "ancduirg123456ggt789uyq"
Dim b As String
Dim c As String
Dim d As String
Dim e As String

b = a
c = a

'split constant a in characters and find the ASCII code for each:
For i = 1 To Len(a)
    'just for a better understanding:
    Debug.Print Mid(a, i, 1), Asc(Mid(a, i, 1))
    'the Debug window will contain this text:
'    a              97
'    n              110
'    c              99
'    d              100
'    u              117
'    i              105
'    r              114
'    g              103
'    1              49
'    2              50
'    3              51
'    4              52
'    5              53
'    6              54
'    g              103
'    g              103
'    t              116
'    7              55
'    8              56
'    9              57
'    u              117
'    y              121
'    q              113

    'replace every non-digit character with zero / with zero length string:
    If Asc(Mid(a, i, 1)) < 49 Or Asc(Mid(a, i, 1)) > 57 Then
       b = Replace(b, Mid(a, i, 1), "")
       c = Replace(c, Mid(a, i, 1), 0)
    End If
Next i
'now, b is 123456789
c = Trim(Str(Val(c)))
'now, c is 123456000789000

'reverse the string c in d
For i = Len(c) To 1 Step -1
    d = d & Mid(c, i, 1)
Next i
d = Trim(Str(Val(d)))
'now, d is 987000654321

'reverse the string d in e
For i = Len(d) To 1 Step -1
    e = e & Mid(d, i, 1)
Next i

'c could be reused for saving memory:
c = Replace(e, "0", "_")
Debug.Print "Substract only numbers from string '" & a & "' : " & b
Debug.Print "Keep only the numbers interval from string '" & a & "' : " & e & " or " & c

'this is what Immediate window will show:
'Substract only numbers from string 'ancduirg123456ggt789uyq' : 123456789
'Keep only the numbers interval from string 'ancduirg123456ggt789uyq' : 123456000789 or 123456___789

'remain to choose:
NumbersFromText = b
'or
NumbersFromText = c
'or
NumbersFromText = e
End Function

Note that you need to call this function from abroad, so constant "a" should be passed as parameter of the NumbersFromText Function, like this:

Function NumbersFromText(a As String) As String
...
...
...
End Function

DoCmd.GoToRecord doesn't work on subforms

Presupun că orice programator VBA Access a simțit la un moment dat nevoia unei comenzi de genul DoCmd.GoToRecord , , acNext care să acționeze într-un subformular. Dar, nu merge. O comandă de acest tip va genera o eroare ca cea de mai jos:

I suppose that any VBA Access programmer at one point felt the need for a command like DoCmd.GoToRecord , , acNext, to work in a subform. But it is not working. An order of this type will generate an error like the one below:

Această eroare apare indiferent de felul în care este apelat subformularul, așa

This error occurs regardless of how the subform is called, this way

DoCmd.GoToRecord acDataForm, "Table2 subform", acNext

sau așa

or that way

DoCmd.GoToRecord acDataForm, Forms!Form1![Table2 subform].Form.Name, acNext

Astfel, trebuie găsită o altă cale.

Să presupunem că avem un formular care conține două subformulare și avem nevoie să scriem într-un subformular și în acealși timp să vedem rezultatul în al doilea subformular. Voi pune mai jos codul și felul în care trebuie construite formularele.

Thus, another way must be found.

Suppose we have a form that contains two subforms and we need to write in a subform and at the same time see the result in the second subform. I will put below the code and the way in which the forms must be build.

Mai întâi, voi construi două tabele Table1 și Table2 astfel:

First, I will build two tables Table1 and Table2 as follows:

Apoi, voi construi un formular Form1 și două subformulare corespondente celor două tabele, Table1 subform și Table2 subform. Acestea vor putea arăta astfel:

Then I will build a Form1 form and two subforms corresponding to the two tables, Table1 subform and Table2 subform. They will look like this:

Sursele datelor pentru Tabel1 subform și Tabel2 subform sunt

SELECT [Table1].[ID], [Table1].[Field1] FROM Table1; 

respectiv 

SELECT Table2.Table1_ID, Table2.Table1_Field1 FROM Table2; 

Data sources for Table1 subform and Table2 subform are

SELECT [Table1]. [ID], [Table1]. [Field1] FROM Table1;

respectively

SELECT Table2.Table1_ID, Table2.Table1_Field1 FROM Table2;

Ca să fie evitate orice erori de introducere, Table2 subform nu trebuie să permită scrierea. Puteți seta proprietățile controlului care conține subformularul Enabled = No sau Locked = Yes.

In order to avoid any input errors, Table2 should not allow writing. You can set Enabled = No or Locked = Yes for the control properties that contain the subform.

Acum, obiectele bazei de date vor arăta astfel:

Now, the database objects will look like this:

În Module1 voi scrie codul pentru resetarea tabelelor după fiecare încercare:

In Module1 I will write the code to reset the tables after each attempt:

Option Compare Database

Option Explicit

Sub BackCounter()

With CurrentDb

     .Execute "DELETE FROM Table1"

     .Execute "DELETE FROM Table2"

     .Execute "ALTER TABLE Table1 ALTER COLUMN ID COUNTER (1,1)"

End With

End Sub

În modulul subformularului Table1 subform voi scrie următorul cod, pentru evenimentele Form_AfterInsert, Form_Current și Form_Delete:

In Table1 subform VBA module I will write the following code for Form_AfterInsert, Form_Current and Form_Delete events:

Option Compare Database

Option Explicit

Private Sub Form_AfterInsert()

With Forms!Form1![Table2 subform].Form

     .Recordset.AddNew

     !Table1_ID = Me!ID

     !Table1_Field1 = Me!Field1

     .Refresh

End With

End Sub

Private Sub Form_Current()

'there is an error with OnOpen event, because Table2_subform is not initialized yet

On Error GoTo ErrEx

With Forms!Form1![Table2 subform].Form.Recordset

     .MoveFirst

     .Move Me.Recordset.AbsolutePosition

End With

ErrEx:

End Sub

Private Sub Form_Delete(Cancel As Integer)

Forms!Form1![Table2 subform].Form.Recordset.Delete

'after Delete, Table2 was going to the first record

'so, to make sure the both tables are on the same record, put the Table1 on the first record:

Me.Recordset.MoveFirst

End Sub

Rezultatul arată astfel:

The result looks like this:

Când se va introduce rând nou în Tabel1 subform, se va adăuga și în Tabel2 subform. Dacă se va șterge un rând din Tabel1 subform, în Tabel2 subform va fi șters rândul corespunzător.

When a new row is inserted into Table1 subform, it will be added to Table2 subform as well. Deleting a row from Table1 subform will delete the corresponding row in Table2 subform.

DAO Recordset AddNew vs. SQL INSERT INTO - which is faster?

Dincolo de orice opinie, am pus mai jos codul care are raspunsul adevarat la intrebarea din titlu.
Am ales trei situatii, am facut trei tabele (Table1, Table2, Table3), fiecare cu doua campuri (ID - AutoNumber, fieldTXT - ShortText) si am rulat un singur cod pentru a insera 100000 de inregistrari in fiecare tabel.


Beyond any opinion, I have put below the code that has the true answer to the title question.
I chose three situations, made three tables (Table1, Table2, Table3), each with two fields (ID - AutoNumber, fieldTXT - ShortText) and ran a single code to insert 100,000 records in each table.




Sub Faster()
Dim valTime1 As Long, valTime2 As Long
Dim rst As Recordset
Dim i As Long

'reset tables, just for sure, for when this code is repeated:
With CurrentDb
     .Execute "ALTER TABLE Table1 ALTER COLUMN ID COUNTER (1,1)"
     .Execute "ALTER TABLE Table2 ALTER COLUMN ID COUNTER (1,1)"
     .Execute "ALTER TABLE Table3 ALTER COLUMN ID COUNTER (1,1)"
End With

valTime1 = Time * 86400
Set rst = CurrentDb.OpenRecordset("Table1")
For i = 1 To 100000
    rst.AddNew
    rst!fieldTXT = "123456789101112131415161718192021222324252627282930"
    rst.Update
Next i
rst.Close
Set rst = Nothing
valTime2 = Time * 86400
Debug.Print "DAO Recordset: ", valTime2 - valTime1

valTime1 = Time * 86400
For i = 1 To 100000
    CurrentDb.Execute "INSERT INTO Table2 (fieldTXT) VALUES ('123456789101112131415161718192021222324252627282930')"
Next i
valTime2 = Time * 86400
Debug.Print "SQL INSERT single row: ", valTime2 - valTime1

valTime1 = Time * 86400
CurrentDb.Execute "INSERT INTO Table3 (fieldTXT) SELECT fieldTXT FROM Table1"
valTime2 = Time * 86400
Debug.Print "SQL INSERT multiple rows: ", valTime2 - valTime1
End Sub

rezultatul apare in Immediate Window (in secunde):

the result appears in the Immediate Window (in seconds):

DAO Recordset:               12 

SQL INSERT single row:       61 

SQL INSERT multiple rows:    0 

Wow!