The code will run a lot faster if you use With ... End With to reduce the
number of object references.
--
http://www.standards.com/; See Howard Kaikow's web site.
Thanks for the advice, I do have Option Explicit on, but not Option Strict.
The conversion routine picked up a few "I can't figure ot the default
property" errors, but I can't see a way round those as I am using OLE
Automation into Excel to open the sheets. The code is as follows:
============================================================================
=======================
Dim FName, SheetName As String
Dim DataArray(12, 60) As Object
Dim mth, cl As Short
Dim xlc, xlr, n As Short
Dim rs As ADODB.Recordset
Dim Cn As ADODB.Connection
Dim strSQL, strCnn, MSg As String
Dim XLApp As Object
Dim LastM As Short
On Error GoTo ConvertRoutine_Err
ConvertRoutine = False 'Start off assuming fail and correct this if
we do succeed.
'Work out the lastM var from LastMonth
LastM = Val(LastMonth)
FileOpen(1, "C:\T7ConversionLog.txt", OpenMode.Append)
PrintLine(1, "TACSY 7 Conversion Log - " & Now)
PrintLine(1, "===========================================")
PrintLine(1, " ")
'Look for the files in the source directory by
FName = Dir(tp & "*.xls") 'tp is the var holding the path to the
spreadsheets being processed.
If FName = "" Then
'No xls files in this directory
MSg = "WARNING: No Excel files found in:" & NL & NL
MSg = MSg & tp & NL & NL
MSg = MSg & "Click OK to exit the Conversion Routine, "
MSg = MSg & "so that you can reselect the source folder."
MsgBox(MSg, MsgBoxStyle.Information, H)
PrintLine(1, "No Files found in selected folder ( " & tp & " )
to convert!")
PrintLine(1, "Aborting Conversion Run at " & Now)
FileClose(1)
Exit Function
Else
'Found some XL files.
'So Get Excel fired up
XLApp = CreateObject("Excel.Application")
XLApp.screenupdating = False
'Get the Tacsy7Data tble open ready to add records
Cn = New ADODB.Connection
Cn.ConnectionString = "Driver={SQL
Server};Server=SERVER;UID=;PWD=;DATABASE=TACSY"
Cn.Open()
rs = New ADODB.Recordset
rs.Open("SELECT * FROM Tacsy7Data", Cn,
ADODB.CursorTypeEnum.adOpenKeyset, ADODB.LockTypeEnum.adLockOptimistic,
ADODB.CommandTypeEnum.adCmdText)
Do
XLApp.workbooks.Open(tp & FName)
lblReadout.Text = "Processing " & FName & "."
PrintLine(1, "Started converting " & tp & FName & " at " &
Now)
System.Windows.Forms.Application.DoEvents() 'Let system in
for a tick + allow readout refresh.
xlr = 64 'Row start, 1 less than desired so that the mth can
be added to it to get the correct row.
DataArray(0, 0) = XLApp.cells(50, 4).Value 'Get the points
score
If XLApp.cells(84, 2).Value = "EmpNo" Then
DataArray(0, 1) = VB.Left(FName, Len(FName) - 4)
Else
DataArray(0, 1) = XLApp.cells(84, 2).Value 'Get EmpNo
End If
For mth = 1 To 12
For cl = 1 To 55
'Read the existing data into the array
DataArray(mth, cl) = XLApp.cells(xlr + mth,
cl).Value
Next cl
Next mth
'Array now has all the data from the old sheet - close the
sheet
XLApp.workbooks(FName).Close(savechanges:=False) 'close but
do not save
For mth = 1 To 12
'Read the data back from the array - Up to col 36 they
are the same, then
'the new column appears at the 37th column and then the
data is the same to the end.
Select Case mth
Case 1 To 5
rs.AddNew()
'UPGRADE_WARNING: Couldn't resolve default
property of object DataArray(). Click for more:
'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"'
rs.Fields("EmpNo").Value = Val(DataArray(0, 1))
'Employee Number
'UPGRADE_WARNING: Couldn't resolve default
property of object DataArray(0, 0). Click for more:
'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"'
rs.Fields("PointsScoreAtThisMonth").Value =
DataArray(0, 0) 'Points score.
If mth > LastM Then
rs.Fields("Year").Value = Year(Now) - 1
Else
rs.Fields("Year").Value = VB6.Format(Now,
"YYYY")
End If
'UPGRADE_WARNING: Couldn't resolve default
property of object DataArray(mth, 1). Click for more:
'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"'
rs.Fields("TextMonthNumber").Value =
DataArray(mth, 1)
'UPGRADE_WARNING: Couldn't resolve default
property of object DataArray(mth, 2). Click for more:
'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"'
rs.Fields("RollMonthNumber").Value =
DataArray(mth, 2)
... Lots more fields as per the above ...
'UPGRADE_WARNING: Couldn't resolve default
property of object DataArray(mth, 55). Click for more:
'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"'
rs.Fields("BusMixPCInvNumShade").Value =
DataArray(mth, 55)
rs.Update()
Case 6 To 12 'beyond m6 data is screwed from column
36, data is in 1 to right of where it should be ie 37.
rs.AddNew()
'UPGRADE_WARNING: Couldn't resolve default
property of object DataArray(). Click for more:
'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"'
rs.Fields("EmpNo").Value = Val(DataArray(0, 1))
'Employee Number
'UPGRADE_WARNING: Couldn't resolve default
property of object DataArray(0, 0). Click for more:
'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"'
rs.Fields("PointsScoreAtThisMonth").Value =
DataArray(0, 0) 'Points score.
If mth > LastM Then
rs.Fields("Year").Value = Year(Now) - 1
Else
rs.Fields("Year").Value = VB6.Format(Now,
"YYYY")
End If
'UPGRADE_WARNING: Couldn't resolve default
property of object DataArray(mth, 1). Click for more:
'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"'
rs.Fields("TextMonthNumber").Value =
DataArray(mth, 1)
'UPGRADE_WARNING: Couldn't resolve default
property of object DataArray(mth, 2). Click for more:
'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"'
rs.Fields("RollMonthNumber").Value =
DataArray(mth, 2)
... Lots more fields as per the above ...
'UPGRADE_WARNING: Couldn't resolve default
property of object DataArray(mth, 55). Click for more:
'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"'
rs.Fields("BusMixPCInvNum").Value =
DataArray(mth, 55)
rs.Fields("BusMixPCInvNumShade").Value = 0 'Just
have to hardcode a value of no shade as there is no data on sheets.
rs.Update()
End Select
Next mth
AfterError:
'Clear the array ready for next loop (if any).
For mth = 1 To 12
For cl = 1 To 55
'Clear the array
'UPGRADE_WARNING: Couldn't resolve default property
of object DataArray(mth, cl). Click for more:
'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"'
DataArray(mth, cl) = 0
Next cl
Next mth
'do a dir for the next file name or exit if FName=""
'UPGRADE_WARNING: Dir has a new behavior. Click for more:
'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1041"'
FName = Dir()
Loop Until FName = "" 'Move on to next sheet.
'Close recordset
rs.Close()
'Write closing log entry
PrintLine(1, " and finished file writes at " & Now) 'Finishes a
line started near top of loop
PrintLine(1,
"=====================================================================")
FileClose(1) 'close log file!
'UPGRADE_WARNING: Couldn't resolve default property of object
XLApp.screenupdating. Click for more:
'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"'
XLApp.screenupdating = True 'Turn on screen updating
'UPGRADE_WARNING: Couldn't resolve default property of object
XLApp.quit. Click for more:
'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"'
XLApp.quit() 'Quit excel
End If
ConvertRoutine = True
ConvertRoutine_End:
Exit Function
ConvertRoutine_Err:
Select Case Err.Number
Case 13 'Type Mismatch
Resume Next
Case 94 'Invalid Use of Null
Resume Next
Case 3021 'No record found
Resume ConvertRoutine_End
Case 3022 'Duplicate record
Resume ConvertRoutine_End
Case -2147217887 'Multiple-step OLE DB operation generated
errors. Check each OLE DB status value, if available. No work was done.
rs.CancelUpdate() 'Will occurr if dataarray(x,y) is empty
due to sheet being empty?? Found one so have put in this patch to bypass it.
Resume AfterError
Resume 'debugging
Case Else
Me.Cursor = System.Windows.Forms.Cursors.Default
Call ProgErrorHandler("ConvertRoutine in
frmConvertT7ToData", False)
Resume ConvertRoutine_End
Resume 'Debugging
End Select
=====================================================
I have retained the "On error Goto" because using Try, Catch, Finally I
can't find out how to trap a specific error like the -2147217887 Multiple
Step OLE error the help on this is "pants".
Siv
