AD Users with nested group memberships

I was recently working on a single domain which contained a lot of nested security groups (ie one group was a member of another, which in turn was a member of another etc.).
This kind of model can be useful to place a user account in one security group and automatically belong to many. However this can be a nightmare to diagnose if something goes wrong!
So here's a script I've had in my box of tricks for a while that should help. It outputs a list of users and all their group memberships (including the nested ones).

'==== SETTINGS ====================

' start ad path for user list
strOU = "OU=Site01,OU=Staff"


'==================================
If Right(LCase(WScript.FullName), 11) = "wscript.exe" Then
      Set objShell = CreateObject("WScript.Shell")
      objShell.Run "cscript """ & WScript.ScriptFullName & """", 1, False
      Set objShell = Nothing
      WScript.Quit
End If



Set adoCommand = CreateObject("ADODB.Command")
Set adoConnection = CreateObject("ADODB.Connection")
adoConnection.Provider = "ADsDSOObject"
adoConnection.Open "Active Directory Provider"
adoCommand.ActiveConnection = adoConnection

 ' Search entire Active Directory domain.
Set objRootDSE = GetObject("LDAP://RootDSE")
strDNSDomain = objRootDSE.Get("defaultNamingContext")

If Right(strOU, 1) <> "," Then strOU = strOU & ","
strBase = ""

strFilter = "(&(objectCategory=person)(objectClass=user))"

' Comma delimited list of attribute values to retrieve.
strAttributes = "ADsPath"

' Construct the LDAP syntax query.
strQuery = strBase & ";" & strFilter & ";" & strAttributes & ";subtree"
adoCommand.CommandText = strQuery
adoCommand.Properties("Page Size") = 100
adoCommand.Properties("Timeout") = 30
adoCommand.Properties("Cache Results") = False

' Run the query.
Set adoRecordset = adoCommand.Execute


' Enumerate the resulting recordset.
Do Until adoRecordset.EOF
      WScript.Echo ""
      WScript.Echo "Proccessing: " & adoRecordset.Fields("ADsPath").Value

    ' Retrieve values and display.
      Set objUser = GetObject(adoRecordset.Fields("ADsPath").Value)

      strResults = ""
      strGroups = ""
     
      intLevel = 0
     
      GetMemberOfNames objUser, intLevel
     
      strResults = Replace(objUser.Name, "CN=", "") & " is a member of: "
      arrGroups = Split(strGroups, VbCrLf)
      For intCount = LBound(arrGroups) To UBound(arrGroups)
            If strResults = "" Then
                  strResults = arrGroups(intCount)
            Else
                  strResults = strResults & VbCrLf & arrGroups(intCount)
            End If
      Next

      Set objUser = Nothing

      WScript.Echo ""
      WScript.Echo strResults

      adoRecordset.MoveNext
Loop

' Clean up.
adoRecordset.Close
Set adoRecordset = Nothing

adoConnection.Close

MsgBox "Done. Please see text file " & strOutputFile


'==== Sub's and Functions =========

Sub GetMemberOfNames(objObjectToCheck, intLevel)
      ' This function can get caught in a loop if there is a circular
      ' group membership.  There is a method of using a Dictionary object
      ' here: http://www.rlmueller.net/MemberOf.htm
      ' which checks if the group has been used before.
     
      intLevel = intLevel + 1
      ' Retrieve ALL of the user groups that a user is a member of
      On Error Resume Next
      objMemberOf = objObjectToCheck.GetEx("MemberOf")
      If Err.Number = 0 Then
            On Error GoTo 0
            For Each objGroup in objMemberOf
                  strGroupName = Left(Mid(objGroup, InStr(objGroup, "CN=") + 3),InStr(Mid(objGroup, InStr(objGroup, "CN=") + 3), ",") - 1)
                  If strGroups = "" Then
                        strGroups = String(intLevel, chr(9)) & strGroupName
                  Else
                        strGroups = strGroups & VbCrLf & String(intLevel, chr(9)) & "o " & strGroupName
                  End If
                  Set objNextGroup = GetObject("LDAP://" & objGroup)
                  GetMemberOfNames objNextGroup, intLevel
            Next
            intLevel = intLevel - 1
      Else
            intLevel = intLevel - 1
            Err.Clear
            On Error GoTo 0
      End If
End Sub

NB: Usually I stick some comments at the top of code so I know the source. I've had this so long that really can't remember if I wrote this or modified someone else's code. So if the above looks familiar, drop me an email and I'll give you credit!

MS Access Hebrew Dates Class (revisited)

This article has been updated and is now available here.

I've just finished the new version of the Hebrew Dates code.
All thanks to Moishy at Access World Forums for some really useful feedback on the original.
The new version can be downloaded for free via:

• 4Shared
• Access World Forums

Here's a description of the functionality

clsHebrewDate Class
  PROPERTIES
    .HDay
        Read/Write (long)
        stores the value of the current Hebrew day
        When set, the Gregorian Date will automatically be updated.
    .HMonth
        Read/Write (long)
        stores the value of the current Hebrew month
        When set, the Gregorian Date will automatically be updated.
    .HYear
        Read/Write (long)
        stores the value of the current Hebrew year
        When set, the Gregorian Date will automatically be updated.
    .HDaysInMonth
        Read Only (integer)
        returns the number of days in current Hebrew month.
    .GDate
        Read/Write (date)
        stores the value of the current Gregorian Date
        When set, the Hebrew Date will automatically be updated.
    .GAfterSunset
        Read/Write (boolean)
        used to mark the Gregorian date as occuring after sunset.
        NB: Gregorian days start at midnight but Hebrew days start
        after sunset
        TRUE = After sunset
        FALSE = Before sunset
        When set, the Hebrew Date will automatically be updated.
    .IsHLeapyear
        Read Only (boolean)
        Returns TRUE if the current Hebrew Year is a Hebrew leapyear
        NB: Hebrew leap years include a whole extra month (Adar II)
        and occur in a pattern that follows a 19 year cycle (see below)
    .IsValid
        Read Only (boolean)
        Returns TRUE if the current Hebrew Date is valid
  METHODS
    .Copy()
        Function returns clsHebrewDate type
        Creates and returns a new copy of the current instance
        of the clsHebrewDate class.
    .SetHebrewDate()
        Sets the Hebrew date and automatically updates the Gregorian
        date.
    .YahrzeitStep([,])
        Alters the current Hebrew Date moving it forward or backward
        x years according to the value of YearStep in accordance with
        the selected algorithm selected by CalcStyle.
        NB: You should always calculate additional Yahrzeit dates from
        the orginal date of the aneversary. DO NOT be tempted to calc
        a Yahrzeit from a previous Yahrzeit! This will lead to errors!
        YearStep: integer value can be positive or negative
        CalcStyle: (OPTIONAL)
                    1: Traditional (DEFAULT)
                    2: Reform
                    3: CatchAll

Module modHebrewDate
Function's
 GetHebrewMonthsList(bLeapYear As Boolean) As Variant
  returns a list of month numbers and their names delimited with semicolons
  this is particularly useful for generating combobox dropdown lists
  NB: Hebrew leap years have a extra month, hence the need for bLeapYear 
  to specify if the list should generate months for a leap year

 FormatHDate(myDate As clsHebrewDate, myFormat As Variant) As Variant
  Format hebrew date and output as a variant string.
  Variant string is needed so unicode letters can be used i.e. for Hebrew text
  the format parameters are based on the ones uses in PHP. See http://php.net/manual/en/function.date.php
  Format codes:
   Misc
    \ escape character
   Day
                d Date, 2 digits with leading zeros (00..30)
                f Textual representation of date as stored in the language table (HDate01..HDate30)
                j Date as number without leading zeros (1..30)
                l NB: this is a lowercase letter L
     Textual representation of the day of the week as stored in the language table (HDay1..HDay7)
                S English ordinal suffix for the day of the month, 2 characters (st, nd, rd, th)
                w returns 1..7 where 1=Sunday (Yom Rishon)
   Month
                F Textual representation of a month as stored in the language table
     (HMonth01..05, HMonth07..13, HMonth06Leap, HMonth07Leap)
                m Numeric representation of a month, with leading zeros (01..13)
                n Numeric representation of a month, without leading zeros (1..13)
                t Number of days in the given month (29..30)
   Year
                L Whether it's a leap year (1=yes 0=no)
                Y A full numeric representation of a year, all digits (eg 5758)
                y A two digit representation of a year (eg 58)
   Time
                a Textual representation of time of day in the Gregorian Date part as stored in Language Table (GTimeNight, GTimeDay)
Sub's
 SetHebrewDateFromGUI(ByRef MyHebrewDate As clsHebrewDate)
  Shows a hebrew date picker dialog box and returns any selected date back to the carable passed to MyHebrewDate
  NB: if you prefer the dialog box to display in Right to Left mode and have days that change according to the hebrew
  rather than the gregorian calendar (i.e. at sunset rather than midnight) edit the dlgHebDatePick13/14 form and set
  Const CDisplayRTL = True
  
  
  

Internationalisation in Access

Working with Joomla, I'm used to messing around with language files for the user interface.
Each language file supplies text that should be displayed (as part of the interface) to the user depending on their language.
So today, I decided it was high time I built something similar in Access. Below is the (surprisingly easy) result, using Kernel32 to identify the current language of the user...

First of all you'll need a table to store your text. Access text fields store text as unicode so you can even include text from right-to-left languages like Arabic or Hebrew.

The table will need 3 fields

1. swmVar to store the variable name
   Type: Text
   Size: 25
   Required: Yes
   Input Mask:  >Aaaaaaaaaaaaaaaaaaaaaaaaa
2. lwmLanguageID to store the ID of the Language the text is for
   Type: Long (Long Integer)
   Required: Yes
   Default Val: 0
3. swoData to store the text itself
    Type: Text
   Size: 255

I can't think of a reason why table would need a primary key but it does need to make sure that you don't store duplicate values of swmVar within the same Language ID so for ease I've set swmVar + lwmLanguageID as a composite primary key. However, you could create a separate primary key and just have these to fields as a composite unique index.

NB: I'm using my standard naming convention here where the first letter of the field represents the field type, the 2nd notes if the field is editable (w=write, r=read-only) and the 3rd shows if the field is optional (o) or mandatory (m).

Next you'll need the module
Module: ModLanguage

Option Compare Database
' Module to assist internationalisation of database interface
' written by Marc Ozin
' version: rc2012.02.02
' Website: http://marcozin.blogspot.com


' this module requires a lanaguage table like this:

' Table Name: tblLanguage
' Fields:
'   swmVar
'       Type:        Text
'       Size:        25
'       Required:    Yes
'       Input Mask:  >Aaaaaaaaaaaaaaaaaaaaaaaaa
'   lwmLanguageID
'       Type:        Long Integer
'       Required:    Yes
'       Default Val: 0
'   swoData
'       Type:        Text
'       Size:        255
'
' Primary Key: Composite of swmVar & lwmLanguageID
'
' this table will store language varables & text for each lanaguage code
' plus language varables & text to default to if language code not found
' signifed using lwmLanguageID of zero (0)

' Notes:
' Table of Locale ID's can be found on these pages:
' http://msdn.microsoft.com/en-us/goglobal/bb895996
' http://msdn.microsoft.com/en-us/goglobal/bb964664

' Examples:
' to set the caption for the button called ButtonCancel in a form when it opens
' edit the OnLoad event for the form and insert the following line:
'   ButtonCancel.Caption = GetLangTxt("CANCEL")
' Then in the language table create a row with these values:
'   swmVar:         CANCEL
'   lwmLanguageID:  0
'   swoData:        &Cancel
' "&Cancel" will be the default text when a particular user's language cannot be found
' to have different text for German, add the following row:
'   swmVar:         CANCEL
'   lwmLanguageID:  1031
'   swoData:        &Kündigen




'Get the language ID for the current user's locale from kernel32
'returns Long number representing the Language ID
Public Declare Function GetUserDefaultLCID% Lib "kernel32" ()


Public Function GetLangTxt(sLangVar As String, Optional ByVal lLanguageID As Long = -1) As String
' returns language text from specified variable stored in the Language Table
' function will try and return text for specified varable for current language (or language specified by lLanguageID)
' if no text found, then it will try and return text for varable with a language id of zero
' if still no text found, then it will return the name of the varable incased in square brackets

Const cLanguageTable = "tblLanguage"
Const cLanguageDataField = "[swoData]"
Const cLanguageVarableNameField = "[swmVar]"
Const cLanguageIDField = "[lwmLanguageID]"

Dim vTemp As Variant
    
    If lLanguageID = -1 Then
        lLanguageID = GetUserDefaultLCID()
    End If

    'try for a specific language id
    vTemp = DLookup(cLanguageDataField, cLanguageTable _
    , cLanguageVarableNameField & " like '" & UCase(Trim(sLangVar)) & "' and " & cLanguageIDField & "=" & CStr(lLanguageID))
    
    ' if nothing found
    If IsNull(vTemp) Then
        'try for language zero
        vTemp = DLookup(cLanguageDataField, cLanguageTable _
        , cLanguageVarableNameField & " like '" & UCase(Trim(sLangVar)) & "' and " & cLanguageIDField & "=0")
    End If
    GetLangTxt = Nz(vTemp, "[" & sLangVar & "]")
End Function

Here's an example of how to set the caption for the button called ButtonCancel in a form when it opens.

1. edit the OnLoad event for the form and insert the following line:

   ButtonCancel.Caption = GetLangTxt("CANCEL")

2. Then to set "&Cancel" as the default text when a particular user's language cannot be found, in the language table create a row with these values:
   
   • swmVar: CANCEL
   • lwmLanguageID: 0
   • swoData: &Cancel
3. to have different text for German, add the following row:
   
   • swmVar: CANCEL
   • lwmLanguageID: 1031
   • swoData: &Kündigen

Hebrew Dates as Class Module in Access

See new post with updated version!
Recently I've been messing around with a neat bit of code written to explain how to calculate Hebrew dates (which are based on a Lunar calendar).
I've extended it's functions, building it into a Class; creating Yartzeit calculation functionality (using Progressive, Traditional and Catch-All options); and hebrew date picker GUI dialogs.

You can find my first version of this code here:
http://www.4shared.com/file/_5c5GJcP/hebrewDates.html
or
http://www.access-programmers.co.uk/forums/attachment.php?attachmentid=40063

The file is is Access2010 format and contains an example form to show some of it's features.

NB you can open the file in Access 2007 but 2007 doesn't support the .BackColor property for Buttons so you'll need to alter this in the dlgHebDatePick code inside the Draw_MonthButtons Sub.

See new post with updated version!

Displaying a 6 digit number as 4 text characters

Recently I had to link up 2 systems, one financial off the shelf package and a bespoke Access database used for contact management.
The contact management data was going to create and maintain customer accounts in the financial package. The problem was in the access DB each contact had a unique number and in the financial package we needed a reference where the first 2 letters of the customers surname were followed with up to 4 more characters for a unique reference.
Tricky.
In the end I put together this short bit of code that allows you to convert a number to any base. All you have to do is supply the digits to use.
In my case I've used base 33 to pack the id numbers into a shorter format using numbers and letters.

Const vbB2Digits = "01" 'base 2 - Binary
Const vbB8Digits = "01234567" 'base 8 - Octal
Const vbB10Digits = "0123456789" 'base 10 - Decimal
Const vbB10Digits = "0123456789XE" 'base 12 - Dozenal. See http://www.dozenal.org
Const vbB16Digits = "0123456789ABCDEF" 'base 16 - Hexedecimal
Const vbB33Digits = "0123456789ABCDEFGHJKMNPQRSTUVWXYZ" 'base 33 - non similar characters (I,L,O removed) from 0-9 & Alphabet


Public Function sEncodeNumber(lNumber As Long, Optional sDigitList As String = vbB10Digits) As String
Dim sOutputString As String
Dim lTmpNumber As Long
Dim lRangeSize As Long
Dim lTmpPower As Long
Dim lTmpLastPower As Long

    OutputString = ""
    lTmpNumber = lNumber
    lRangeSize = Len(sDigitList)
    lTmpPower = 1

    ' Work with postive numbers
    If lTmpNumber < 0 Then
        lTmpNumber = lTmpNumber * -1
    End If

    While lTmpNumber > 0
        lTmpLastPower = lTmpPower
        lTmpPower = lTmpPower * lRangeSize
        sOutputString = Mid(sDigitList, ((lTmpNumber Mod lTmpPower) / lTmpLastPower) + 1, 1) & sOutputString
        lTmpNumber = lTmpNumber - (lTmpNumber Mod lTmpPower)
    Wend

    ' insert the -ve sign if the orginal number was negative
    If lNumber < 0 Then
        sOutputString = "-" & sOutputString
    End If

    sEncodeNumber = sOutputString
End Function

For those maths geeks out there, if you haven't come across dozenal before, have a quick gander at Alex Bellos' blog entires on the subject.

Viewing a Nested Set Model tree as an Adjacency List

Recently, I needed to view a Nested Set Model tree as an Adjacency list so I could use it with VB's TreeCtrl.

Here's the MS-SQL view I came up with:

SELECT   T1.irpCategory, T1.iwmleft, T1.iwmright, T1.swmCategoryName, T1.ircDepth, T2.ircParentID
FROM     (SELECT   TOP 100 PERCENT node.irpCategory, node.iwmleft, node.iwmright, node.swmCategoryName, (COUNT(parent.swmCategoryName) - 1) 
                       AS ircDepth
            FROM     dbo.tblCategories AS node, dbo.tblCategories AS parent
            WHERE   node.iwmleft BETWEEN parent.iwmleft AND parent.iwmright
            GROUP BY node.irpCategory, node.swmCategoryName, node.iwmleft, node.iwmright
            ORDER BY node.iwmleft) T1 LEFT OUTER JOIN
             (SELECT   TOP 100 PERCENT irpCategory,
                            (SELECT   TOP 1 irpCategory
                             FROM     dbo.tblCategories t2
                             WHERE   t2.iwmleft < t1.iwmleft AND t2.iwmright > t1.iwmright
                             ORDER BY t2.iwmright - t1.iwmright ASC) AS ircParentID
              FROM     dbo.tblCategories t1
              ORDER BY iwmright - iwmleft DESC) T2 ON T1.irpCategory = T2.irpCategory

And the VB for the TreeCtrl object called tvCategories:

Private Sub Refresh_tvCategories()
On Error GoTo Err_Handler
Dim vNodeSet As Variant
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim bFirstItem As Boolean
Dim sFirstKey As String
    Set db = CurrentDb
    'SQLCategoriesList is a odbc passthru query to the view on the MSSQL server
    Set rs = db.OpenRecordset("SELECT * FROM SQLCategoriesList")
    bFirstItem = True
    
    
    If Not rs.EOF Then
        rs.MoveFirst
        While Not rs.EOF
                        

            If IsNull(rs.Fields("ircParentID")) Then
                Set vNodeSet = tvCategories.Nodes.Add()
                vNodeSet.Key = "K" & rs.Fields("irpCategory")
                vNodeSet.Expanded = False
                vNodeSet.Text = rs.Fields("swmCategoryName")
            Else
                'Tree Controls need text for their IDs so I'm prefixing the ID numbers with the letter K
                Set vNodeSet = tvCategories.Nodes.Add("K" & rs.Fields("ircParentID"), tvwChild)
                vNodeSet.Key = "K" & rs.Fields("irpCategory")
                vNodeSet.Expanded = False
                vNodeSet.Text = rs.Fields("swmCategoryName")
            End If
            If bFirstItem Then
                sFirstKey = vNodeSet.Key
                bFirstItem = False
            End If
            rs.MoveNext
        Wend
    End If
    
    'for some reason the form doesnt work properly unless an item has been selected at some point
    tvCategories.Nodes(sFirstKey).Selected = True
    'it can be unslected straight away
    
    
    
Exit_Err_Handler:
    Exit Sub
    
Err_Handler:
    Select Case Err.Number
       Case vbObjectError + 1
          Resume Next
       Case Else
          msgbox Err.Number & Err.Description
          Resume Exit_Err_Handler
    End Select

End Sub