PAYEsoft Forum
PAYEsoft Forum
Home | Profile | Register | Active Topics | Members | Search | FAQ
Username:
Password:
Save Password
 All Forums
 Payroll Software Developers
 Code Snippets
 How do I generate an IRMark for HMRC?
 Forum Locked
 Printer Friendly
Author  Topic   

peeweethe2nd

3 Posts

Posted - 21 April 2013 :  09:31:02  Show Profile
Is there any example code for generating the IRMark for the XML file sent to HMRC?

quote:
You know he’s a really good tax accountant when he’s got a loophole named after him.

Peter Gransden

United Kingdom
4 Posts

Posted - 21 April 2013 :  09:35:51  Show Profile  Visit Peter Gransden's Homepage
Yes there are two examples, a VB.Net version from http://www.jack-frost.co.uk/vb_net_c14n_sha1_irmark.html and one I will post under this topic in VB6.

quote:
If debugging is the process of removing software bugs, then programming must be the process of putting them in - Edsger Dijkstra.
Go to Top of Page

Peter Gransden

United Kingdom
4 Posts

Posted - 21 April 2013 :  10:24:04  Show Profile  Visit Peter Gransden's Homepage
This is the VB6 source code for generating the IRMark.

Remember you are only passing the body of the submission into the IRMark function. Including the Body tags and any indents (tabs).
For example:

	<Body>
		<IRenvelope xmlns="http://www.govtalk.gov.uk/taxation/PAYE/RTI/FullPaymentSubmission/13-14/2">
			<IRheader>
				<Keys>
					<Key Type="TaxOfficeNumber">841</Key>
					<Key Type="TaxOfficeReference">A841</Key>
				</Keys>
				<PeriodEnd>2014-04-05</PeriodEnd>
				<DefaultCurrency>GBP</DefaultCurrency>
				<IRmark Type="generic">0</IRmark>
				<Sender>Agent</Sender>
			</IRheader>
			<FullPaymentSubmission>
				<EmpRefs>
					<OfficeNo>841</OfficeNo>
					<PayeRef>A841</PayeRef>
					<AORef>123PQ7654321X</AORef>
				</EmpRefs>
				<RelatedTaxYear>13-14</RelatedTaxYear>
				<Employee>
					<EmployeeDetails>
						<NINO>AA123456A</NINO>
						<Name>
							<Ttl>Mr</Ttl>
							<Initials>P</Initials>
							<Sur>Gransden</Sur>
						</Name>
						<BirthDate>1971-06-05</BirthDate>
						<Gender>M</Gender>
					</EmployeeDetails>
					<Employment>
						<PayId>123456</PayId>
						<FiguresToDate>
							<TaxablePay>5740.00</TaxablePay>
							<TotalTax>833.00</TotalTax>
							<EmpeePenContribnsPaidYTD>150.00</EmpeePenContribnsPaidYTD>
						</FiguresToDate>
						<Payment>
							<PayFreq>M1</PayFreq>
							<PmtDate>2013-04-25</PmtDate>
							<MonthNo>2</MonthNo>
							<PeriodsCovered>1</PeriodsCovered>
							<HoursWorked>A</HoursWorked>
							<TaxCode>944L</TaxCode>
							<TaxablePay>2870.00</TaxablePay>
							<NonTaxOrNICPmt>10.00</NonTaxOrNICPmt>
							<DednsFromNetPay>20.00</DednsFromNetPay>
							<PayAfterStatDedns>2350.92</PayAfterStatDedns>
							<EmpeePenContribnsPaid>150.00</EmpeePenContribnsPaid>
							<ItemsSubjectToClass1NIC>10.00</ItemsSubjectToClass1NIC>
							<TaxDeductedOrRefunded>416.60</TaxDeductedOrRefunded>
							<SMPYTD>10.00</SMPYTD>
							<SAPYTD>10.00</SAPYTD>
						</Payment>
						<NIlettersAndValues>
							<NIletter>A</NIletter>
							<GrossEarningsForNICsInPd>3000.00</GrossEarningsForNICsInPd>
							<GrossEarningsForNICsYTD>6000.00</GrossEarningsForNICsYTD>
							<AtLELYTD>473.00</AtLELYTD>
							<LELtoPTYTD>173.00</LELtoPTYTD>
							<PTtoUAPYTD>2354.00</PTtoUAPYTD>
							<UAPtoUELYTD>0.00</UAPtoUELYTD>
							<TotalEmpNICInPd>325.54</TotalEmpNICInPd>
							<TotalEmpNICYTD>651.08</TotalEmpNICYTD>
							<EmpeeContribnsInPd>282.48</EmpeeContribnsInPd>
							<EmpeeContribnsYTD>564.96</EmpeeContribnsYTD>
						</NIlettersAndValues>
					</Employment>
				</Employee>
			</FullPaymentSubmission>
		</IRenvelope>
	</Body>

In this example "<IRmark Type=""generic"">0</IRmark>" is already in the body when its passed to the IRMark function.
Add it back later with the IRmark generated, for example:
"<IRmark Type="generic">hx/FFykHZWbaPMxUDX7w3FHdG/4=</IRmark>"

Copy and past this into a module or form.

Option Explicit
Private Const clOneMask = 16515072          '000000 111111 111111 111111
Private Const clTwoMask = 258048            '111111 000000 111111 111111
Private Const clThreeMask = 4032            '111111 111111 000000 111111
Private Const clFourMask = 63               '111111 111111 111111 000000
Private Const clHighMask = 16711680         '11111111 00000000 00000000
Private Const clMidMask = 65280             '00000000 11111111 00000000
Private Const clLowMask = 255               '00000000 00000000 11111111
Private Const cl2Exp18 = 262144             '2 to the 18th power
Private Const cl2Exp12 = 4096               '2 to the 12th
Private Const cl2Exp6 = 64                  '2 to the 6th
Private Const cl2Exp8 = 256                 '2 to the 8th
Private Const cl2Exp16 = 65536              '2 to the 16th

Public Function IRMark(sBody As String) As String
Dim SHA1Hash As New SHA1Hash
Dim Normalized As String
Dim RawHash As String
Dim HASH As String
Dim Test As String
Dim x As Long
    
    Normalized = Replace(sBody, vbCrLf, vbLf)
    Normalized = Replace(Normalized, vbCr, vbLf)
    Normalized = Trim(Mid(Normalized, 1, Len(Normalized) - 1))
    Normalized = Replace(Normalized, "<IRmark Type=""generic"">0</IRmark>", "")
    
    RawHash = SHA1Hash.HashBytes(StrConv(Normalized, vbFromUnicode))
    For x = 1 To Len(RawHash) Step 2
        HASH = HASH & Chr(Val("&H" & Mid(RawHash, x, 2)))
    Next x
    IRMark = Encode64(HASH)

End Function

Private Function Encode64(sString As String) As String

    Dim bTrans(63) As Byte, lPowers8(255) As Long, lPowers16(255) As Long, bOut() As Byte, bIn() As Byte
    Dim lChar As Long, lTrip As Long, iPad As Integer, lLen As Long, lTemp As Long, lPos As Long, lOutSize As Long
    
    For lTemp = 0 To 63                                 'Fill the translation table.
        Select Case lTemp
            Case 0 To 25
                bTrans(lTemp) = 65 + lTemp              'A - Z
            Case 26 To 51
                bTrans(lTemp) = 71 + lTemp              'a - z
            Case 52 To 61
                bTrans(lTemp) = lTemp - 4               '1 - 0
            Case 62
                bTrans(lTemp) = 43                      'Chr(43) = "+"
            Case 63
                bTrans(lTemp) = 47                      'Chr(47) = "/"
        End Select
    Next lTemp

    For lTemp = 0 To 255                                'Fill the 2^8 and 2^16 lookup tables.
        lPowers8(lTemp) = lTemp * cl2Exp8
        lPowers16(lTemp) = lTemp * cl2Exp16
    Next lTemp

    iPad = Len(sString) Mod 3                           'See if the length is divisible by 3
    If iPad Then                                        'If not, figure out the end pad and resize the input.
        iPad = 3 - iPad
        sString = sString & String(iPad, Chr(0))
    End If

    bIn = StrConv(sString, vbFromUnicode)               'Load the input string.
    lLen = ((UBound(bIn) + 1) \ 3) * 4                  'Length of resulting string.
    lTemp = lLen \ 72                                   'Added space for vbCrLfs.
    lOutSize = ((lTemp * 2) + lLen) - 1                 'Calculate the size of the output buffer.
    ReDim bOut(lOutSize)                                'Make the output buffer.
    
    lLen = 0                                            'Reusing this one, so reset it.
    
    For lChar = LBound(bIn) To UBound(bIn) Step 3
        lTrip = lPowers16(bIn(lChar)) + lPowers8(bIn(lChar + 1)) + bIn(lChar + 2)    'Combine the 3 bytes
        lTemp = lTrip And clOneMask                     'Mask for the first 6 bits
        bOut(lPos) = bTrans(lTemp \ cl2Exp18)           'Shift it down to the low 6 bits and get the value
        lTemp = lTrip And clTwoMask                     'Mask for the second set.
        bOut(lPos + 1) = bTrans(lTemp \ cl2Exp12)       'Shift it down and translate.
        lTemp = lTrip And clThreeMask                   'Mask for the third set.
        bOut(lPos + 2) = bTrans(lTemp \ cl2Exp6)        'Shift it down and translate.
        bOut(lPos + 3) = bTrans(lTrip And clFourMask)   'Mask for the low set.
        If lLen = 68 Then                               'Ready for a newline
            bOut(lPos + 4) = 13                         'Chr(13) = vbCr
            bOut(lPos + 5) = 10                         'Chr(10) = vbLf
            lLen = 0                                    'Reset the counter
            lPos = lPos + 6
        Else
            lLen = lLen + 4
            lPos = lPos + 4
        End If
    Next lChar
    
    If bOut(lOutSize) = 10 Then lOutSize = lOutSize - 2 'Shift the padding chars down if it ends with CrLf.
    
    If iPad = 1 Then                                    'Add the padding chars if any.
        bOut(lOutSize) = 61                             'Chr(61) = "="
    ElseIf iPad = 2 Then
        bOut(lOutSize) = 61
        bOut(lOutSize - 1) = 61
    End If
    
    Encode64 = StrConv(bOut, vbUnicode)                 'Convert back to a string and return it.
    
End Function


Copy the following code into a class module named "SHA1Hash"

Option Explicit
'SHA1Hash
'Perform CryptoAPI SHA1 hash of supplied file, returning hash
'as string of 40 hex digits.
'----- Private Consts -----
Private Const ALG_TYPE_ANY          As Long = 0
Private Const ALG_CLASS_HASH        As Long = 32768
Private Const ALG_SID_SHA1          As Long = 4
Private Const CALG_SHA1             As Long = ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_SHA1
Private Const PROV_RSA_FULL         As Long = 1
Private Const CRYPT_VERIFYCONTEXT   As Long = &HF0000000
Private Const MS_DEFAULT_PROVIDER   As String = _
    "Microsoft Base Cryptographic Provider v1.0"

Private Const HP_HASHVAL            As Long = 2
Private Const HP_HASHSIZE           As Long = 4               
'----- Private Defines -----
Private Declare Function CryptAcquireContext Lib "advapi32" Alias "CryptAcquireContextA" ( _
    ByRef phProv As Long, _
    ByVal pszContainer As String, _
    ByVal pszProvider As String, _
    ByVal dwProvType As Long, _
    ByVal dwFlags As Long) As Long 'TRUE (<> 0) = success.  See Err.LastDLLError if FALSE.

Private Declare Function CryptCreateHash Lib "advapi32" ( _
    ByVal hProv As Long, _
    ByVal algid As Long, _
    ByVal hKey As Long, _
    ByVal dwFlags As Long, _
    ByRef phHash As Long) As Long 'TRUE (<> 0) = success.  See Err.LastDLLError if FALSE.
    
Private Declare Function CryptDestroyHash Lib "advapi32" ( _
    ByVal hHash As Long) As Long 'TRUE (<> 0) = success.  See Err.LastDLLError if FALSE.

Private Declare Function CryptGetHashParam Lib "advapi32" ( _
    ByVal hHash As Long, _
    ByVal dwParam As Long, _
    ByRef pbData As Any, _
    ByRef pdwDataLen As Long, _
    ByVal dwFlags As Long) As Long

Private Declare Function CryptHashData Lib "advapi32" ( _
    ByVal hHash As Long, _
    ByRef pbData As Any, _
    ByVal dwDataLen As Long, _
    ByVal dwFlags As Long) As Long

Private Declare Function CryptReleaseContext Lib "advapi32" ( _
    ByVal hProv As Long, _
    ByVal dwFlags As Long) As Long 'TRUE (<> 0) = success.  See Err.LastDLLError if FALSE.
'----- Private Data -----
Private m_hHash As Long 'Hash object handle.
Private m_hProvider As Long 'Cryptographic Service Provider handle.
'----- Private Methods -----
Private Sub HashBlock(ByRef Block() As Byte)
    If CryptHashData(m_hHash, _
                     Block(LBound(Block)), _
                     UBound(Block) - LBound(Block) + 1, _
                     0&) = 0 Then
        Err.Raise vbObjectError Or &HC312&, _
                  "SHA1Hash.HashFile", _
                  "Failed to hash data block, system error " _
                & CStr(Err.LastDllError)
    End If
End Sub

Private Function HashValue() As String
    Dim lngDataLen As Long
    Dim lngHashSize As Long
    Dim bytHashValue() As Byte
    
    lngDataLen = 4 '4 bytes for Long length.
    If CryptGetHashParam(m_hHash, HP_HASHSIZE, lngHashSize, lngDataLen, 0&) = 0 Then
        Err.Raise vbObjectError Or &HC322&, _
                  "SHA1Hash.HashFile", _
                  "Failed to obtain hash value length, system error " _
                & CStr(Err.LastDllError)
    Else
        lngDataLen = lngHashSize
        ReDim bytHashValue(lngDataLen - 1)
        
        If CryptGetHashParam(m_hHash, HP_HASHVAL, bytHashValue(0), lngDataLen, 0&) = 0 Then
            Err.Raise vbObjectError Or &HC324&, _
                      "SHA1Hash.HashFile", _
                      "Failed to obtain hash value, system error " _
                    & CStr(Err.LastDllError)
        Else
            Dim intByte As Integer
            
            For intByte = 0 To lngDataLen - 1
                HashValue = HashValue & Right$("0" & Hex$(bytHashValue(intByte)), 2)
            Next
            
            CryptDestroyHash m_hHash
        End If
    End If
End Function

Private Sub NewHash()
    If CryptCreateHash(m_hProvider, CALG_SHA1, 0&, 0&, m_hHash) = 0 Then
        Err.Raise vbObjectError Or &HC332&, _
                  "SHA1Hash.HashFile", _
                  "Failed to create CryptoAPI Hash object, system error " _
                & CStr(Err.LastDllError)
    End If
End Sub

'----- Public Methods -----

Public Function HashFile(ByVal FileName As String) As String
    Const CHUNK As Long = 16384
    Dim intFile As Integer
    Dim lngWholeChunks As Long
    Dim intRemainder As Integer
    Dim lngChunk As Long
    Dim bytBlock() As Byte
    
    
    If Len(Dir$(FileName, vbNormal Or vbHidden Or vbReadOnly Or vbSystem)) > 0 Then
        intFile = FreeFile(0)
        Open FileName For Binary Access Read As #intFile
        lngWholeChunks = LOF(intFile) \ CHUNK
        intRemainder = LOF(intFile) - (CHUNK * lngWholeChunks)
        NewHash
        ReDim bytBlock(CHUNK - 1)
        For lngChunk = 1 To lngWholeChunks
            Get #intFile, , bytBlock
            HashBlock bytBlock
        Next
        If intRemainder > 0 Then
            ReDim bytBlock(intRemainder - 1)
            Get #intFile, , bytBlock
            HashBlock bytBlock
        End If
        Close #intFile
        HashFile = HashValue()
    Else
        Err.Raise vbObjectError Or &HC342&, _
                  "SHA1Hash.HashFile", _
                  "File doesn't exist"
    End If
End Function

Public Function HashBytes(ByRef Bytes() As Byte) As String
    NewHash
    HashBlock Bytes
    HashBytes = HashValue()
End Function

'----- Class Event Handlers -----

Private Sub Class_Initialize()
    If CryptAcquireContext(m_hProvider, _
                           vbNullString, _
                           MS_DEFAULT_PROVIDER, _
                           PROV_RSA_FULL, _
                           CRYPT_VERIFYCONTEXT) = 0 Then
        Err.Raise vbObjectError Or &HC352&, _
                  "SHA1Hash.Class_Initialize", _
                  "Failed to obtain access to CryptoAPI, system error " _
                & CStr(Err.LastDllError)
    End If
End Sub

Private Sub Class_Terminate()
    On Error Resume Next 'All exceptions must be processed here.
    CryptDestroyHash m_hHash
    CryptReleaseContext m_hProvider, 0&
End Sub


quote:
If debugging is the process of removing software bugs, then programming must be the process of putting them in - Edsger Dijkstra.
Go to Top of Page

peeweethe2nd

3 Posts

Posted - 26 April 2013 :  03:07:17  Show Profile
Thanks this is much easier to follow then the spec from the HMRC.
But anyone reading this topic should also take a look at http://www.hmrc.gov.uk/softwaredevelopers/hmrcmark/index.htm to get the full picture. There is a java version there too.


quote:
You know he’s a really good tax accountant when he’s got a loophole named after him.
Go to Top of Page
   Topic   
 Forum Locked
 Printer Friendly
Jump To:
PAYEsoft Forum © 2013 PAYEsoft Inc Go To Top Of Page
Snitz Forums 2000