MI HAYATUL ISLAM: Advanced VBA

Breaking News

Showing posts with label Advanced VBA. Show all posts

Monday, October 8, 2012

VBA : Creating Custom Data type

here is a code to Create your own type of variable :

Sunday, June 24, 2012

Ex24: VBA - GetName of AutoNumber using DAO

Get the name of the AutoNumber field, using DAO.

Option Compare Database
Option Explicit

'Constants for examining how a field is indexed.
Private Const intcIndexNone As Integer = 0
Private Const intcIndexGeneral As Integer = 1
Private Const intcIndexUnique As Integer = 3
Private Const intcIndexPrimary As Integer = 7

Function GetAutoNumDAO(strTable) As String
    'Purpose:   Get the name of the AutoNumber field, using DAO.
    Dim db As DAO.Database
    Dim tdf As DAO.TableDef
    Dim fld As DAO.Field
    
    Set db = CurrentDb()
    Set tdf = db.TableDefs(strTable)
    
    For Each fld In tdf.Fields
        If (fld.Attributes And dbAutoIncrField) <> 0 Then
            GetAutoNumDAO = fld.Name
            Exit For
        End If
    Next
    
    Set fld = Nothing
    Set tdf = Nothing
    Set db = Nothing
End Function

Ex23: VBA - Execute SQL using DAO

Execute the SQL statement on the current database in a transaction using DAO in VBA

Option Compare Database
Option Explicit

'Constants for examining how a field is indexed.
Private Const intcIndexNone As Integer = 0
Private Const intcIndexGeneral As Integer = 1
Private Const intcIndexUnique As Integer = 3
Private Const intcIndexPrimary As Integer = 7

Public Function ExecuteInTransaction(strSql As String, Optional strConfirmMessage As String) As Long
On Error GoTo Err_Handler
    'Purpose:   Execute the SQL statement on the current database in a transaction.
    'Return:    RecordsAffected if zero or above.
    'Arguments: strSql = the SQL statement to be executed.
    '           strConfirmMessage = the message to show the user for confirmation. Number will be added to front.
    '           No confirmation if ZLS.
    '           -1 on error.
    '           -2 on user-cancel.
    Dim ws As DAO.Workspace
    Dim db As DAO.Database
    Dim bInTrans As Boolean
    Dim bCancel As Boolean
    Dim strMsg As String
    Dim lngReturn As Long
    Const lngcUserCancel = -2&
    
    Set ws = DBEngine(0)
    ws.BeginTrans
    bInTrans = True
    Set db = ws(0)
    db.Execute strSql, dbFailOnError
    lngReturn = db.RecordsAffected
    If strConfirmMessage <> vbNullString Then
        If MsgBox(lngReturn & " " & Trim$(strConfirmMessage), vbOKCancel + vbQuestion, "Confirm") <> vbOK Then
            bCancel = True
            lngReturn = lngcUserCancel
        End If
    End If
    
    'Commmit or rollback.
    If bCancel Then
        ws.Rollback
    Else
        ws.CommitTrans
    End If
    bInTrans = False

Exit_Handler:
    ExecuteInTransaction = lngReturn
    On Error Resume Next
    Set db = Nothing
    If bInTrans Then
        ws.Rollback
    End If
    Set ws = Nothing
    Exit Function

Err_Handler:
    MsgBox "Error " & Err.Number & ": " & Err.Description, vbExclamation, "ExecuteInTransaction()"
    lngReturn = -1
    Resume Exit_Handler
End Function

Ex22: VBA - Show form properties using DAO

Loop through the controls on a form, showing names and properties using DAO in VBA

Option Compare Database
Option Explicit

'Constants for examining how a field is indexed.
Private Const intcIndexNone As Integer = 0
Private Const intcIndexGeneral As Integer = 1
Private Const intcIndexUnique As Integer = 3
Private Const intcIndexPrimary As Integer = 7

Function ShowFormProperties(strFormName As String)
On Error GoTo Err_Handler
    'Purpose:   Loop through the controls on a form, showing names and properties.
    'Usage:     Call ShowFormProperties("Form1")
    Dim frm As Form
    Dim ctl As Control
    Dim prp As Property
    Dim strOut As String
    
    DoCmd.OpenForm strFormName, acDesign, WindowMode:=acHidden
    Set frm = Forms(strFormName)
    
    For Each ctl In frm
        For Each prp In ctl.Properties
            strOut = strFormName & "." & ctl.Name & "." & prp.Name & ": "
            strOut = strOut & prp.Type & vbTab
            strOut = strOut & prp.Value
            Debug.Print strOut
        Next
        If ctl.ControlType = acTextBox Then Stop
    Next
    
    Set frm = Nothing
    DoCmd.Close acForm, strFormName, acSaveNo

Exit_Handler:
    Exit Function

Err_Handler:
    Select Case Err.Number
    Case 2186:
        strOut = strOut & Err.Description
        Resume Next
    Case Else
        MsgBox "Error " & Err.Number & ": " & Err.Description, vbExclamation, "ShowFormProperties()"
        Resume Exit_Handler
    End Select
End Function

Ex21: VBA - Open & Loop through records using DAO

How to open a recordset and loop through the records using DAO in VBA

Option Compare Database
Option Explicit

'Constants for examining how a field is indexed.
Private Const intcIndexNone As Integer = 0
Private Const intcIndexGeneral As Integer = 1
Private Const intcIndexUnique As Integer = 3
Private Const intcIndexPrimary As Integer = 7

Function DAORecordsetExample()
    'Purpose:   How to open a recordset and loop through the records.
    'Note:      Requires a table named MyTable, with a field named MyField.
    Dim rs As DAO.Recordset
    Dim strSql As String
    
    strSql = "SELECT MyField FROM MyTable;"
    Set rs = DBEngine(0)(0).OpenRecordset(strSql)
    
    Do While Not rs.EOF
        Debug.Print rs!MyField
        rs.MoveNext
    Loop
    
    rs.Close
    Set rs = Nothing
End Function

Ex20: VBA - Convert numeric results using DAO

Converts the numeric results of DAO fieldtype to text using DAO in VBA

Option Compare Database
Option Explicit

'Constants for examining how a field is indexed.
Private Const intcIndexNone As Integer = 0
Private Const intcIndexGeneral As Integer = 1
Private Const intcIndexUnique As Integer = 3
Private Const intcIndexPrimary As Integer = 7

Public Function FieldTypeName(fld As DAO.Field)
    'Purpose: Converts the numeric results of DAO fieldtype to text.
    'Note:    fld.Type is Integer, but the constants are Long.
    Dim strReturn As String         'Name to return
    
    Select Case CLng(fld.Type)
        Case dbBoolean: strReturn = "Yes/No"            ' 1
        Case dbByte: strReturn = "Byte"                 ' 2
        Case dbInteger: strReturn = "Integer"           ' 3
        Case dbLong                                     ' 4
            If (fld.Attributes And dbAutoIncrField) = 0& Then
                strReturn = "Long Integer"
            Else
                strReturn = "AutoNumber"
            End If
        Case dbCurrency: strReturn = "Currency"         ' 5
        Case dbSingle: strReturn = "Single"             ' 6
        Case dbDouble: strReturn = "Double"             ' 7
        Case dbDate: strReturn = "Date/Time"            ' 8
        Case dbBinary: strReturn = "Binary"             ' 9 (no interface)
        Case dbText                                     '10
            If (fld.Attributes And dbFixedField) = 0& Then
                strReturn = "Text"
            Else
                strReturn = "Text (fixed width)"
            End If
        Case dbLongBinary: strReturn = "OLE Object"     '11
        Case dbMemo                                     '12
            If (fld.Attributes And dbHyperlinkField) = 0& Then
                strReturn = "Memo"
            Else
                strReturn = "Hyperlink"
            End If
        Case dbGUID: strReturn = "GUID"                 '15
        
        'Attached tables only: cannot create these in JET.
        Case dbBigInt: strReturn = "Big Integer"        '16
        Case dbVarBinary: strReturn = "VarBinary"       '17
        Case dbChar: strReturn = "Char"                 '18
        Case dbNumeric: strReturn = "Numeric"           '19
        Case dbDecimal: strReturn = "Decimal"           '20
        Case dbFloat: strReturn = "Float"               '21
        Case dbTime: strReturn = "Time"                 '22
        Case dbTimeStamp: strReturn = "Time Stamp"      '23
        
        'Constants for complex types don't work prior to Access 2007.
        Case 101&: strReturn = "Attachment"         'dbAttachment
        Case 102&: strReturn = "Complex Byte"       'dbComplexByte
        Case 103&: strReturn = "Complex Integer"    'dbComplexInteger
        Case 104&: strReturn = "Complex Long"       'dbComplexLong
        Case 105&: strReturn = "Complex Single"     'dbComplexSingle
        Case 106&: strReturn = "Complex Double"     'dbComplexDouble
        Case 107&: strReturn = "Complex GUID"       'dbComplexGUID
        Case 108&: strReturn = "Complex Decimal"    'dbComplexDecimal
        Case 109&: strReturn = "Complex Text"       'dbComplexText
        Case Else: strReturn = "Field type " & fld.Type & " unknown"
    End Select
    
    FieldTypeName = strReturn
End Function

Ex19: VBA - Read table records using DAO

How to read the field names and types from a table or query.

Option Compare Database
Option Explicit

'Constants for examining how a field is indexed.
Private Const intcIndexNone As Integer = 0
Private Const intcIndexGeneral As Integer = 1
Private Const intcIndexUnique As Integer = 3
Private Const intcIndexPrimary As Integer = 7

Function ShowFieldsRS(strTable)
    'Purpose:   How to read the field names and types from a table or query.
    'Usage:     Call ShowFieldsRS("Table1")
    Dim rs As DAO.Recordset
    Dim fld As DAO.Field
    Dim strSql As String
    
    strSql = "SELECT " & strTable & ".* FROM " & strTable & " WHERE (False);"
    Set rs = DBEngine(0)(0).OpenRecordset(strSql)
    For Each fld In rs.Fields
        Debug.Print fld.Name, FieldTypeName(fld), "from " & fld.SourceTable & "." & fld.SourceField
    Next
    rs.Close
    Set rs = Nothing
End Function

Ex18: VBA - Read fields using DAO

How to read the fields of a table using DAO in VBA

Option Compare Database
Option Explicit

'Constants for examining how a field is indexed.
Private Const intcIndexNone As Integer = 0
Private Const intcIndexGeneral As Integer = 1
Private Const intcIndexUnique As Integer = 3
Private Const intcIndexPrimary As Integer = 7

Function ShowFields(strTable As String)
    'Purpose:   How to read the fields of a table.
    'Usage:     Call ShowFields("Table1")
    Dim db As DAO.Database
    Dim tdf As DAO.TableDef
    Dim fld As DAO.Field
    
    Set db = CurrentDb()
    Set tdf = db.TableDefs(strTable)
    For Each fld In tdf.Fields
        Debug.Print fld.Name, FieldTypeName(fld)
    Next
    
    Set fld = Nothing
    Set tdf = Nothing
    Set db = Nothing
End Function

Ex17: VBA - Show DB properties using DAO

List the properties of the current database using DAO in VBA

Option Compare Database
Option Explicit

'Constants for examining how a field is indexed.
Private Const intcIndexNone As Integer = 0
Private Const intcIndexGeneral As Integer = 1
Private Const intcIndexUnique As Integer = 3
Private Const intcIndexPrimary As Integer = 7

Function ShowDatabaseProps()
    'Purpose:   List the properies of the current database.
    Dim db As DAO.Database
    Dim prp As DAO.Property
    
    Set db = CurrentDb()
    For Each prp In db.Properties
        Debug.Print prp.Name
    Next
    
    Set db = Nothing
End Function

Ex16: VBA - Create new database using DAO

Create a new database programmatically, and set its key properties using DAO in VBA

Option Compare Database
Option Explicit

'Constants for examining how a field is indexed.
Private Const intcIndexNone As Integer = 0
Private Const intcIndexGeneral As Integer = 1
Private Const intcIndexUnique As Integer = 3
Private Const intcIndexPrimary As Integer = 7

Function CreateDatabaseDAO()
    'Purpose:   How to create a new database and set key properties.
    Dim dbNew As DAO.Database
    Dim prp As DAO.Property
    Dim strFile As String
    
    'Create the new database.
    strFile = "C:\SampleDAO.mdb"
    Set dbNew = DBEngine(0).CreateDatabase(strFile, dbLangGeneral)
    
    'Create example properties in new database.
    With dbNew
        Set prp = .CreateProperty("Perform Name AutoCorrect", dbLong, 0)
        .Properties.Append prp
        Set prp = .CreateProperty("Track Name AutoCorrect Info", _
            dbLong, 0)
        .Properties.Append prp
    End With
    
    'Clean up.
    dbNew.Close
    Set prp = Nothing
    Set dbNew = Nothing
    Debug.Print "Created " & strFile
End Function

Ex15: VBA - Create a query using DAO

Create a query programmatically using DAO in VBA

Option Compare Database
Option Explicit

'Constants for examining how a field is indexed.
Private Const intcIndexNone As Integer = 0
Private Const intcIndexGeneral As Integer = 1
Private Const intcIndexUnique As Integer = 3
Private Const intcIndexPrimary As Integer = 7

Function CreateQueryDAO()
    'Purpose:   How to create a query
    'Note:      Requires a table named MyTable.
    Dim db As DAO.Database
    Dim qdf As DAO.QueryDef
    
    Set db = CurrentDb()
    
    'The next line creates and automatically appends the QueryDef.
    Set qdf = db.CreateQueryDef("qryMyTable")
    
    'Set the SQL property to a string representing a SQL statement.
    qdf.SQL = "SELECT MyTable.* FROM MyTable;"
    
    'Do not append: QueryDef is automatically appended!

    Set qdf = Nothing
    Set db = Nothing
    Debug.Print "qryMyTable created."
End Function

Ex14: VBA - Index on field using DAO

Indicate if there is a single-field index using DAO in VBA

Option Compare Database
Option Explicit

'Constants for examining how a field is indexed.
Private Const intcIndexNone As Integer = 0
Private Const intcIndexGeneral As Integer = 1
Private Const intcIndexUnique As Integer = 3
Private Const intcIndexPrimary As Integer = 7

Private Function IndexOnField(tdf As DAO.TableDef, fld As DAO.Field) _
As Integer
    'Purpose:   Indicate if there is a single-field index _
    '               on this field in this table.
    'Return:    The constant indicating the strongest type.
    Dim ind As DAO.Index
    Dim intReturn As Integer
    
    intReturn = intcIndexNone
    
    For Each ind In tdf.Indexes
        If ind.Fields.Count = 1 Then
            If ind.Fields(0).Name = fld.Name Then
                If ind.Primary Then
                    intReturn = (intReturn Or intcIndexPrimary)
                ElseIf ind.Unique Then
                    intReturn = (intReturn Or intcIndexUnique)
                Else
                    intReturn = (intReturn Or intcIndexGeneral)
                End If
            End If
        End If
    Next
    
    'Clean up
    Set ind = Nothing
    IndexOnField = intReturn
End Function

Ex13: VBA - Set field description using DAO

Assign a Description to a field using DAO in VBA

Option Compare Database
Option Explicit

'Constants for examining how a field is indexed.
Private Const intcIndexNone As Integer = 0
Private Const intcIndexGeneral As Integer = 1
Private Const intcIndexUnique As Integer = 3
Private Const intcIndexPrimary As Integer = 7

Function SetFieldDescription(tdf As DAO.TableDef, fld As DAO.Field, _
Optional ByVal strDescrip As String, Optional strErrMsg As String) _
As Boolean
    'Purpose:   Assign a Description to a field.
    'Arguments: tdf = the TableDef the field belongs to.
    '           fld = the field to document.
    '           strDescrip = The description text you want.
    '                        If blank, uses Caption or Name of field.
    '           strErrMsg  = string to append any error messages to.
    'Notes:     Description includes field size, validation,
    '               whether required or unique.
    
    If (fld.Attributes And dbAutoIncrField) > 0& Then
        strDescrip = strDescrip & " Automatically generated " & _
            "unique identifier for this record."
    Else
        'If no description supplied, use the field's Caption or Name.
        If Len(strDescrip) = 0& Then
            If HasProperty(fld, "Caption") Then
                If Len(fld.Properties("Caption")) > 0& Then
                    strDescrip = fld.Properties("Caption") & "."
                End If
            End If
            If Len(strDescrip) = 0& Then
                strDescrip = fld.Name & "."
            End If
        End If
        
        'Size of the field.
        'Ignore Date, Memo, Yes/No, Currency, Decimal, GUID,
        '   Hyperlink, OLE Object.
        Select Case fld.Type
        Case dbByte, dbInteger, dbLong
            strDescrip = strDescrip & " Whole number."
        Case dbSingle, dbDouble
            strDescrip = strDescrip & " Fractional number."
        Case dbText
            strDescrip = strDescrip & " " & fld.Size & "-char max."
        End Select
        
        'Required and/or Unique?
        'Check for single-field index, and Required property.
        Select Case IndexOnField(tdf, fld)
        Case intcIndexPrimary
            strDescrip = strDescrip & " Required. Unique."
        Case intcIndexUnique
            If fld.Required Then
                strDescrip = strDescrip & " Required. Unique."
            Else
                strDescrip = strDescrip & " Unique."
            End If
        Case Else
            If fld.Required Then
                strDescrip = strDescrip & " Required."
            End If
        End Select
        
        'Validation?
        If Len(fld.ValidationRule) > 0& Then
            If Len(fld.ValidationText) > 0& Then
                strDescrip = strDescrip & " " & fld.ValidationText
            Else
                strDescrip = strDescrip & " " & fld.ValidationRule
            End If
        End If
    End If
    
    If Len(strDescrip) > 0& Then
        strDescrip = Trim$(Left$(strDescrip, 255&))
        SetFieldDescription = SetPropertyDAO(fld, "Description", _
            dbText, strDescrip, strErrMsg)
    End If
End Function

Ex12: VBA - Proper() function using DAO

Convert mixed case name into a name with spaces using DAO in VBA

Option Compare Database
Option Explicit

'Constants for examining how a field is indexed.
Private Const intcIndexNone As Integer = 0
Private Const intcIndexGeneral As Integer = 1
Private Const intcIndexUnique As Integer = 3
Private Const intcIndexPrimary As Integer = 7

Function ConvertMixedCase(ByVal strIn As String) As String
    'Purpose:   Convert mixed case name into a name with spaces.
    'Argument:  String to convert.
    'Return:    String converted by these rules:
    '           1. One space before an upper case letter.
    '           2. Replace underscores with spaces.
    '           3. No spaces between continuing upper case.
    'Example:   "FirstName" or "First_Name" => "First Name".
    Dim lngStart As Long        'Loop through string.
    Dim strOut As String        'Output string.
    Dim boolWasSpace As Boolean 'Last char. was a space.
    Dim boolWasUpper As Boolean 'Last char. was upper case.
    
    strIn = Trim$(strIn)        'Remove leading/trailing spaces.
    boolWasUpper = True         'Initialize for no first space.
    
    For lngStart = 1& To Len(strIn)
        Select Case Asc(Mid(strIn, lngStart, 1&))
        Case vbKeyA To vbKeyZ   'Upper case: insert a space.
            If boolWasSpace Or boolWasUpper Then
                strOut = strOut & Mid(strIn, lngStart, 1&)
            Else
                strOut = strOut & " " & Mid(strIn, lngStart, 1&)
            End If
            boolWasSpace = False
            boolWasUpper = True
            
        Case 95                 'Underscore: replace with space.
            If Not boolWasSpace Then
                strOut = strOut & " "
            End If
            boolWasSpace = True
            boolWasUpper = False
            
        Case vbKeySpace         'Space: output and set flag.
            If Not boolWasSpace Then
                strOut = strOut & " "
            End If
            boolWasSpace = True
            boolWasUpper = False
            
        Case Else               'Any other char: output.
            strOut = strOut & Mid(strIn, lngStart, 1&)
            boolWasSpace = False
            boolWasUpper = False
        End Select
    Next
    
    ConvertMixedCase = strOut
End Function

Ex11: VBA - Set default properties using DAO

Properties you always want set by default using DAO in VBA

Option Compare Database
Option Explicit

'Constants for examining how a field is indexed.
Private Const intcIndexNone As Integer = 0
Private Const intcIndexGeneral As Integer = 1
Private Const intcIndexUnique As Integer = 3
Private Const intcIndexPrimary As Integer = 7

Function StandardProperties(strTableName As String)
    'Purpose:   Properties you always want set by default:
    '           TableDef:        Subdatasheets off.
    '           Numeric fields:  Remove Default Value.
    '           Currency fields: Format as currency.
    '           Yes/No fields:   Display as check box. Default to No.
    '           Text/memo/hyperlink: AllowZeroLength off,
    '                                UnicodeCompression on.
    '           All fields:      Add a caption if mixed case.
    'Argument:  Name of the table.
    'Note:      Requires: SetPropertyDAO()
    Dim db As DAO.Database      'Current database.
    Dim tdf As DAO.TableDef     'Table nominated in argument.
    Dim fld As DAO.Field        'Each field.
    Dim strCaption As String    'Field caption.
    Dim strErrMsg As String     'Responses and error messages.
    
    'Initalize.
    Set db = CurrentDb()
    Set tdf = db.TableDefs(strTableName)
    
    'Set the table's SubdatasheetName.
    Call SetPropertyDAO(tdf, "SubdatasheetName", dbText, "[None]", _
        strErrMsg)
    
    For Each fld In tdf.Fields
        'Handle the defaults for the different field types.
        Select Case fld.Type
        Case dbText, dbMemo 'Includes hyperlinks.
            fld.AllowZeroLength = False
            Call SetPropertyDAO(fld, "UnicodeCompression", dbBoolean, _
                True, strErrMsg)
        Case dbCurrency
            fld.DefaultValue = 0
            Call SetPropertyDAO(fld, "Format", dbText, "Currency", _
                strErrMsg)
        Case dbLong, dbInteger, dbByte, dbDouble, dbSingle, dbDecimal
            fld.DefaultValue = vbNullString
        Case dbBoolean
            Call SetPropertyDAO(fld, "DisplayControl", dbInteger, _
                CInt(acCheckBox))
        End Select
        
        'Set a caption if needed.
        strCaption = ConvertMixedCase(fld.Name)
        If strCaption <> fld.Name Then
            Call SetPropertyDAO(fld, "Caption", dbText, strCaption)
        End If
        
        'Set the field's Description.
        Call SetFieldDescription(tdf, fld, , strErrMsg)
    Next
    
    'Clean up.
    Set fld = Nothing
    Set tdf = Nothing
    Set db = Nothing
    If Len(strErrMsg) > 0 Then
        Debug.Print strErrMsg
    Else
        Debug.Print "Properties set for table " & strTableName
    End If
End Function

Ex10: VBA - Return Object property using DAO

Return true if the object has the property using DAO in VBA

Option Compare Database
Option Explicit

'Constants for examining how a field is indexed.
Private Const intcIndexNone As Integer = 0
Private Const intcIndexGeneral As Integer = 1
Private Const intcIndexUnique As Integer = 3
Private Const intcIndexPrimary As Integer = 7

Public Function HasProperty(obj As Object, strPropName As String) As Boolean
    'Purpose:   Return true if the object has the property.
    Dim varDummy As Variant
    
    On Error Resume Next
    varDummy = obj.Properties(strPropName)
    HasProperty = (Err.Number = 0)
End Function

Ex9: VBA - Set Object property using DAO

Set a property for an object, creating if necessary using DAO in VBA

Option Compare Database
Option Explicit

'Constants for examining how a field is indexed.
Private Const intcIndexNone As Integer = 0
Private Const intcIndexGeneral As Integer = 1
Private Const intcIndexUnique As Integer = 3
Private Const intcIndexPrimary As Integer = 7

Function SetPropertyDAO(obj As Object, strPropertyName As String, intType As Integer, _
    varValue As Variant, Optional strErrMsg As String) As Boolean
On Error GoTo ErrHandler
    'Purpose:   Set a property for an object, creating if necessary.
    'Arguments: obj = the object whose property should be set.
    '           strPropertyName = the name of the property to set.
    '           intType = the type of property (needed for creating)
    '           varValue = the value to set this property to.
    '           strErrMsg = string to append any error message to.
    
    If HasProperty(obj, strPropertyName) Then
        obj.Properties(strPropertyName) = varValue
    Else
        obj.Properties.Append obj.CreateProperty(strPropertyName, intType, varValue)
    End If
    SetPropertyDAO = True

ExitHandler:
    Exit Function

ErrHandler:
    strErrMsg = strErrMsg & obj.Name & "." & strPropertyName & " not set to " & varValue & _
        ". Error " & Err.Number & " - " & Err.Description & vbCrLf
    Resume ExitHandler
End Function