Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

  • Congratulations Mike Lewis on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!

Method '~' of object '~' failed

Status
Not open for further replies.

JoPaBC

Technical User
Sep 26, 2017
85
CA
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)
untitled_ccwyua.png


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 Sub

Any idea how to fix this, please?
 
The problem is likely to be, therefore, that you have dependencies (the code you have provided indicates that you are using early binding) on older ActiveX libraries than those available on your Windows 10 boxes.

One solution, assuming you still have a working Visual Studio 6 installation on an XP box, would be to switch to late binding, and recompile there.
 
Thanks for your suggestion; yes, I still have a working Visual Studio 6 installation on XP so I will try to modify binding.
It looks like the program can read/write to MS Access, can create a proper TXT file, but failing to read Excel on Windows 10.
 
Also, if you're going to reference a line number in your error message you could put line numbers in your code. I can't tell what line your code is failing on. Did it open Excel properly and the workbook?
 
Not related to your issue, but you do realize that all those [red]RED[/red] variables are Variants, right.... [ponder]

Code:
Dim [red]RATE, RT, OT, DT, DR, SH, WHR, WHRMAX, D15[/red], REMRT As Double
Dim [red]JOBID, RTYPE, WTYPE, STR1, EMPNAME[/red], Msg As String
Dim [red]i, J, COL, PPID, PDAYS, WNUM, EMPID, FIB[/red], LL As Integer
Dim [red]STD, FD, NSTD, JUL1, AUG2, SEP3, MAY4, DM30[/red], DM1 As Date
Dim [red]CIARKA, KLK[/red], K As Integer
Dim numericCheck As Boolean
Dim SVIATKY() As String
Dim WSVIATKY() As String
Dim [red]rst, rst1, rst2, rst3[/red], rst4 As ADODB.Recordset


---- Andy

There is a great need for a sarcasm font.
 
There also appear to be some undeclared variables - sSQL for example - but that may be because they are declared elsewhere
 
undeclared variables " - set your VB 6 IDE this way (a must, in my opinion):

Must_kajjms.png


and Run - Start With Full Compile (Ctrl - F5)


---- Andy

There is a great need for a sarcasm font.
 
Thanks everybody for you input.
I changed both setting to "Require Variable Declaration', code (late binding) and recompiled:

Code:
Dim xlApp1 As Object
Dim wb1 As Object
Dim ws1 As Object
...
    Set xlApp1 = CreateObject("Excel.Application")
    Set wb1 = xlApp1.Workbooks.Open(Text1.Text)
    Set ws1 = wb1.Worksheets(1)

It works under fine XP but getting the same error in Windows 10 :-(
 
PS: I have two Excel (2000 and 2007) versions installed on Windows 10, only Excel 2000 on XP; note sure if that can make any difference.
 
You need to find out which line of code creates the error you see.

On Windows 10 machine, set your error trapping to this:

eroor_r7sia0.png


Run your code and you will stop on the offending line.


---- Andy

There is a great need for a sarcasm font.
 
>On Windows 10 machine, set your error trapping to this:
>Run your code and you will stop on the offending line.

Andy, you've missed the fact that the OP cannot get the IDE to install on W10, so they cannot do this …

But, yes we do now need to

>find out which line of code creates the error you see

In the meantime: where and how are wb1 and ws1 declared?
 
Sorry - missed that in your most recently posted code snippet

Are you now saying the declarations are in the same Sub as they are used? Or do they have greater scope? If the latter, are they actually being used elsewhere?
 
Yes, I missed that, sorry about it....

But to find out which line of code creates this error, just add line numbers to your code. You already detect which line causes the error, you just do not have the line numbers...

Code:
...
NAV1:
    Msg = "Error # " & str(Err.Number) & " was generated by " _
        & Err.Source & Chr(13) & [blue]"Error Line: " & Erl [/blue]& Chr(13) & Err.Description
    MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
End Sub


---- Andy

There is a great need for a sarcasm font.
 
I am sorry, I tried Tools -> Options but didn't see anything like Line Numbers; am I looking at wrong place or doing it wrong way?
 
Unfortunately, VB6 does not have any automatic line numbers generator.
You can either use MZTools (if you have it) or do it by hand... :-(

Code:
Dim i As Integer

120 i = 7
121 If i = 7 Then
122     MsgBox 7
123 End If


---- Andy

There is a great need for a sarcasm font.
 
I tried your code on my machine with full compile, and even though you have late binding to Excel object, you still need to have reference to Excel.

You may try eliminating the reference to Excel object, and modify [blue]this code[/blue]:

Code:
Private Sub Command3_Click()[green]
'Pieces may be declared somewhere else[/green]
    Dim sSQL As String
    Dim objAccessConnection As ADODB.Connection
    Dim rsAccess As ADODB.Recordset

...
    NSTD = rst.Fields(2).Value  [green]'FIRST DAY OF PAY PERIOD

    'Set xlApp1 = New Excel.Application[/green][blue]
    Set xlApp1 = CreateObject("Excel.Application")[/blue]
    Set wb1 = xlApp1.Workbooks.Open(Text1.Text)
    Set ws1 = wb1.Worksheets(1)
...


---- Andy

There is a great need for a sarcasm font.
 
Thanks; I installed MZTools (trial) and add line numbers first to the current form then to current projects.
I can see line numbers in both cases, they start as line 10 and go to 7890 but the error message shows 'error line 0' so I am a little confused what is the proper line.

I tried some other VB6 programs (running okay on XP) and they all failed with the same error when trying to access an Excel file so it looks like there is definitely something wrong in handling Excel file on Windows 10.
 
Status
Not open for further replies.

Part and Inventory Search

Sponsor

Back
Top