Date Calculations in VBA

May 26
2010

I have picked up a number of date function from the web over the years and added some changes for my own use. These pick be useful for your projects

'----------------------------------------------------------------------
' FUNCTION: BeginLastMonth
' PURPOSE  : Returns the last calendar day of last month
'----------------------------------------------------------------------
Function BeginLastMonth()
BeginLastMonth = DateAdd("m", -1, DateSerial(Year(Date), Month(Date), 1))
End Function
 
'----------------------------------------------------------------------
' FUNCTION: BeginNextMonth
' PURPOSE  : Returns the first day of next month
'----------------------------------------------------------------------
Function BeginNextMonth()
BeginNextMonth = DateAdd("m", 1, DateSerial(Year(Date), Month(Date), 1))
End Function
 
'----------------------------------------------------------------------
' FUNCTION: BeginThisMonth
' PURPOSE  : Returns the first day of the current month.
'----------------------------------------------------------------------
Function BeginThisMonth()
BeginThisMonth = DateSerial(Year(Date), Month(Date), 1)
End Function
 
'----------------------------------------------------------------------
' FUNCTION: EndofMonth
' PURPOSE  : Returns the date of the last day of a month/year combination.
'----------------------------------------------------------------------
Function EndofMonth(Vdate) As Variant
 
If IsNull(Vdate) Then Exit Function
 
EndofMonth = DateAdd("M", 1, DateSerial(Year(Vdate), Month(Vdate), 1)) - 1
 
End Function
 
Function EndofThisMonth()
EndofThisMonth = DateAdd("m", 1, DateSerial(Year(Date), Month(Date), 1)) - 1
End Function
 
 
Function EndOfWeek(D As Variant, Optional FirstWeekday As Integer) As Variant
'
' Returns the date representing the last day of the current week.
'
' Arguments:
' D            = Date
' FirstWeekday = (Optional argument) Integer that represents the first
' day of the week (e.g., 1=Sun..7=Sat).
'
If IsMissing(FirstWeekday) Then 'Sunday is the assumed first day of week.
  EndOfWeek = D - WeekDay(D) + 7
Else
  EndOfWeek = D - WeekDay(D, FirstWeekday) + 7
End If
End Function
 
Function StartOfWeek(D As Variant, Optional FirstWeekday As Integer) As Variant
'
' Returns the date representing the last day of the current week.
'
' Arguments:
' D            = Date
' FirstWeekday = (Optional argument) Integer that represents the first
' day of the week (e.g., 1=Sun..7=Sat).
'
If IsMissing(FirstWeekday) Then 'Sunday is the assumed first day of week.
  StartOfWeek = D + WeekDay(D) - 7
Else
  StartOfWeek = D + WeekDay(D, FirstWeekday) - 7
End If
End Function
 
Function ElapsedDays(StartDate As Date, EndDate As Date) As Long
 
    ElapsedDays = Int(CSng(EndDate - StartDate))
 
End Function
 
Function DayName(tmpDay As Integer)
Select Case tmpDay
Case 1
    DayName = "Sunday"
Case 2
    DayName = "Monday"
Case 3
    DayName = "Tuesday"
Case 4
    DayName = "Wednesday"
Case 5
    DayName = "Thursday"
Case 6
    DayName = "Friday"
Case 7
    DayName = "Saturday"
 
End Select
 
End Function
 
 
Function Daynam(tmpDate As Date, Optional tmpS As Boolean)
Dim Day, Dat
tmpFirstDay = GetPref("First Day of Week")
If IsNull(tmpFirstDay) Then
   tmpFirstDay = GetPref("First Day of Week")
End If
Select Case tmpFirstDay
Case 0 ' Sunday
   Day = Array("Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday")
Case 1 ' Sunday
   Day = Array("Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday")
Case 2 ' Monday
   Day = Array("Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday", "Sunday")
Case 3 ' Tuesday
   Day = Array("Tuesday", "Wednesday", "Thursday", "Friday", "Saturday", "Sunday", "Monday")
Case 4 ' Wednesday
   Day = Array("Wednesday", "Thursday", "Friday", "Saturday", "Sunday", "Monday", "Tuesday")
Case 5 ' Thursday
   Day = Array("Thursday", "Friday", "Saturday", "Sunday", "Monday", "Tuesday", "Wednesday")
Case 6 ' Friday
   Day = Array("Friday", "Saturday", "Sunday", "Monday", "Tuesday", "Wednesday", "Thursday")
Case 7 ' Saturday
   Day = Array("Saturday", "Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", "Friday")
End Select
 
If tmpS Then
    Daynam = Left(Day(WeekDay(tmpDate)), 3)
Else
    Daynam = Day(WeekDay(tmpDate))
End If
End Function
 
 
Function getFday()
If IsNull(tmpFirstDay) Or IsEmpty(tmpFirstDay) Then
   tmpFirstDay = GetPref("First Day of Week")
End If
getFday = Val(tmpFirstDay)
End Function

Making your wordpress site smartphone ready

May 19
2010

Check this out http://www.bravenewcode.com/products/wptouch/

Its a brillant plugin for wordpress which serves up a different theme when viewed on a smartphone and your regular web site , check this site out on your touch phone..

Creating an AIB Credits transfer file in VBA

May 10
2010

This is the code I use to create an IBB transfer file, this can be linked to Sage, Syspro, Intact or any Accounting system which allow an ODBC connection. This contains a fe functions such as Getpref which pulls preference data from another table. These can be replaced with static data or your own functions.

The first part makes the the payee file….

 
Function CreatePayeeFile()
On Error GoTo Errorhandler
 
DoCmd.Hourglass True
 
Dim db As Database
Dim rst As Recordset
Dim SqlStr  As String
Dim myfile As Integer, tmpStr As String
Dim tmpfile As String, tmpPath As String
 
Set db = CurrentDb()
Set rst = db.OpenRecordset("qryPayeeExport")
 
'assign variables
'file
myfile = FreeFile
'check file name and path
If Len(GetPref("Payee File Name") & "") = 0 Then
    MsgBox ("File name required, please review setup details")
    GoTo Exit_Func
Else
    tmpPath = GetPref("Export File Path")
    tmpfile = GetPref("Payee File Name")
End If
 
If rst.RecordCount > 0 Then
    'move to the first record
    rst.MoveFirst
    'open the file for output
    Open (tmpPath & "\" & tmpfile) For Output As myfile
    Do While Not rst.EOF
        tmpStr = Chr(34) & rst!V_Payee & Chr(34) & ","
        tmpStr = tmpStr & Chr(34) & rst!V_VendorID & Chr(34) & ","
        tmpStr = tmpStr & Chr(34) & rst!V_Name & Chr(34) & ","
        tmpStr = tmpStr & Chr(34) & rst!V_Address & Chr(34) & ","
        tmpStr = tmpStr & Chr(34) & rst!V_Phone & Chr(34) & ","
        tmpStr = tmpStr & Chr(34) & rst!V_Fax & Chr(34) & ","
        tmpStr = tmpStr & Chr(34) & rst!V_Telex & Chr(34) & ","
        tmpStr = tmpStr & Chr(34) & rst!V_Bank_Name & Chr(34) & ","
        tmpStr = tmpStr & Chr(34) & rst!V_Bank_Code_Type & Chr(34) & ","
        tmpStr = tmpStr & Chr(34) & rst!V_Bank_Code & Chr(34) & ","
        tmpStr = tmpStr & Chr(34) & rst!V_Account_Number & Chr(34) & ","
        tmpStr = tmpStr & Chr(34) & rst!V_International & Chr(34) & ","
        tmpStr = tmpStr & Chr(34) & rst!V_EDIFact_ID & Chr(34) & ","
        tmpStr = tmpStr & Chr(34) & rst!V_EDIFACT_Qualifier & Chr(34) & ","
        tmpStr = tmpStr & Chr(34) & rst!V_Vendor_Ref & Chr(34) & ","
        Print #myfile, tmpStr
        rst.MoveNext
    Loop
    'MsgBox ("File Export Complete")
'Else
    'MsgBox ("No Payee Records to Export")
End If
 
Exit_Func:
 
Set db = Nothing
Set rst = Nothing
DoCmd.Hourglass False
Close #myfile
 
Exit Function
 
Errorhandler:
MsgBox "An Error has Occurred " & vbCrLf & _
        "Error Number :" & Err.Number & vbCrLf & _
        "Details :" & Err.Description
        GoTo Exit_Func
 
 
End Function

The second part creates the payee file

Function CreatePaymentFile()
On Error GoTo Errorhandler
 
DoCmd.Hourglass True
 
Dim db As Database
Dim rst As Recordset
Dim SqlStr  As String
Dim myfile As Integer, tmpStr As String, tmpVer As String
Dim tmpfile As String, tmpPath As String, tmpLine As String, tmpComma
tmpComma = ","
Set db = CurrentDb()
Set rst = db.OpenRecordset("qryPaymentFile")
tmpVer = GetPref("AIB Program Version")
 
'increment the payment run to get a new run number
SetPref "Payment File Name", GetPref("Payment File Name") + 1, "Program", "System"
 
'assign variables
'file
myfile = FreeFile
'check file name and path
If Len(GetPref("Payment File Name") & "") = 0 Then
    MsgBox ("Payment File name required, please review setup details")
    GoTo Exit_Func
Else
    tmpPath = GetPref("Export File Path")
    tmpfile = right("00000000" & GetPref("Payment File Name"), 8) & ".imp"
End If
 
If rst.RecordCount > 0 Then
    'move to the first record
    rst.MoveFirst
    'open the file for output
    Open (tmpPath & "\" & tmpfile) For Output As myfile
    Do While Not rst.EOF
        tmpLine = ""
        tmpLine = tmpLine & rst!PY_Payer & tmpComma                                   'field 1
        tmpLine = tmpLine & "EUR" & tmpComma                                          'field 2
        tmpLine = tmpLine & "WT" & tmpComma                                           'field 3
        tmpLine = tmpLine & "SHA" & tmpComma                                          'field 4
        tmpLine = tmpLine & rst!PY_Currency & tmpComma                                'field 5
        tmpLine = tmpLine & rst!PY_Amount & tmpComma                                  'field 6
        tmpLine = tmpLine & Format(rst!PY_ValueDate, "DD-MM-YYYY") & tmpComma         'field 7
        tmpLine = tmpLine & Left(RegReplace(rst!V_Name) & "", 35) & tmpComma          'field 8
        tmpLine = tmpLine & Left(RegReplace(rst!V_Address) & "", 35) & tmpComma       'field 9
        tmpLine = tmpLine & "" & tmpComma   'second address line blank                'field 10
        tmpLine = tmpLine & rst!PY_Reference & tmpComma                               'field 11
        tmpLine = tmpLine & "" & tmpComma   'optional unique ref                      'field 12
        tmpLine = tmpLine & rst!V_Account_Number & tmpComma   'Bank account           'field 13
        
        If IsNumeric(Left(rst!V_Bank_Code, 1)) = False Then
            tmpLine = tmpLine & rst!V_Bank_Code & tmpComma   'Bank code               'field 14
            tmpLine = tmpLine & "" & tmpComma   'bank clearing code if no iban        'field 15
            tmpLine = tmpLine & "" & tmpComma   'party bank clearing code if 15 is p  'field 16
        Else
            tmpLine = tmpLine & "" & tmpComma   'Bank code               'field 14
            tmpLine = tmpLine & rst!V_Bank_Code & tmpComma   '                   'field 15
            tmpLine = tmpLine & rst!V_Bank_Code_Type & tmpComma   'party bank clearing code if 15 is pop'field 16
        End If
        tmpLine = tmpLine & rst!V_CountryCode & tmpComma   'bank country code         'field 17
        tmpLine = tmpLine & "" & tmpComma   'optional                                 'field 18
        tmpLine = tmpLine & "" & tmpComma   'optional                                 'field 19
        tmpLine = tmpLine & "" & tmpComma   'optional                                 'field 20
        tmpLine = tmpLine & "" & tmpComma   'optional                                 'field 21
        tmpLine = tmpLine & "" & tmpComma   'optional                                 'field 22
        tmpLine = tmpLine & ""              'optional                                 'field 23
                
 
        Print #myfile, tmpLine
 
        rst.MoveNext
    Loop
   If MsgBox("Print Reports ", vbYesNo) = vbYes Then
        DoCmd.OpenReport "your reports...."      
   End If
    MsgBox ("File Export Complete")
Else
    MsgBox ("No Payment Records to Export")
End If
 
Exit_Func:
 
Set db = Nothing
Set rst = Nothing
 
DoCmd.Hourglass False
 
Close #myfile
 
Exit Function
 
Errorhandler:
MsgBox "An Error has Occurred " & vbCrLf & _
        "Error Number :" & Err.Number & vbCrLf & _
        "Details :" & Err.Description
        GoTo Exit_Func
 
 
End Function

10+ reasons why IT pros hate Microsoft Access..

May 05
2010

10+ reasons why IT pros hate Microsoft Access (but really shouldn’t)
This is a link to the article by Susan Harkins on TechRepublic.

Its an interesting read whatever side of the fence you are on

http://blogs.techrepublic.com.com/10things/?p=386

Idle Backup

May 01
2010

Here is a simple way to keep your important documents and data backed up

http://idlebackup.nl/

If you need some help on a project drop leave a comment on the post and I will reply.