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

SAP – Changing the format of downloaded files

Jun 20
2013

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 " &amp; tmpFile       

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

Preserving Excel Comments Across versions

Mar 05
2013

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

Consolidate the contents of multiple excel sheets

Apr 30
2012

This is a very useful macro to add the contents of several excel sheets onto a single sheet

Sub CopyFromWorksheets()
    Dim wrk As Workbook 'Workbook object - Always good to work with object variables
    Dim sht As Worksheet 'Object for handling worksheets in loop
    Dim trg As Worksheet 'Master Worksheet
    Dim rng As Range 'Range object
    Dim colCount As Integer 'Column count in tables in the worksheets

    Set wrk = ActiveWorkbook 'Working in active workbook

    For Each sht In wrk.Worksheets
        If sht.Name = "Master" Then
            MsgBox "There is a worksheet called as 'Master'." &amp; vbCrLf &amp; _
            "Please remove or rename this worksheet since 'Master' would be" &amp; _
            "the name of the result worksheet of this process.", vbOKOnly + vbExclamation, "Error"
            Exit Sub
        End If
    Next sht 
 
     'We don't want screen updating
    Application.ScreenUpdating = False 
 
     'Add new worksheet as the last worksheet
    Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
     'Rename the new worksheet
    trg.Name = "Master"
     'Get column headers from the first worksheet
     'Column count first
    Set sht = wrk.Worksheets(1)
    colCount = sht.Cells(1, 255).End(xlToLeft).Column
     'Now retrieve headers, no copy&amp;paste needed
    With trg.Cells(1, 1).Resize(1, colCount)
        .Value = sht.Cells(1, 1).Resize(1, colCount).Value
         'Set font as bold
        .Font.Bold = True
    End With 
 
     'We can start loop
    For Each sht In wrk.Worksheets
         'If worksheet in loop is the last one, stop execution (it is Master worksheet)
        If sht.Index = wrk.Worksheets.Count Then
            Exit For
        End If
         'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets
        Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))
         'Put data into the Master worksheet
        trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
    Next sht
     'Fit the columns in Master worksheet
    trg.Columns.AutoFit 
 
     'Screen updating should be activated
    Application.ScreenUpdating = True
End Sub

Creating an Agresso upload file from Excel

Nov 23
2010

Actually this could be used for a variety of purposes but I wrote this for Agresso.

This is designed for a sheet with the data in column d , e and f which was required by period and transposes for loading.

Use the x variable to define the offset relative position, this allows you to copy the code down for each column and only change 1 value.

If time had allowed I would have written this as a loop using column numbers. But you can change this if you wish..

 
 
 
Sub Create_Agresso_BudgetLoad()
'Macro to create Agresso Load
Dim tmpArray(5000, 8), I As Integer, y As Integer
Dim tmpCode, tmpCount, x, tmpTrue
Range("D3").Select
 
I = 1
x = 0
 
tmpCode = ActiveCell.Value
tmpCount = 1
 
Do While I < 300
    ActiveCell.Offset(1, 0).Select
    If ActiveCell.Value <> 0 And ActiveCell.Offset(0, (-3 - x)).Value <> "" Then
        y = 1
 
        Do While y < 13
            tmpArray(tmpCount, 1) = ActiveCell.Offset(0, (-3 - x)).Value
            tmpArray(tmpCount, 2) = ActiveCell.Offset(0, (-2 - x)).Value
            tmpArray(tmpCount, 3) = tmpCode
            tmpArray(tmpCount, 4) = ""
            tmpArray(tmpCount, 5) = ""
            tmpArray(tmpCount, 6) = ActiveCell.Offset(0, (-1 - x)).Value
            tmpArray(tmpCount, 7) = ActiveCell.Offset(0, 0).Value / 12
            tmpArray(tmpCount, 8) = "2011" & Right("00" & y, 2)
            tmpCount = tmpCount + 1
            y = y + 1
        Loop
    End If
    I = I + 1
Loop
 
Range("E3").Select
I = 1
x = 1
 
tmpCode = ActiveCell.Value
 
 
Do While I < 300
    ActiveCell.Offset(1, 0).Select
    If ActiveCell.Value <> 0 And ActiveCell.Offset(0, (-3 - x)).Value <> "" Then
        y = 1
 
        Do While y < 13
            tmpArray(tmpCount, 1) = ActiveCell.Offset(0, (-3 - x)).Value
            tmpArray(tmpCount, 2) = ActiveCell.Offset(0, (-2 - x)).Value
            tmpArray(tmpCount, 3) = tmpCode
            tmpArray(tmpCount, 4) = ""
            tmpArray(tmpCount, 5) = ""
            tmpArray(tmpCount, 6) = ActiveCell.Offset(0, (-1 - x)).Value
            tmpArray(tmpCount, 7) = ActiveCell.Offset(0, 0).Value / 12
            tmpArray(tmpCount, 8) = "2011" & Right("00" & y, 2)
            tmpCount = tmpCount + 1
            y = y + 1
        Loop
    End If
    I = I + 1
Loop
 
 
Range("F3").Select
I = 1
x = 2
 
tmpCode = ActiveCell.Value
 
 
Do While I < 300
    ActiveCell.Offset(1, 0).Select
    If ActiveCell.Value <> 0 And ActiveCell.Offset(0, (-3 - x)).Value <> "" Then
        y = 1
 
        Do While y < 13
            tmpArray(tmpCount, 1) = ActiveCell.Offset(0, (-3 - x)).Value
            tmpArray(tmpCount, 2) = ActiveCell.Offset(0, (-2 - x)).Value
            tmpArray(tmpCount, 3) = tmpCode
            tmpArray(tmpCount, 4) = ""
            tmpArray(tmpCount, 5) = ""
            tmpArray(tmpCount, 6) = ActiveCell.Offset(0, (-1 - x)).Value
            tmpArray(tmpCount, 7) = ActiveCell.Offset(0, 0).Value / 12
            tmpArray(tmpCount, 8) = "2011" & Right("00" & y, 2)
            tmpCount = tmpCount + 1
            y = y + 1
        Loop
    End If
    I = I + 1
Loop
 
 
 
Sheets("Setup").Activate
Range("a2").Select
ActiveCell.Value = "Depart"
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = "Project"
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = "Account"
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = "Budget"
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = "Company"
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = "Text"
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = "Period"
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = "Budget"
Range("a3").Select
 
 
y = 1
Do While y < 5000
    For I = 1 To 8
        ActiveCell.Offset(y, I - 1).Value = tmpArray(y, I)
    Next I
    y = y + 1
Loop
 
 
 
 
 
End Sub

Excel / IE links not working

Aug 25
2010

If you received this error after uninstalling Chrome (or Firefox) browser you may also need to change the HTM/HTML association in the registry.

1. Start, click Run, type Regedit in the Open box, and then click OK.
2. Browse to HKEY_CURRENT_USER\Software\Classes\.html
3. Right click the value for the .html key and select Modify…
4. Change the value from “ChromeHTML” to “htmlfile” (or from FireFoxHTML to htmlfile)
Repeat these steps for htm and .shtml keys if they exist.

Date Difference in Excel

Jun 06
2010

I have used datediff in access and vba but didnt not know that excel had the function DateDif which is very useful function in pay budgeting models.

See the link here for details

Creating Excel files from MS Access

Apr 24
2010

This routine is used to create an inventory forecast, which displays a 52 week forecast based on Sales orders MRP forecast and scheduled PO’s.

Function OpenWritetoXLS_QCS(tmpFiletoOpen, tmpFirstWeek, tmpLastWeek)
Dim objXL As Object
Dim strWhat As String, boolXL As Boolean
Dim objWkb As Object
Dim objSht As Object
Dim rst As Recordset, tmpRange, tmpRangeCount, tmpGonePast, tmpPosition, tmpOffset, I, tmpColumn
tmpGonePast = False
    Set rst = CurrentDb.OpenRecordset("Select * from tblTmpXLFile order by Id") ' this is my access table that contains the records I want to insert into excel
    If rst.RecordCount > 0 Then
        rst.MoveFirst
    Else
        Set rst = Nothing
        MsgBox ("Nothing to export to excel")
        Exit Function
    End If
    tmpRange = ""
 
    If fIsAppRunning("Excel") Then
        Set objXL = GetObject(, "Excel.Application")
        boolXL = False
    Else
        Set objXL = CreateObject("Excel.Application")
        boolXL = True
    End If
 
    'now open file
  With objXL
 
    .Visible = True
    Set objWkb = .Workbooks.Open(tmpFiletoOpen)
    On Error Resume Next
    Set objSht = objWkb.Worksheets("SHEETNAME")
    If Not Err.Number = 0 Then
      Set objSht = objWkb.Worksheets.Add
      objSht.Name = "SHEETNAME"
    End If
 
    objWkb.Worksheets("SHEETNAME").Activate
 
    objSht.Range("C1").Select
    objXL.ActiveCell.offset(0, 0) = tmpFirstWeek
 
    Err.Clear
 
    On Error GoTo 0
    tmpRangeCount = 1
    With objSht
        Do While Not rst.EOF
            tmpPosition = rst!Cellref ' this notes the line within the Excel model that I want to populate
            'reset to new position
            Select Case tmpPosition
                Case 6
                    .Range("B4").Select
                    tmpOffset = 3
                Case 8
                    .Range("B5").Select
                    tmpOffset = 4
                Case 9
                    .Range("B6").Select
                    tmpOffset = 5
                Case 20
                    .Range("B12").Select
                    tmpOffset = 11
                Case 30
                    .Range("B13").Select
                    tmpOffset = 12
                Case 35
                    .Range("B14").Select
                    tmpOffset = 13
            End Select
 
            'Find out what row we should go to
            tmpColumn = Val(rst!rptLabel)
            tmpColumn = tmpColumn - tmpFirstWeek + 1
 
            If Val(rst!rptLabel) = 0 Then
                objXL.ActiveCell.offset(0, 0) = rst!FIELDNAME
            Else
                objXL.ActiveCell.offset(0, tmpColumn) = rst!FIELDNAME
            End If
            rst.MoveNext
        Loop
    End With
 
  'update Parameters
    Set objSht = objWkb.Worksheets("Parameters")
    If Not Err.Number = 0 Then
      Set objSht = objWkb.Worksheets.Add
      objSht.Name = "Parameters"
    End If
 
    objWkb.Worksheets("Parameters").Activate
 
    objSht.Range("A1").Select
    objXL.ActiveCell.offset(0, 0) = "Year"
    objXL.ActiveCell.offset(0, 1) = Forms![frmExport]![txtYear]
    objXL.ActiveCell.offset(1, 0) = "Overdue Week"
    objXL.ActiveCell.offset(1, 1) = Forms![frmExport]![txtOverDue]
    objXL.ActiveCell.offset(2, 0) = "Start of Month"
    objXL.ActiveCell.offset(2, 1) = Forms![frmExport]![txtStartofMonth]
 
    objXL.ActiveCell.offset(3, 0) = "First Week"
    objXL.ActiveCell.offset(3, 1) = Forms![frmExport]![txtFirstWeek]
 
    objXL.ActiveCell.offset(3, 0) = "Last Week"
    objXL.ActiveCell.offset(3, 1) = Forms![frmExport]![txtLastWeek]
 
  End With
 
  objWkb.Close savechanges:=True
 
  Set objSht = Nothing
  Set objWkb = Nothing
  Set objXL = Nothing
  Set rst = Nothing
 
End Function

Excel Limiting the number of characters

Mar 24
2010

Following from the link on Access this one is for Excel

http://www.techonthenet.com/excel/cells/validation1.php

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