VB раздувает базу Access что делать

[vrodo]

Доброе время суток
топик собсно
работает прога на VB которая работая в трее смотрит за состоянием одной из таблиц
за сутки база увеличивается на 10 мег
что делать
Заранее благодарю за любые ответы

[Konst_One]

Надо ее сжать. Используй DAO , там есть метод для сжатия базы.

[alibek]

Сжатие есть и в ADO, надо подключить Jet and Replication Objects (JRO).

[Konst_One]

Точно, можно через JRO , спасибо за поправку БОЛЬШОЙ ЧЕЛОВЕК

[vrodo]

хмм но ведь люди работают в онлайн режиме как же я ее сжимать буду ?
база от 97 акцеса

[Alexanbar]

Надо выбрать время (например, раз в сутки) для сжатия базы. Я думаю, это не очень болезненно. Или пересмотреть структуру базы, т.е. что в неё заносить.

[vrodo]

самое интересное что данные через Access заносились нормально
а вот простой запрос с группировкой через VB вызывает раздутие ее
вчера сжимал вручную до 500Кб сжалась а сегодня утром уже 39Мб
причем увеличивается 1 раз в 10сек как раз по времени запроса
что делать?
вот собсно код который осуществляет получение инфо
может че пальцами кривыми не то настучал
с базой в 1 раз работаю через VB

Код: Выделить всё

Function get_info()
again:
    Dim Col As TrueOLEDBList60.Column
    Dim Cols As TrueOLEDBList60.Columns
   
    Dim C As Integer
   
    On Error GoTo OpenRecSetError
    Set WK = Nothing
    Set DB = Nothing
    Set RS = Nothing
   
    Set WK = DBEngine.Workspaces(0)
    Set DB = WK.OpenDatabase("путь к базе данных")
    Set RS = DB.OpenRecordset("count_query", dbOpenDynaset) ' сохраненный запрос
   
    Sink.RecordSet = RS
   
    Set Cols = TDBList1.Columns
    Set Flds = RS.Fields
   
    While Cols.Count
        Cols.Remove 0
    Wend
    TDBList1.ReBind
   
    ' Configure the list
    For C = 0 To Sink.ColCount - 1
        Set Col = Cols.Add(C)
        Col.Caption = Flds(C).Name
        Col.Visible = True
        Col.HeadingStyle.Font.Bold = True
    Next C
   
    Sink.Attach TDBList1
   
    TDBList1.ReBind
   
    TDBList1.ApproxCount = Sink.RowCount
    If TDBList1.ApproxCount > 0 Then
        Me.Icon = Me.imgIcon(1).Picture
       
    Else
        Me.Icon = Me.imgIcon(0).Picture
    End If
    Exit Function
OpenRecSetError:
DoEvents
    GoTo again
    'MsgBox "Error openning Recordset!"
End Function

[vrodo]

вот собсно модуль класса который описывает переменную Sink
Dim Sink As New RsListCls

Код: Выделить всё

Option Explicit

Private WithEvents TDBL As TrueOLEDBList60.TDBList

Private RS As DAO.RecordSet
Private MaxCol As Integer
Private MaxRow As Long
Private Flds As DAO.Fields

Public Sub Attach(L As TrueOLEDBList60.TDBList)
    Set TDBL = L
End Sub

' Instantiate a working Recordset, MaxRow, MaxCol
Public Property Let RecordSet(RecSet As DAO.RecordSet)
    Set RS = RecSet
    Set Flds = RecSet.Fields
    If Not (RS.EOF And RS.BOF) Then RS.MoveLast
    MaxRow = RS.RecordCount
    MaxCol = Flds.Count
End Property

' Returns number of rows
Public Property Get RowCount() As Long
    RowCount = MaxRow
End Property

' Returns number of columns
Public Property Get ColCount() As Integer
    ColCount = MaxCol
End Property

' Fired when the list requests values OR a bookmark
Private Sub TDBL_UnboundReadDataEx(ByVal RowBuf As TrueOLEDBList60.RowBuffer, StartLocation As Variant, ByVal offset As Long, ApproximatePosition As Long)
    Dim ColIndex As Integer, Col As Integer
    Dim RowsFetched As Integer, Row As Long
    Dim StartRow As Variant
   
    Dim Cols As Long
    Dim Rows As Long
    Cols = RowBuf.ColumnCount - 1
    Rows = RowBuf.RowCount - 1
   
    RowsFetched = 0
   
    On Error GoTo NoRead
    If IsNull(StartLocation) Then
        If offset < 0 Then
            ' StartLocation refers to EOF
            RS.MoveLast
            RS.MoveNext
        Else
            ' StartLocation refers to BOF
            RS.MoveFirst
            RS.MovePrevious
        End If
        RS.Move offset
    Else
        RS.Move offset, StartLocation
    End If
       
    ' StartRow is the bookmark of the first requested row
    StartRow = RS.Bookmark
    Dim Pos As Long
    Pos = RS.AbsolutePosition
   
    For Row = 0 To Rows
        ' If out of bounce quit this loop
        If RS.BOF Or RS.EOF Then Exit For
       
        ' Retrieve values
        For Col = 0 To Cols
            ColIndex = RowBuf.ColumnIndex(Row, Col)
            RowBuf.Value(Row, Col) = Flds(ColIndex).Value
        Next Col
       
        ' Assign a bookmark for currently fetched row
        RowBuf.Bookmark(Row) = RS.Bookmark
       
        RowsFetched = RowsFetched + 1
        RS.MoveNext
    Next Row
   
    RowBuf.RowCount = RowsFetched
   
    ' Callibrate VScroll bar
    If Pos >= 0 Then ApproximatePosition = Pos
   
    Exit Sub
NoRead:
    RowBuf.RowCount = 0
    If Err.Number = 3021 Then
    Resume Next
    Else
        Exit Sub
    End If
End Sub