Program freezes after reading 1284 records via ADO and ODBC

Program freezes after reading 1284 records via ADO and ODBC

Post by Ricard » Thu, 08 Jun 2000 04:00:00



Program freezes after reading 1284 records via ADO and ODBC

The program source underneath runs a query on a MS Access
database and writes the recordset to an Excel spreadsheet.
However, after 1284 records processed the program freezes
without any error messages.
I've tried to refresh the recordset using methods: .Refresh
(with a datacontrol in stead of an ADODB-object) and
Resync and .Requery, but the result is exactly the same.
Can anyone point out the flaw and how to correct it? Thank you.

Option Explicit

Public Const PadExcelSheet = "C:\My Documents\Productlijst"
Public Const PadImpDBC = "C:\My Documents\impodbc.mdb"
Public Const MaxAantalRegelsInExcelSheet = 200
Public RunDatum As String

Sub MAIN()
  Dim cnImpuls As New ADODB.Connection
  Dim cmdImpuls As New ADODB.Command
  Dim Rs As New ADODB.Recordset

  On Error GoTo ErrorHandler

  RunDatum = Format(Now, "yyyymmdd.HHMM")

  Set cnImpuls = CreateObject("ADODB.Connection")
  Set cmdImpuls = CreateObject("ADODB.Command")
  Set Rs = CreateObject("ADODB.Recordset")

  With cnImpuls
    .ConnectionString = "DSN=Impuls_via_MSAccess_CMyDocuments"
    .Open
  End With

  Rs.CursorLocation = adUseServer
  Rs.Open "query1", cnImpuls, adOpenForwardOnly,
adLockBatchOptimistic, adCmdTable

  Call CopyRecordset2ExcelSheet(Rs, PadExcelSheet,
MaxAantalRegelsInExcelSheet)

  Rs.Close
  cnImpuls.Close
  Set Rs = Nothing
  Set cnImpuls = Nothing
  Exit Sub

ErrorHandler:
  Open PadExcelSheet & "_STATUS.txt" For Append As #1
    Print #1, "| Rundatum: " & RunDatum & " | " & Format
(Time, "HH:MM:SS") & " | Status: FOUT: Sub Main:   (" &
Err.Number & ")  " & Err.Description
  Close #1
  If Rs.State = adStateOpen Then Rs.Close
  If cnImpuls.State = adStateOpen Then cnImpuls.Close
  Set Rs = Nothing
  Set cnImpuls = Nothing

End Sub

-----

Public Sub CopyRecordset2ExcelSheet(InRecordset As Recordset,
NaamExcelSheet As String, MaxAantalRegels As Integer)

  Dim objExcel As Object
  Dim BestandVolgnummer, Rij, Kolom As Integer
  Dim ExtraKolomLetter, BestandsNaamExcelSheet As String
  Dim RegelBeperkingAan As Boolean

  On Error GoTo ErrorHandler

  RegelBeperkingAan = MaxAantalRegels >= 0

  Set objExcel = CreateObject("Excel.Application")
  objExcel.Workbooks.Add

  Open PadExcelSheet & "_STATUS.txt" For Append As #1
    Print #1, "| Rundatum: " & RunDatum & " | " & Format
(Time, "HH:MM:SS") & " | Status: BEZIG met het MoveFirst na
MoveLast in de recordset..."
  Close #1
  InRecordset.MoveFirst

' Doorlopen van de database en vullen van de Excel-sheet:
  BestandVolgnummer = 1
  Rij = 1
  Do While Not InRecordset.EOF
    ExtraKolomLetter = ""
    For Kolom = 0 To InRecordset.Fields.Count - 1
''    Debug.Print "Coordinaat=[" & Trim(ExtraKolomLetter & Chr
(65 + Kolom Mod 26)) & Trim(Str(Rij)) & "]  ; Veldwaarde=[" &
InRecordset.Fields(Kolom) & "]"
      objExcel.Range(Trim(ExtraKolomLetter & Chr(65 + Kolom Mod
26)) & Trim(Str(Rij))).Select
      objExcel.ActiveCell.FormulaR1C1 = InRecordset.Fields(Kolom)
      If Chr(65 + Kolom Mod 26) = "Z" _
        Then
          If Trim(ExtraKolomLetter) = "" Then ExtraKolomLetter =
Chr(Asc("A") - 1)
          ExtraKolomLetter = Chr(Asc(ExtraKolomLetter) + 1)
      End If
    Next
    Open PadExcelSheet & "_STATUS.txt" For Append As #1
    InRecordset.MoveNext
    Rij = Rij + 1
    If RegelBeperkingAan And (((Rij - 1) Mod MaxAantalRegels =
0) Or InRecordset.EOF) _
      Then
        If BestandVolgnummer = 1 _
          Then
            BestandsNaamExcelSheet = PadExcelSheet & "(" &
RunDatum & ")"
          Else
            BestandsNaamExcelSheet = PadExcelSheet & "(" &
RunDatum & "." & BestandVolgnummer & ")"
        End If
        objExcel.Range("A1").Select
        objExcel.DisplayAlerts = False
        objExcel.ActiveWorkbook.SaveAs
FileName:=BestandsNaamExcelSheet & ".xls" _
          , FileFormat:=xlNormal _
          , Password:="" _
          , WriteResPassword:="" _
          , ReadOnlyRecommended:=False _
          , CreateBackup:=False
        objExcel.DisplayAlerts = True
        objExcel.ActiveWindow.Close
        objExcel.Quit
''        Set objExcel = Nothing
      ' Indien niet alle records in de recordset zijn geweest,
dan nieuwe sheet aanmaken:
        If Not InRecordset.EOF _
          Then
          ' Indien niet klaar een nieuwe Excel-sheet aanmaken:
            Set objExcel = CreateObject("Excel.Application")
            objExcel.Workbooks.Add
            BestandVolgnummer = Trim(Str(Val(BestandVolgnummer)
+ 1))
          ' En een resync doen van de recordset om het object
niet te groot te laten worden.
''            InRecordset.Resync
        End If
        Rij = 1
    End If
  Loop

' Finalisatie:
  ' Sluiten van statusbestand:
''  Open PadExcelSheet & "_STATUS.txt" For Output As #1
  Open PadExcelSheet & "_STATUS.txt" For Append As #1
''    Print #1, "| Rundatum: " & RunDatum & " | " & Format
(Time, "HH:MM:SS") & " | Status: KLAAR!!!  ( Bestandnr.= " &
BestandVolgnummer & "/" & (InRecordset.RecordCount \
MaxAantalRegels) + 1 & ", Regel= " & Rij + BestandVolgnummer *
MaxAantalRegelsInExcelSheet & "/" & InRecordset.RecordCount
& " )"
    Print #1, "| Rundatum: " & RunDatum & " | " & Format
(Time, "HH:MM:SS") & " | Status: KLAAR!!!  ( Bestandnr.= " &
BestandVolgnummer & ", Regel= " & Rij + (BestandVolgnummer - 1)
* MaxAantalRegelsInExcelSheet & " )"
  Close #1
  ' Einde programma:
  Exit Sub

ErrorHandler:
  ' Registreren van de fout:
''  Open PadExcelSheet & "_STATUS.txt" For Output As #1
  Open PadExcelSheet & "_STATUS.txt" For Append As #1
''    Print #1, "| Rundatum: " & RunDatum & " | " & Format
(Time, "HH:MM:SS") & " | Status: FOUT: Public Sub
RecordsetCopierenInExcelSheet: " & Err.Description & (" &
Err.Number & "); " "
    Print #1, "| Rundatum: " & RunDatum & " | " & Format
(Time, "HH:MM:SS") & " | Status: KLAAR!!!  ( Bestandnr.= " &
BestandVolgnummer & ", Regel= " & Rij + (BestandVolgnummer - 1)
* MaxAantalRegelsInExcelSheet & " )"
  Close #1
  ' Bewaren (c.q. overschrijven) van de sheet:
  objExcel.DisplayAlerts = False
  objExcel.ActiveWorkbook.SaveAs
FileName:=BestandsNaamExcelSheet & ".xls" _
    , FileFormat:=xlNormal _
    , Password:="" _
    , WriteResPassword:="" _
    , ReadOnlyRecommended:=False _
    , CreateBackup:=False
  objExcel.DisplayAlerts = True
 ' Sluiten van de Excel-sheet en opruimen van het object:
  objExcel.ActiveWindow.Close
  objExcel.Quit
  Set objExcel = Nothing

End Sub

* Sent from RemarQ http://www.remarq.com The Internet's Discussion Network *
The fastest and easiest way to search and participate in Usenet - Free!

 
 
 

Program freezes after reading 1284 records via ADO and ODBC

Post by Ricard » Thu, 08 Jun 2000 04:00:00


Program freezes after reading 1284 records via ADO and ODBC

The program source underneath runs a query on a MS Access
database and writes the recordset to an Excel spreadsheet.
However, after 1284 records processed the program freezes
without any error messages.
I've tried to refresh the recordset using methods: .Refresh
(with a datacontrol in stead of an ADODB-object) and
Resync and .Requery, but the result is exactly the same.
Can anyone point out the flaw and how to correct it? Thank you.

Option Explicit

Public Const PadExcelSheet = "C:\My Documents\Productlijst"
Public Const PadImpDBC = "C:\My Documents\impodbc.mdb"
Public Const MaxAantalRegelsInExcelSheet = 200
Public RunDatum As String

Sub MAIN()
  Dim cnImpuls As New ADODB.Connection
  Dim cmdImpuls As New ADODB.Command
  Dim Rs As New ADODB.Recordset

  On Error GoTo ErrorHandler

  RunDatum = Format(Now, "yyyymmdd.HHMM")

  Set cnImpuls = CreateObject("ADODB.Connection")
  Set cmdImpuls = CreateObject("ADODB.Command")
  Set Rs = CreateObject("ADODB.Recordset")

  With cnImpuls
    .ConnectionString = "DSN=Impuls_via_MSAccess_CMyDocuments"
    .Open
  End With

  Rs.CursorLocation = adUseServer
  Rs.Open "query1", cnImpuls, adOpenForwardOnly,
adLockBatchOptimistic, adCmdTable

  Call CopyRecordset2ExcelSheet(Rs, PadExcelSheet,
MaxAantalRegelsInExcelSheet)

  Rs.Close
  cnImpuls.Close
  Set Rs = Nothing
  Set cnImpuls = Nothing
  Exit Sub

ErrorHandler:
  Open PadExcelSheet & "_STATUS.txt" For Append As #1
    Print #1, "| Rundatum: " & RunDatum & " | " & Format
(Time, "HH:MM:SS") & " | Status: FOUT: Sub Main:   (" &
Err.Number & ")  " & Err.Description
  Close #1
  If Rs.State = adStateOpen Then Rs.Close
  If cnImpuls.State = adStateOpen Then cnImpuls.Close
  Set Rs = Nothing
  Set cnImpuls = Nothing

End Sub

-----

Public Sub CopyRecordset2ExcelSheet(InRecordset As Recordset,
NaamExcelSheet As String, MaxAantalRegels As Integer)

  Dim objExcel As Object
  Dim BestandVolgnummer, Rij, Kolom As Integer
  Dim ExtraKolomLetter, BestandsNaamExcelSheet As String
  Dim RegelBeperkingAan As Boolean

  On Error GoTo ErrorHandler

  RegelBeperkingAan = MaxAantalRegels >= 0

  Set objExcel = CreateObject("Excel.Application")
  objExcel.Workbooks.Add

  Open PadExcelSheet & "_STATUS.txt" For Append As #1
    Print #1, "| Rundatum: " & RunDatum & " | " & Format
(Time, "HH:MM:SS") & " | Status: BEZIG met het MoveFirst na
MoveLast in de recordset..."
  Close #1
  InRecordset.MoveFirst

' Doorlopen van de database en vullen van de Excel-sheet:
  BestandVolgnummer = 1
  Rij = 1
  Do While Not InRecordset.EOF
    ExtraKolomLetter = ""
    For Kolom = 0 To InRecordset.Fields.Count - 1
''    Debug.Print "Coordinaat=[" & Trim(ExtraKolomLetter & Chr
(65 + Kolom Mod 26)) & Trim(Str(Rij)) & "]  ; Veldwaarde=[" &
InRecordset.Fields(Kolom) & "]"
      objExcel.Range(Trim(ExtraKolomLetter & Chr(65 + Kolom Mod
26)) & Trim(Str(Rij))).Select
      objExcel.ActiveCell.FormulaR1C1 = InRecordset.Fields(Kolom)
      If Chr(65 + Kolom Mod 26) = "Z" _
        Then
          If Trim(ExtraKolomLetter) = "" Then ExtraKolomLetter =
Chr(Asc("A") - 1)
          ExtraKolomLetter = Chr(Asc(ExtraKolomLetter) + 1)
      End If
    Next
    Open PadExcelSheet & "_STATUS.txt" For Append As #1
    InRecordset.MoveNext
    Rij = Rij + 1
    If RegelBeperkingAan And (((Rij - 1) Mod MaxAantalRegels =
0) Or InRecordset.EOF) _
      Then
        If BestandVolgnummer = 1 _
          Then
            BestandsNaamExcelSheet = PadExcelSheet & "(" &
RunDatum & ")"
          Else
            BestandsNaamExcelSheet = PadExcelSheet & "(" &
RunDatum & "." & BestandVolgnummer & ")"
        End If
        objExcel.Range("A1").Select
        objExcel.DisplayAlerts = False
        objExcel.ActiveWorkbook.SaveAs
FileName:=BestandsNaamExcelSheet & ".xls" _
          , FileFormat:=xlNormal _
          , Password:="" _
          , WriteResPassword:="" _
          , ReadOnlyRecommended:=False _
          , CreateBackup:=False
        objExcel.DisplayAlerts = True
        objExcel.ActiveWindow.Close
        objExcel.Quit
''        Set objExcel = Nothing
      ' Indien niet alle records in de recordset zijn geweest,
dan nieuwe sheet aanmaken:
        If Not InRecordset.EOF _
          Then
          ' Indien niet klaar een nieuwe Excel-sheet aanmaken:
            Set objExcel = CreateObject("Excel.Application")
            objExcel.Workbooks.Add
            BestandVolgnummer = Trim(Str(Val(BestandVolgnummer)
+ 1))
          ' En een resync doen van de recordset om het object
niet te groot te laten worden.
''            InRecordset.Resync
        End If
        Rij = 1
    End If
  Loop

' Finalisatie:
  ' Sluiten van statusbestand:
''  Open PadExcelSheet & "_STATUS.txt" For Output As #1
  Open PadExcelSheet & "_STATUS.txt" For Append As #1
''    Print #1, "| Rundatum: " & RunDatum & " | " & Format
(Time, "HH:MM:SS") & " | Status: KLAAR!!!  ( Bestandnr.= " &
BestandVolgnummer & "/" & (InRecordset.RecordCount \
MaxAantalRegels) + 1 & ", Regel= " & Rij + BestandVolgnummer *
MaxAantalRegelsInExcelSheet & "/" & InRecordset.RecordCount
& " )"
    Print #1, "| Rundatum: " & RunDatum & " | " & Format
(Time, "HH:MM:SS") & " | Status: KLAAR!!!  ( Bestandnr.= " &
BestandVolgnummer & ", Regel= " & Rij + (BestandVolgnummer - 1)
* MaxAantalRegelsInExcelSheet & " )"
  Close #1
  ' Einde programma:
  Exit Sub

ErrorHandler:
  ' Registreren van de fout:
''  Open PadExcelSheet & "_STATUS.txt" For Output As #1
  Open PadExcelSheet & "_STATUS.txt" For Append As #1
''    Print #1, "| Rundatum: " & RunDatum & " | " & Format
(Time, "HH:MM:SS") & " | Status: FOUT: Public Sub
RecordsetCopierenInExcelSheet: " & Err.Description & (" &
Err.Number & "); " "
    Print #1, "| Rundatum: " & RunDatum & " | " & Format
(Time, "HH:MM:SS") & " | Status: KLAAR!!!  ( Bestandnr.= " &
BestandVolgnummer & ", Regel= " & Rij + (BestandVolgnummer - 1)
* MaxAantalRegelsInExcelSheet & " )"
  Close #1
  ' Bewaren (c.q. overschrijven) van de sheet:
  objExcel.DisplayAlerts = False
  objExcel.ActiveWorkbook.SaveAs
FileName:=BestandsNaamExcelSheet & ".xls" _
    , FileFormat:=xlNormal _
    , Password:="" _
    , WriteResPassword:="" _
    , ReadOnlyRecommended:=False _
    , CreateBackup:=False
  objExcel.DisplayAlerts = True
 ' Sluiten van de Excel-sheet en opruimen van het object:
  objExcel.ActiveWindow.Close
  objExcel.Quit
  Set objExcel = Nothing

End Sub

* Sent from RemarQ http://www.remarq.com The Internet's Discussion Network *
The fastest and easiest way to search and participate in Usenet - Free!