SEPA Code for VBA and C#
2013
Code Samples for Excel and Access and integration to Accounting Systems
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 |
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 |
The SAP system often downloads files as MHT which can be opened in excel but can be enormous
After getting a list of files for conversion I pass the file name (tmpFile) to this function to load the file listing and then save the file as Excel 2003 for easy import into and Access or SQL database
Function ChangeFormat(tmpFile) Dim success As Long Dim xlApp As Object ;first clear the destination folder of any temporary xls/mht files 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 fIsAppRunning("Excel") Then Set xlApp = GetObject(, "Excel.Application") Else Set xlApp = CreateObject("Excel.Application") End If If Dir(tmpFile) "" Then Set xlApp = CreateObject("Excel.Application") xlApp.workbooks.Open tmpFile 'xlApp.Visible = True xlApp.DisplayAlerts = False xlApp.activeworkbook.Saveas "c:\test\OrderImport.xls", FileFormat:=56 xlApp.Quit Set xlApp = Nothing End If 'MsgBox "Done processing " & tmpFile End Function |
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 |
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
Our Program MASC, WRAP and Stock Count have been updated to use Sage 2013
If you need to update your program please contact support first
Thanks – Support@handheld.ie
I cant believe the last entry I had was Sept ! Tardy..
You may need to save comment from one excel model and load them into another file. This can be a time consuming task and this routine will eliminate if ( big IF) you have a key column to store the comments on
Sub SaveComments() Dim rst As Recordset, i As Integer, tmpComment, tmpCrystal Dim db As Database Set db = OpenDatabase("Your Access Database") If MsgBox("Save these comments to the database ?", vbYesNo) = vbNo Then Exit Function End If Range("D1").Select For i = 2 To 5000 ActiveCell.Offset(1, 0).Select tmpCrystal = ActiveCell.Value tmpComment = ActiveCell.Offset(0, 62).Value If Len(tmpComment & "") > 0 Then If Len(tmpCrystal & "") > 0 Then Set rst = db.OpenRecordset("select * from tblComments where CrystalID='" & tmpCrystal & "'") If rst.RecordCount > 0 Then rst.MoveFirst rst.Edit Else rst.AddNew End If rst!CrystalID = tmpCrystal rst!Comments = tmpComment rst.Update End If End If Next i Set rst = Nothing MsgBox "Comments Updated" End Sub |
And now the function to load the comments
Sub LoadComments() Dim rst As Recordset, i As Integer, tmpComment, tmpCrystal Dim db As Database Set db = OpenDatabase("Your Access Database") If MsgBox("LOAD Comments into this File from the Database ", vbYesNo) = vbNo Then Exit Function End If tmpComment = "" Range("BN2").Select For i = 2 To 5000 tmpComment = tmpComment & ActiveCell.Value ActiveCell.Offset(1, 0).Select Next If Len(tmpComment & "") > 1 Then If MsgBox("Comments already exist these may be lost - CONTINUE ?", vbYesNo) = vbNo Then Exit Function End If End If Range("D1").Select For i = 2 To 5000 ActiveCell.Offset(1, 0).Select tmpCrystal = ActiveCell.Value ' If Len(tmpCrystal & "") > 2 Then Set rst = db.OpenRecordset("select * from tblComments where CrystalID='" & tmpCrystal & "'") If rst.RecordCount > 0 Then rst.MoveFirst ActiveCell.Offset(0, 62).Value = rst!Comments End If End If Next i Set rst = Nothing MsgBox "Comments Updated" End sub |
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 |
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 <> 0 If Err.Number = 3075 Then MsgBox "This application has detected newer versions " _ & "of required files on your computer. " _ & "It may take several minutes to recompile " _ & "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 <> 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 |
Comments