SEPA Code for VBA and C#

Sep 07
2013

I have just finished coding the solution for both our C# and VBA programs

If you need the code for your project drop me an email

SEPA Code

Save Outlook Attachments to Disk

Jul 15
2013

I used the code on this page for a client to save the attachments into a specific folder

The files that are saved are automatically unzipped and loaded into a database each night and the system creates the reports automatically and loads the report PDFs into a MS Sharepoint server for access through the WAN

http://www.pixelchef.net/content/rule-autosave-attachment-outlook

I changed the code slightly as all the files were zipped with the same name and I used the email subject and date to distinguish the files.

Public Sub saveAttachtoDisk (itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String, DateFormat
 
DateFormat = Format(Now(), "yyyy-mm-dd H-mm")
 
saveFolder = "C:\temp"
 
    For Each objAtt In itm.Attachments
        objAtt.SaveAsFile saveFolder & "\" & itm.Subject & "_" & DateFormat & objAtt.DisplayName
        Set objAtt = Nothing
    Next
 
End Sub

How to ensure the Intact SDK is running before your load your invoices

Jul 05
2013

We noticed we Intact that if the SDK wasn’t running before you started your posting , it could be very slow to post the transactions. We had tried to call the SDK but if it was already running the user would get an error. Calling the function CheckForProcByExe allowed the program to check if the intactsdk.exe was running before starting the routine.

Very handy…

Option Compare Database
 
Private Declare Function EnumProcesses Lib "psapi.dll" _
   (ByRef lpidProcess As Long, ByVal cb As Long, _
      ByRef cbNeeded As Long) As Long
 
Private Declare Function OpenProcess Lib "Kernel32.dll" _
  (ByVal dwDesiredAccessas As Long, ByVal bInheritHandle As Long, _
      ByVal dwProcId As Long) As Long
 
Private Declare Function EnumProcessModules Lib "psapi.dll" _
   (ByVal hProcess As Long, ByRef lphModule As Long, _
      ByVal cb As Long, ByRef cbNeeded As Long) As Long
 
Private Declare Function GetModuleFileNameExA Lib "psapi.dll" _
   (ByVal hProcess As Long, ByVal hModule As Long, _
      ByVal strModuleName As String, ByVal nSize As Long) As Long
 
Private Declare Function CloseHandle Lib "Kernel32.dll" _
   (ByVal Handle As Long) As Long
 
Private Const PROCESS_QUERY_INFORMATION = 1024
Private Const PROCESS_VM_READ = 16
Private Const MAX_PATH = 260
 
Public Function CheckForProcByExe(pEXEName As String) As Boolean
 
    On Error Resume Next
 
        Dim cb As Long
        Dim cbNeeded As Long
        Dim NumElements As Long
        Dim lProcessIDs() As Long
        Dim cbNeeded2 As Long
        Dim lNumElements2 As Long
        Dim lModules(1 To 200) As Long
        Dim lRet As Long
        Dim strModuleName As String
        Dim nSize As Long
        Dim hProcess As Long
        Dim i As Long
 
        'Get the array containing the process id's for each process object
        cb = 8
        cbNeeded = 96
        Do While cb <= cbNeeded
            cb = cb * 2
            ReDim lProcessIDs(cb / 4) As Long
            lRet = EnumProcesses(lProcessIDs(1), cb, cbNeeded)
        Loop
        NumElements = cbNeeded / 4
        For i = 1 To NumElements
            'Get a handle to the Process
            hProcess = OpenProcess(PROCESS_QUERY_INFORMATION _
            Or PROCESS_VM_READ, 0, lProcessIDs(i))
            'Got a Process handle
            If hProcess <> 0 Then
                'Get an array of the module handles for the specified
                'process
                lRet = EnumProcessModules(hProcess, lModules(1), 200, _
                        cbNeeded2)
                'If the Module Array is retrieved, Get the ModuleFileName
                If lRet <> 0 Then
                    strModuleName = Space(MAX_PATH)
                    nSize = 500
                    lRet = GetModuleFileNameExA(hProcess, lModules(1), _
                    strModuleName, nSize)
                    strModuleName = Left(strModuleName, lRet)
                    'Check for the client application running
                    If InStr(UCase(strModuleName), UCase(pEXEName)) Then
                        CheckForProcByExe = True
                        Exit Function
                    Else
                        CheckForProcByExe = False
                    End If
                End If
            End If
            'Close the handle to the process
            lRet = CloseHandle(hProcess)
        Next
End Function

Auto Unzipping Files and Loading of Excel Files

Jun 11
2013

We used this function to automatically unzip Excel files , the files had been sent by email and an outlook rule saved the attachments into a given folder

Function ProcessZippedDownloads()
Dim rst As Recordset
Dim tmpFromFolder As String
tmpFromFolder = "\\your-folder-name"
'get the new zip files from folder
Call upStatus("Receipts - Getting File List @" & Now())
 
Call ListFilesInFolder(tmpFromFolder)
 
'check for procesing folder
If Dir("C:\test", vbDirectory) = "" Then
    MkDir "c:\test"
End If
 
If Right(tmpFromFolder, 1) <> "\" Then
   tmpFromFolder = tmpFromFolder & "\"
End If
'process the file into the Receipts table son the server
Set rst = CurrentDb.OpenRecordset("Select * from tblFilesDownloaded where FTP_PRocessed<>-1", dbOpenDynaset, dbSeeChanges)
If rst.RecordCount = 0 Then
    Exit Function
    Set rst = Nothing
    Call upStatus("No files to Process ?? @" & Now())
 
End If
rst.MoveFirst
DoCmd.SetWarnings False
Do While Not rst.EOF
    Call upStatus("Processing File @" & rst!FTP_FileDownloaded)
 
    'unpack and save as excel
    If Dir(tmpFromFolder & rst!FTP_FileDownloaded) = "" Then
        MsgBox "Where is it ? " & tmpFromFolder & rst!FTP_FileDownloaded
    Else
        Call Unzipit(tmpFromFolder & rst!FTP_FileDownloaded)
 
        'load into receipts table
        DoCmd.OpenQuery "qryAddReceipts"
        'edit and mark as processed
        rst.Edit
        rst!FTP_Processed = -1
        rst.Update
        FileCopy tmpFromFolder & rst!FTP_FileDownloaded, "C:\test\processed\" & rst!FTP_FileDownloaded
        Kill tmpFromFolder & rst!FTP_FileDownloaded
    End If
    rst.MoveNext
Loop
 
DoCmd.SetWarnings True
Call upStatus("Finished @" & Now())
 
 
End Function

The Unzipit function uses the Chilkat Component and Excel Automation to open and save the file into a specific folder and load the contents into an SQL database.
The unzipped Excel file in this case has the same name and is linked to the database which allows the data to be loaded using an access query.

 
Function Unzipit(tmpFile)
Dim zip As New ChilkatZip2
 
Dim success As Long
 
'  Any string unlocks the component for the 1st 30-days.
success = zip.UnlockComponent("Your License Code")
If (success <> 1) Then
    MsgBox zip.LastErrorText & vbCrLf
    Exit Function
End If
 
success = zip.OpenZip(tmpFile)
 
If (success <> 1) Then
    MsgBox zip.LastErrorText & vbCrLf
    Exit Function
End If
 
If Dir("c:\test\*.xls") <> "" Then
    Kill "c:\test\*.xls"
End If
 
If Dir("c:\test\*.mht") <> "" Then
    Kill "c:\test\*.mht"
End If
 
If Dir("c:\test\*.lxs") <> "" Then
    Kill "c:\test\*.xls"
End If
 
 
Dim unzipCount As Long
 
'  Returns the number of files and directories unzipped.
'  Unzips to /my_files, re-creating the directory tree
'  from the .zip.
unzipCount = zip.UnzipInto("c:\test")
If (unzipCount < 0) Then
    MsgBox zip.LastErrorText & vbCrLf
Else
    tmpFile = "c:\test\" & Dir("c:\test\*.xls")
    FileCopy tmpFile, Left(tmpFile, Len(tmpFile) - 3) & "mht"
End If
 
 
 
Dim xlApp As Object
 
If fIsAppRunning("Excel") Then
    Set xlApp = GetObject(, "Excel.Application")
Else
    Set xlApp = CreateObject("Excel.Application")
End If
 
Set xlApp = CreateObject("Excel.Application")
xlApp.workbooks.Open Left(tmpFile, Len(tmpFile) - 3) & "mht"
'xlApp.Visible = True
xlApp.DisplayAlerts = False
xlApp.activeworkbook.Saveas "c:\test\ReceiptImport.xls", FileFormat:=56
xlApp.Quit
Set xlApp = Nothing
'MsgBox "Done processing " & tmpFile

 
 
End Function

SEPA – Direct Debits / Credits

May 11
2013

We have now completed our program for SEPA Direct Debits Processing

If you need to upgrade to the new version please contact Saiju for details

support@hanhdeld.ie

Using Passthrough query in MASC

Sep 12
2012

We have recently converted a database from Access to SQL and needed to increase the speed of the reports when working with a large recordset. We amended this code from the web which significantly increased the speed on 2 reports but reduced the speed on another – so its a case of testing to get the best results.

Public Sub PassThrough(strSQL As String, tmpQry)
On Error GoTo ErrHandler
 
Dim obj As QueryDef
Dim dbsCurrent As Database
Dim qdfPassThrough As QueryDef
 
Set dbsCurrent = CurrentDb()
 
'delete the existing query
For Each obj In dbsCurrent.QueryDefs
     If obj.Name = tmpQry Then dbsCurrent.QueryDefs.Delete tmpQry
Next
 
 
Set qdfPassThrough = dbsCurrent.CreateQueryDef(tmpQry)
qdfPassThrough.Connect = "ODBC;DSN=MASCSql;DATABASE=mascdataSQL;UID=xxxx;PWD=yyyy" ' replace with your details
qdfPassThrough.SQL = strSQL ' this is generated from the form taking the parameters and changing the table names to add the dbo. 
qdfPassThrough.ReturnsRecords = True 
 
dbsCurrent.Close
 
Exit_ErrHandler:
Exit Sub
 
ErrHandler:
MsgBox Err.Number & ": " & Err.Description
Resume Exit_ErrHandler
End Sub

Checking the References in an Access Database

Sep 12
2012

This code from the MS site checks the references and can fix broken references – the compile will only work in an mdb version

Function CheckRefs()
   Dim db As Database, rs As Recordset
   Dim x
   Set db = CurrentDb
 
   On Error Resume Next
 
   ' Run the query qryTestRefs you created and trap for an error.
   Set rs = db.OpenRecordset("qryTestRefs", dbOpenDynaset)
 
   ' The if statement below checks for error 3075. If it encounters the
   ' error, it informs the user that it needs to fix the application.
   ' Error 3075 is the following:
   ' "Function isn't available in expressions in query expression..."

   ' Note: This function only checks for the error 3075. If you want it to
   ' check for other errors, you can modify the If statement. To have
   ' it check for any error, you can change it to the following:
   ' If Err.Number &lt;&gt; 0

    If Err.Number = 3075 Then
      MsgBox "This application has detected newer versions " _
             &amp; "of required files on your computer. " _
             &amp; "It may take several minutes to recompile " _
             &amp; "this application."
      Err.Clear
      FixUpRefs
   End If   
 
End Function
 
Sub FixUpRefs()
    Dim loRef As Access.Reference
    Dim intCount As Integer
    Dim intX As Integer
    Dim blnBroke As Boolean
    Dim strPath As String
 
    On Error Resume Next
 
    'Count the number of references in the database
    intCount = Access.References.Count
 
    'Loop through each reference in the database
    'and determine if the reference is broken.
    'If it is broken, remove the Reference and add it back.
    For intX = intCount To 1 Step -1
      Set loRef = Access.References(intX)
      With loRef
        blnBroke = .IsBroken
        If blnBroke = True Or Err &lt;&gt; 0 Then
          strPath = .FullPath
          With Access.References
            .Remove loRef
            .AddFromFile strPath
          End With
        End If
       End With
    Next
 
  Set loRef = Nothing
 
  ' Call a hidden SysCmd to automatically compile/save all modules.
  Call SysCmd(504, 16483)
End Sub

Editing a NK2 files

May 30
2012

This is so random that I had to include this here

Every time that you type an email address or name in the message window of MS-Outlook, it automatically offer you a list of users and email address that you can choose. This feature is known as ‘AutoComplete’ and Outlook automatically build this emails list according to user activity and save it into a file with .NK2 extension.

This site has a free utility to edit these addresses

http://www.nirsoft.net/utils/outlook_nk2_edit.html

Rounded corners in an Access report

Mar 30
2012

Here is a useful function which Duane Hookom MVP had on on of the blogs

It allows you to add nice rounded boxes to your reports for addresses for example

 
Sub RoundCornerBox( _
        lngWidth As Long, _
        lngHeight As Long, _
        lngTop As Long, _
        lngLeft As Long, _
        lngRadius As Long, _
        rptReport As Report)
 
    'call this from a report with syntax like
    '
    'Private Sub Detail_Format(Cancel As Integer, FormatCount As Integer)
    '    RoundCornerBox 4000, 6000, 100, 200, 300, Me
    'End Sub

    Dim sngStart As Single
    Dim sngEnd As Single
    Dim dblPI As Double
    dblPI = 3.14159265359
 
    rptReport.DrawWidth = 15
    'Top Left
    sngStart = 2 * dblPI * 0.25 ' Start of pie slice.
    sngEnd = 2 * dblPI * 0.5    ' End of pie slice.
    rptReport.Circle (lngLeft + lngRadius, _
            lngTop + lngRadius), _
            lngRadius, vbBlack, sngStart, sngEnd
    'Top line
    rptReport.Line (lngLeft + lngRadius, lngTop)- _
        (lngLeft + lngWidth - lngRadius, lngTop)
 
    'Top Right
    sngStart = 2 * dblPI * 0.000001
    sngEnd = 2 * dblPI * 0.25
    rptReport.Circle (lngLeft + lngWidth - _
            lngRadius, lngTop + lngRadius), _
            lngRadius, vbBlack, sngStart, sngEnd
    'right line
    rptReport.Line (lngLeft + lngWidth, _
        lngTop + lngRadius)- _
        (lngLeft + lngWidth, _
        lngTop + lngHeight - lngRadius)
 
    'Bottom right
    sngStart = 2 * dblPI * 0.75
    sngEnd = 2 * dblPI
    rptReport.Circle (lngLeft + lngWidth - _
        lngRadius, lngTop + lngHeight - lngRadius), _
        lngRadius, vbBlack, sngStart, sngEnd
    rptReport.Line (lngLeft + lngRadius, _
        lngTop + lngHeight)- _
        (lngLeft + lngWidth - lngRadius, lngTop + lngHeight)
 
    'Bottom Left
    sngStart = 2 * dblPI * 0.5
    sngEnd = 2 * dblPI * 0.75
    rptReport.Circle (lngLeft + lngRadius, _
        lngTop + lngHeight - lngRadius), _
        lngRadius, vbBlack, sngStart, sngEnd
    'right line
    rptReport.Line (lngLeft, lngTop + lngRadius)- _
        (lngLeft, lngTop + lngHeight - lngRadius)
 
End Sub

Locked File

Feb 21
2012

This function from the MS site was useful to ensure the file was available before been processed

Function FileLocked(strFileName As String) As Boolean
   On Error Resume Next
   ' If the file is already opened by another process,
   ' and the specified type of access is not allowed,
   ' the Open operation fails and an error occurs.
   Open strFileName For Binary Access Read Write Lock Read Write As #1
   Close #1
   ' If an error occurs, the document is currently open.
   If Err.Number <> 0 Then
      ' Display the error number and description.
      Application.Echo True, "Error #" & str(Err.Number) & " - " & Err.Description
      FileLocked = True
      Err.Clear
   End If
End Function

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