Hello,
I have a VB6 program which used to be run on XP and it still works there without any issues. It basically reads Excel data, writes them to MS Access and saves MS Access data into TXT file.
We are moving from XP to Windows 10 and trouble started now - it starts OK, can connect to MS Access, but when trying to read Excel data it gives this error (tried to run in both Win XP SP 3 and Windows 8 compatibility mode)
Here is the code causing trouble:
Any idea how to fix this, please?
I have a VB6 program which used to be run on XP and it still works there without any issues. It basically reads Excel data, writes them to MS Access and saves MS Access data into TXT file.
We are moving from XP to Windows 10 and trouble started now - it starts OK, can connect to MS Access, but when trying to read Excel data it gives this error (tried to run in both Win XP SP 3 and Windows 8 compatibility mode)
Here is the code causing trouble:
Code:
Private Sub Command3_Click()
Dim RATE, RT, OT, DT, DR, SH, WHR, WHRMAX, D15, REMRT As Double
Dim JOBID, RTYPE, WTYPE, STR1, EMPNAME, Msg As String
Dim i, J, COL, PPID, PDAYS, WNUM, EMPID, FIB, LL As Integer
Dim STD, FD, NSTD, JUL1, AUG2, SEP3, MAY4, DM30, DM1 As Date
Dim CIARKA, KLK, K As Integer
Dim numericCheck As Boolean
Dim SVIATKY() As String
Dim WSVIATKY() As String
Dim rst, rst1, rst2, rst3, rst4 As ADODB.Recordset
On Error GoTo NAV1
If Combo1.Text = "Select Pay Period" Then
MsgBox "Select Pay Period!"
Exit Sub
End If
If Len(Text1.Text) < 2 Then
MsgBox "Select input file!"
Exit Sub
End If
Me.MousePointer = vbHourglass
sSQL = "Select [SH] From [STATS];"
Set rst4 = New ADODB.Recordset
rst4.Open sSQL, objAccessConnection, adOpenKeyset, adLockOptimistic
KLK = rst4.RecordCount
ReDim SVIATKY(1 To KLK) As String
ReDim WSVIATKY(1 To KLK) As String
For K = 1 To KLK
SVIATKY(K) = rst4.Fields(0).Value
WSVIATKY(K) = Format(SVIATKY(K), "ww", vbMonday)
rst4.MoveNext
Next
sSQL = "Select [PPID], [PDAYS], [STD] From PAYPER where [PAYPER]='" & Combo1.Text & "';"
Set rst = New ADODB.Recordset
rst.Open sSQL, objAccessConnection, adOpenKeyset, adLockOptimistic
PPID = rst.Fields(0).Value 'PAY PERIOD id
PDAYS = rst.Fields(1).Value 'NUMBER OF DAYS IN PAY PERIOD
NSTD = rst.Fields(2).Value 'FIRST DAY OF PAY PERIOD
Set xlApp1 = New Excel.Application
Set wb1 = xlApp1.Workbooks.Open(Text1.Text)
Set ws1 = wb1.Worksheets(1)
For i = 6 To 999 'READ EXCEL ROWS
EMPID = ws1.Cells(i, 1) 'EMPLOYEE ID NUMBER
If IsNumeric(EMPID) = False Then
GoTo NAV2
End If
EMPNAME = ws1.Cells(i, 2) 'EMPLOYEE NAME
RATE = ws1.Cells(i, 3) 'PAY RATE [$]
JOBID = Left(ws1.Cells(i, 4), Len(ws1.Cells(i, 4)) - 1) 'JOB ID + RATE TYPE H/D
RTYPE = Right(ws1.Cells(i, 4), 1) 'RATE TYPE H/D
COL = 6
STD = NSTD 'SET THE FIRST DAY
Label5.Caption = "Processing: " & EMPNAME
Label5.Refresh
sSQL = "Select [EMPID], [FULL_NAME] from [NAMES] where [EMPID]=" & EMPID & ";"
Set rst1 = New ADODB.Recordset
rst1.Open sSQL, objAccessConnection, adOpenKeyset, adLockOptimistic
If rst1.RecordCount = 0 Then
MsgBox "Name " & EMPNAME & " not in database!"
Me.MousePointer = vbDefault
Exit Sub
End If
CIARKA = InStr(rst1.Fields(1).Value, ",")
If CIARKA = 0 Then
CIARKA = 4
End If
If Right(EMPNAME, 1) = " " Then 'REMOVE RIGHT SPACE
EMPNAME = Left(EMPNAME, Len(EMPNAME) - 1)
End If
If ((UCase(Left(rst1.Fields(1).Value, CIARKA - 1)) <> UCase(Left(EMPNAME, CIARKA - 1))) Or (UCase(Right(rst1.Fields(1).Value, 3)) <> UCase(Right(EMPNAME, 3)))) Then 'VERIFY NAMES
MsgBox "Name '" & EMPNAME & "' and '" & rst1.Fields(1).Value & "' and " & rst1.Fields(0).Value & " do not match!"
Me.MousePointer = vbDefault
Exit Sub
End If
If RTYPE = "H" Then 'HOURLY RATE
For J = 1 To PDAYS 'READ COLUMNS
WNUM = Format(STD, "ww", vbMonday)
If IsInArray(WSVIATKY, WNUM) = True Then
WHRMAX = 32
Else
WHRMAX = 40
End If
If IsNumeric((ws1.Cells(i, COL))) = False Then 'valid time value
ws1.Cells(i, COL) = 0
ws1.Cells(i, COL).Interior.ColorIndex = 6
'GoTo nav4
End If
SH = 0 'RESET STAT HOLIDAY
If IsInArray(SVIATKY, STD) = True Then
sSQL = "Select Min(WDATE) From WHOURS Where [EMPID]=" & EMPID & ";"
Set rst = New ADODB.Recordset
rst.Open sSQL, objAccessConnection, adOpenKeyset, adLockOptimistic
FD = rst.Fields(0).Value
DM30 = STD - 30
DM1 = STD - 1
sSQL = "SELECT Count([WDATE]) From WHOURS Where [EMPID]=" & EMPID & " AND [WDATE] Between #" & DM30 & "# And #" & DM1 & "#;"
Set rst = New ADODB.Recordset
rst.Open sSQL, objAccessConnection, adOpenKeyset, adLockOptimistic
D15 = rst.Fields(0).Value
If (((STD - FD) >= 30) And D15 >= 15) Then 'EMPLOYED MORE THAN 30 DAYS, GETS EXTRA DAY
WTYPE = "SH"
sSQL = "SELECT * From WHOURS Where EMPID=" & EMPID & " AND WDATE= #" & STD & "# AND WTYPE=""" & WTYPE & """;"
Set rst3 = New ADODB.Recordset
rst3.Open sSQL, objAccessConnection, adOpenKeyset, adLockOptimistic
If rst3.RecordCount = 0 Then
If (ws1.Cells(i, COL) <= 12) Then 'OT
SH = 8
RT = 0
OT = ws1.Cells(i, COL)
DT = 0
End If
If (ws1.Cells(i, COL) > 12) Then 'OT + DT
SH = 8
RT = 0
OT = 12
DT = ws1.Cells(i, COL) - 12
End If
Else
If (ws1.Cells(i, COL) <= 12) Then 'OT
SH = 0
RT = 0
OT = ws1.Cells(i, COL)
DT = 0
End If
If (ws1.Cells(i, COL) > 12) Then 'OT + DT
SH = 0
RT = 0
OT = 12
DT = ws1.Cells(i, COL) - 12
End If
End If
Else 'EMPLOYED LESS THAN 30 DAYS, DON'T GET EXTRA DAY
If (ws1.Cells(i, COL) <= 12) Then 'OT
RT = 0
OT = ws1.Cells(i, COL)
DT = 0
End If
If (ws1.Cells(i, COL) > 12) Then 'OT + DT
RT = 0
OT = 12
DT = ws1.Cells(i, COL) - 12
End If
End If
Else
If ((Weekday(STD) >= 2) And (Weekday(STD) <= 5)) Then 'IF MONDAY-THURSDAY
If ws1.Cells(i, COL) <= 8 Then 'RT
RT = ws1.Cells(i, COL)
OT = 0
DT = 0
End If
If ((ws1.Cells(i, COL) > 8) And (ws1.Cells(i, COL) <= 12)) Then 'RT + OT
RT = 8
OT = ws1.Cells(i, COL) - 8
DT = 0
End If
If (ws1.Cells(i, COL) > 12) Then 'RT + OT + DT
RT = 8
OT = 4
DT = ws1.Cells(i, COL) - 12
End If
End If
If (Weekday(STD) = 1) Then 'IF SUNDAY
If (ws1.Cells(i, COL) <= 12) Then 'OT
RT = 0
OT = ws1.Cells(i, COL)
DT = 0
End If
If (ws1.Cells(i, COL) > 12) Then 'OT + DT
RT = 0
OT = 12
DT = ws1.Cells(i, COL) - 12
End If
End If
If ((Weekday(STD) = 6) Or (Weekday(STD) = 7)) Then 'IF SATURDAY OR FRIDAY
STR1 = "R/T"
sSQL = "SELECT SUM([WHRS]) From WHOURS where ([WTYPE]='" & STR1 & "' AND [EMPID]=" & EMPID & " AND [WEEKN]=" & WNUM & ");"
Set rst2 = New ADODB.Recordset
rst2.Open sSQL, objAccessConnection, adOpenKeyset, adLockOptimistic
If IsNull(rst2.Fields(0).Value) Then
WHR = 0
Else
WHR = rst2.Fields(0).Value
End If
If WHR >= WHRMAX Then 'REACHED 40/32 R/T IN WEEK
If (ws1.Cells(i, COL) <= 12) Then 'OT
RT = 0
OT = ws1.Cells(i, COL)
DT = 0
End If
If (ws1.Cells(i, COL) > 12) Then 'OT + DT
RT = 0
OT = 12
DT = ws1.Cells(i, COL) - 12
End If
Else 'NOT REACHED 40/32 R/T IN WEEK YET
REMRT = WHRMAX - WHR
If REMRT >= 8 Then
If ws1.Cells(i, COL) <= 8 Then 'RT
RT = ws1.Cells(i, COL)
OT = 0
DT = 0
End If
If ((ws1.Cells(i, COL) > 8) And (ws1.Cells(i, COL) <= 12)) Then 'RT + OT
RT = 8
OT = ws1.Cells(i, COL) - 8
DT = 0
End If
If (ws1.Cells(i, COL) > 12) Then 'RT + OT + DT
RT = 8
OT = 4
DT = ws1.Cells(i, COL) - 12
End If
Else
If ws1.Cells(i, COL) <= REMRT Then 'RT LESS THAN 8 HRS
RT = ws1.Cells(i, COL)
OT = 0
DT = 0
End If
If ((ws1.Cells(i, COL) > REMRT) And (ws1.Cells(i, COL) <= 12)) Then 'RT + OT
RT = REMRT
OT = ws1.Cells(i, COL) - REMRT
DT = 0
End If
If (ws1.Cells(i, COL) > 12) Then 'RT + OT + DT
RT = REMRT
OT = 12 - REMRT
DT = ws1.Cells(i, COL) - 12
End If
End If
End If
End If
End If
If RT > 0 Then
WTYPE = "R/T"
sSQL = "INSERT INTO WHOURS (EMPID, WDATE, WTYPE, WHRS, PCODE, WRATE, WEEKN, PAYPER) VALUES ('" & EMPID & "', '" & STD & "', '" & WTYPE & "', '" & RT & "', '" & JOBID & "', '" & RATE & "', '" & WNUM & "', '" & PPID & "'); "
Set rsAccess = New ADODB.Recordset
rsAccess.CursorLocation = adUseClient
rsAccess.Open sSQL, objAccessConnection, adOpenKeyset, adLockOptimistic, adCmdText
End If
If OT > 0 Then
WTYPE = "O/T"
sSQL = "INSERT INTO WHOURS (EMPID, WDATE, WTYPE, WHRS, PCODE, WRATE, WEEKN, PAYPER) VALUES ('" & EMPID & "', '" & STD & "', '" & WTYPE & "', '" & OT & "', '" & JOBID & "', '" & RATE & "', '" & WNUM & "', '" & PPID & "'); "
Set rsAccess = New ADODB.Recordset
rsAccess.CursorLocation = adUseClient
rsAccess.Open sSQL, objAccessConnection, adOpenKeyset, adLockOptimistic, adCmdText
End If
If DT > 0 Then
WTYPE = "D/T"
sSQL = "INSERT INTO WHOURS (EMPID, WDATE, WTYPE, WHRS, PCODE, WRATE, WEEKN, PAYPER) VALUES ('" & EMPID & "', '" & STD & "', '" & WTYPE & "', '" & DT & "', '" & JOBID & "', '" & RATE & "', '" & WNUM & "', '" & PPID & "'); "
Set rsAccess = New ADODB.Recordset
rsAccess.CursorLocation = adUseClient
rsAccess.Open sSQL, objAccessConnection, adOpenKeyset, adLockOptimistic, adCmdText
End If
If SH > 0 Then
WTYPE = "SH"
sSQL = "INSERT INTO WHOURS (EMPID, WDATE, WTYPE, WHRS, PCODE, WRATE, WEEKN, PAYPER) VALUES ('" & EMPID & "', '" & STD & "', '" & WTYPE & "', '" & SH & "', '" & JOBID & "', '" & RATE & "', '" & WNUM & "', '" & PPID & "'); "
Set rsAccess = New ADODB.Recordset
rsAccess.CursorLocation = adUseClient
rsAccess.Open sSQL, objAccessConnection, adOpenKeyset, adLockOptimistic, adCmdText
End If
COL = COL + 1
STD = DateAdd("d", 1, STD)
Next J
Else 'DAY RATE
For J = 1 To PDAYS
If IsNumeric((ws1.Cells(i, COL))) = False Then 'valid time value
ws1.Cells(i, COL) = 0
ws1.Cells(i, COL).Interior.ColorIndex = 6
'GoTo nav4
End If
'*******************
SH = 0 'RESET STAT HOLIDAY
If IsInArray(SVIATKY, STD) = True Then
sSQL = "Select Min(WDATE) From WHOURS Where [EMPID]=" & EMPID & ";"
Set rst = New ADODB.Recordset
rst.Open sSQL, objAccessConnection, adOpenKeyset, adLockOptimistic
FD = rst.Fields(0).Value
DM30 = STD - 30
DM1 = STD - 1
sSQL = "SELECT Count([WDATE]) From WHOURS Where [EMPID]=" & EMPID & " AND [WDATE] Between #" & DM30 & "# And #" & DM1 & "#;"
Set rst = New ADODB.Recordset
rst.Open sSQL, objAccessConnection, adOpenKeyset, adLockOptimistic
D15 = rst.Fields(0).Value
If (((STD - FD) >= 30) And D15 >= 15) Then 'EMPLOYED MORE THAN 30 DAYS, GETS EXTRA DAY
If JOBID = 20 Then 'STAT HOLIDAY FOR COOKS/KITCHEN STAFF
DR = 1
WTYPE = "S/T"
sSQL = "SELECT * From WHOURS Where EMPID=" & EMPID & " AND WDATE= #" & STD & "# AND WTYPE=""" & WTYPE & """;"
Set rst3 = New ADODB.Recordset
rst3.Open sSQL, objAccessConnection, adOpenKeyset, adLockOptimistic
If rst3.RecordCount = 0 Then
sSQL = "INSERT INTO WHOURS (EMPID, WDATE, WTYPE, WHRS, PCODE, WRATE, WEEKN, PAYPER) VALUES ('" & EMPID & "', '" & STD & "', '" & WTYPE & "', '" & DR & "', '" & JOBID & "', '" & RATE & "', '" & WNUM & "', '" & PPID & "'); "
Set rsAccess = New ADODB.Recordset
rsAccess.CursorLocation = adUseClient
rsAccess.Open sSQL, objAccessConnection, adOpenKeyset, adLockOptimistic, adCmdText
End If
End If
End If
End If
'*******************
WNUM = Format(STD, "ww", vbMonday)
DR = ws1.Cells(i, COL)
If DR > 0 Then
If JOBID = 15 Then
WTYPE = "FAB"
Else
WTYPE = "T/T"
End If
sSQL = "INSERT INTO WHOURS (EMPID, WDATE, WTYPE, WHRS, PCODE, WRATE, WEEKN, PAYPER) VALUES ('" & EMPID & "', '" & STD & "', '" & WTYPE & "', '" & DR & "', '" & JOBID & "', '" & RATE & "', '" & WNUM & "', '" & PPID & "'); "
Set rsAccess = New ADODB.Recordset
rsAccess.CursorLocation = adUseClient
rsAccess.Open sSQL, objAccessConnection, adOpenKeyset, adLockOptimistic, adCmdText
End If
COL = COL + 1
STD = DateAdd("d", 1, STD)
Next J
End If
Next i
NAV2:
Label5.Caption = " "
Label5.Refresh
Me.MousePointer = vbDefault
xlApp1.AlertBeforeOverwriting = False
xlApp1.DisplayAlerts = False
Set ws1 = Nothing
wb1.Save
wb1.Close
Set wb1 = Nothing
Set xlApp1 = Nothing
MsgBox "Done"
Exit Sub
NAV1:
Msg = "Error # " & str(Err.Number) & " was generated by " _
& Err.Source & Chr(13) & "Error Line: " & Erl & Chr(13) & Err.Description
MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
End SubAny idea how to fix this, please?
