DEVelopers HUT

'Decimal To Binary
' =================
' Source: http://groups.google.ca/group/comp.lang.visual.basic/browse_thread/thread/28affecddaca98b4/979c5e918fad7e63
' Author: Randy Birch (MVP Visual Basic)
' NOTE: You can limit the size of the returned
'              answer by specifying the number of bits
Function Dec2Bin(ByVal DecimalIn As Variant, _
              Optional NumberOfBits As Variant) As String
    Dec2Bin = ""
    DecimalIn = Int(CDec(DecimalIn))
    Do While DecimalIn <> 0
        Dec2Bin = Format$(DecimalIn - 2 * Int(DecimalIn / 2)) & Dec2Bin
        DecimalIn = Int(DecimalIn / 2)
    Loop
    If Not IsMissing(NumberOfBits) Then
       If Len(Dec2Bin) > NumberOfBits Then
          Dec2Bin = "Error - Number exceeds specified bit size"
       Else
          Dec2Bin = Right$(String$(NumberOfBits, _
                    "0") & Dec2Bin, NumberOfBits)
       End If
    End If
End Function
 
'Binary To Decimal
' =================
Function Bin2Dec(BinaryString As String) As Variant
    Dim X As Integer
    For X = 0 To Len(BinaryString) - 1
        Bin2Dec = CDec(Bin2Dec) + Val(Mid(BinaryString, _
                  Len(BinaryString) - X, 1)) * 2 ^ X
    Next
End Function

Set oRegEx = CreateObject("vbscript.regexp")
oRegEx.Pattern = "YourRegEx Goes Here"
bResult = oRegEx.Test(YourStringToTestTheRegExWith)

Application.CurrentProject.Name

Application.CurrentProject.Path

Application.CurrentProject.Path & "\"

Application.CurrentDb.Name

'---------------------------------------------------------------------------------------
' Procedure : FormPhone
' Author    : CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Format a string into a formated phone number
' Copyright : The following may be altered and reused as you wish so long as the
'             copyright notice is left unchanged (including Author, Website and
'             Copyright).  It may not be sold/resold or reposted on other sites (links
'             back to this site are allowed).
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sPhone    : a raw phone number string (ie:5555555)
'
' Usage Example:
' ~~~~~~~~~~~~~~~~
' FormPhone("5555555")      -->>    555-5555
' FormPhone("5555555555")   -->>    (555)555-5555
' FormPhone("55555555555")  -->>    5(555)555-5555
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2009-Feb-13             Initial Release
' 2         2010-Jan-26             Expanded code to format 10 and 11 char phone no.
'---------------------------------------------------------------------------------------
Function FormPhone(sPhone As String) As String
On Error GoTo Error_Handler
    Dim sIni        As String
    Dim sArea       As String
    Dim sPNumber    As String
    Dim isPhoneLen  As Integer
 
    'Make sure we actually have a value to process
    If sPhone = "" Or IsNull(sPhone) Then
        sPhone = ""
        Exit Function
    End If
 
    sPhone = Trim(sPhone)    'Remove any leading or trailing white spaces
    isPhoneLen = Len(sPhone) 'Determine the length of the raw tel no.
    Select Case isPhoneLen
        Case 7  '555-5555
            FormPhone = Left(sPhone, 3) & "-" & Right(sPhone, Len(sPhone) - 3)
        Case 10 '(555)555-5555
            sArea = "(" & Left(sPhone, 3) & ") "
            sPNumber = Right(sPhone, Len(sPhone) - 3)
            FormPhone = sArea & Left(sPNumber, 3) & "-" & _
                        Right(sPNumber, Len(sPNumber) - 3)
        Case 11 '5(555)555-5555
            sIni = Left(sPhone, 1)
            sArea = "(" & Left(Right(sPhone, Len(sPhone) - 1), 3) & ") "
            sPNumber = Right(sPhone, Len(sPhone) - 4)
            FormPhone = sIni & sArea & Left(sPNumber, 3) & _
                        "-" & Right(sPNumber, Len(sPNumber) - 3)
        Case Else
            FormPhone = sPhone
    End Select
 
Error_Handler_Exit:
    On Error Resume Next
    Exit Function
 
Error_Handler:
    MsgBox "MS Access has generated the following error" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & "Error Source: FormPhone" & _
           vbCrLf & "Error Description: " & Err.Description, vbCritical, _
           "An Error has Occured!"
    Resume Error_Handler_Exit
End Function

Function StripAllChars(strString As String) As String
'Return only numeric values from a string
    Dim lngCtr      As Long
    Dim intChar     As Integer
 
    For lngCtr = 1 To Len(strString)
        intChar = Asc(Mid(strString, lngCtr, 1))
        If intChar >= 48 And intChar <= 57 Then
            StripAllChars = StripAllChars & Chr(intChar)
        End If
    Next lngCtr
End Function
 
Function FormatPhone(strIn As String) As Variant
On Error Resume Next
 
    strIn = StripAllChars(strIn)
 
    If InStr(1, strIn, "@") >= 1 Then
        FormatPhone = strIn
        Exit Function
    End If
 
    Select Case Len(strIn & vbNullString)
        Case 0
            FormatPhone = Null
        Case 7
            FormatPhone = Format(strIn, "@@@-@@@@")
        Case 10
            FormatPhone = Format(strIn, "(@@@) @@@-@@@@")
        Case 11
            FormatPhone = Format(strIn, "@ (@@@) @@@-@@@@")
        Case Else
            FormatPhone = strIn
    End Select
End Function

'---------------------------------------------------------------------------------------
' Procedure : GetFirstofWeek
' Author    : CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Determine the date of the first day of the week for a given date
' Copyright : The following may be altered and reused as you wish so long as the
'             copyright notice is left unchanged (including Author, Website and
'             Copyright).  It may not be sold/resold or reposted on other sites (links
'             back to this site are allowed).
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' dtDate    : Date to find the start of the week of
'
' Usage Example:
' ~~~~~~~~~~~~~~~~
' GetFirstofWeek(#10/2/2009#)
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2009-Nov-16                 Initial Release
'---------------------------------------------------------------------------------------
Function GetFirstofWeek(dtDate As Date)
On Error GoTo Error_Handler
    'GetFirstofWeek = DateAdd("d", dtDate, -(Weekday(dtDate)) + 1) 'Returns the Sunday
    GetFirstofWeek = DateAdd("d", dtDate, -(Weekday(dtDate)) + 2) 'Returns the Monday

Exit Function
 
Error_Handler:
    MsgBox "MS Access has generated the following error" & vbCrLf & vbCrLf & "Error Number: " & _
    Err.Number & vbCrLf & "Error Source: GetFirstofWeek" & vbCrLf & "Error Description: " & _
    Err.Description, vbCritical, "An Error has Occured!"
    Exit Function
End Function

'---------------------------------------------------------------------------------------
' Procedure : GenRandomStr
' Author    : CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Generate a random string (alpha, numeric or alphanumeric)
' Copyright : The following may be altered and reused as you wish so long as the
'             copyright notice is left unchanged (including Author, Website and
'             Copyright).  It may not be sold/resold or reposted on other sites (links
'             back to this site are allowed).
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' iNoChars      - No of characters the random string should be in length
' bNumeric      - Should the random string include Numeric characters
' bUpperAlpha   - Should the random string include Uppercase Alphabet characters
' bLowerAlpha   - Should the random string include Lowercase Alphabet characters
'
' Usage Example:
' ~~~~~~~~~~~~~~~~
' GenRandomStr(12, True, False, True)
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2009-Nov-11                 Initial Release
'---------------------------------------------------------------------------------------
Function GenRandomStr(iNoChars As Integer, bNumeric As Boolean, _
                      bUpperAlpha As Boolean, bLowerAlpha As Boolean)
On Error GoTo Error_Handler
    Dim AllowedChars() As Variant
    Dim iEleCounter     As Integer
    Dim i               As Integer
    Dim iRndChar        As Integer
 
    'Initialize our array otherwise it throws an error
    ReDim Preserve AllowedChars(0)
    AllowedChars(0) = ""
 
    Randomize
 
    'Numeric
    '48-57
    If bNumeric = True Then
        For i = 48 To 57
            iEleCounter = UBound(AllowedChars)
            ReDim Preserve AllowedChars(iEleCounter + 1)
            AllowedChars(iEleCounter + 1) = i
        Next i
    End If
 
    'Uppercase alphabet
    '65-90
    If bUpperAlpha = True Then
        For i = 65 To 90
            ReDim Preserve AllowedChars(UBound(AllowedChars) + 1)
            iEleCounter = UBound(AllowedChars)
            AllowedChars(iEleCounter) = i
        Next i
    End If
 
    'Lowercase alphabet
    '97-122
    If bLowerAlpha = True Then
        For i = 97 To 122
            ReDim Preserve AllowedChars(UBound(AllowedChars) + 1)
            iEleCounter = UBound(AllowedChars)
            AllowedChars(iEleCounter) = i
        Next i
    End If
 
    iNoAllowedChars = UBound(AllowedChars)
    For i = 1 To iNoChars
        iRndChar = Int((iNoAllowedChars * Rnd) + 1)
        GenRandomStr = GenRandomStr & Chr(AllowedChars(iRndChar))
    Next i
 
Exit Function
 
Error_Handler:
    MsgBox "MS Access has generated the following error" & vbCrLf & vbCrLf & "Error Number: " & _
    Err.Number & vbCrLf & "Error Source: GenRandomStr" & vbCrLf & "Error Description: " & _
    Err.Description, vbCritical, "An Error has Occured!"
    Exit Function
End Function

'---------------------------------------------------------------------------------------
' Procedure : RunFile
' Author    : CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Run/Execute files from vba (bat, vbs,…)
' Copyright : The following may be altered and reused as you wish so long as the
'             copyright notice is left unchanged (including Author, Website and
'             Copyright).  It may not be sold/resold or reposted on other sites (links
'             back to this site are allowed).
' Input Variables:
' ~~~~~~~~~~~~~~~~
' strFile - full path including filename and extension
' strWndStyle - style of the window in which the program is to be run
'               value can be vbHide,vbNormalFocus,vbMinimizedFocus
'               vbMaximizedFocus,vbNormalNoFocus or vbMinimizedNoFocus
' Usage Example:
' ~~~~~~~~~~~~~~~~
' RunFile("c:\test.bat", vbNormalFocus)
' Revision History:
' ~~~~~~~~~~~~~~~~
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2010-Feb-05             Initial Release
'---------------------------------------------------------------------------------------
Function RunFile(strFile As String, strWndStyle As String)
On Error GoTo Error_Handler
 
    Shell "cmd /k """ & strFile & """", strWndStyle
 
Error_Handler_Exit:
    On Error Resume Next
    Exit Function
 
Error_Handler:
    MsgBox "MS Access has generated the following error" & vbCrLf & vbCrLf & "Error Number: " & _
    Err.Number & vbCrLf & "Error Source: RunFile" & vbCrLf & "Error Description: " & _
    Err.Description, vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Function

Function fncUserGroups() As String
On Error GoTo Error_Handler
' Created and provided by Dirk Goldgar (MS Access MVP)
' NOTE: Requires a reference to the DAO Object Library.
' PURPOSE: Returns a comma-separated list of the security groups of which
'          the current user is a member.

    Dim ws          As DAO.Workspace
    Dim grp         As DAO.Group
    Dim strGroups   As String
 
    Set ws = DBEngine.Workspaces(0)
 
    For Each grp In ws.Users(CurrentUser).Groups
        strGroups = strGroups & ", " & grp.Name
    Next grp
 
    fncUserGroups = Mid(strGroups, 3)
 
Error_Handler_Exit:
    On Error Resume Next
    Set ws = Nothing
    Exit Function
 
Error_Handler:
    MsgBox "MS Access has generated the following error" & vbCrLf & vbCrLf & "Error Number: " & _
    Err.Number & vbCrLf & "Error Source: NoYrs" & vbCrLf & "Error Description: " & _
    Err.Description, vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Function

DoCmd.SendObject acSendNoObject,,,"recipient1@somewhere.com;recipient2@somewhere.com",,,"YourSubject","YourEmailMessage"