קטגוריה: Access

לפעמים בשימוש ב-Access צריך להשתמש בטבלה זמנית.

ולפעמים הטבלה הזמנית צריכה להיות מבוססת על Recordset ADO

למען הסר ספק אין באמת טבלאות זמנית באקסס, זוהי רק טבלה רגילה, שפשוט נוצרת  לכמה רגעים, ובפעם הבאה שנריץ את הפרוצדורה, היא תימחק.

להלן המודול, ללא יותר מדי הסברים,

בקצרה – שולחים אליו רקורדסט ADO קיים, ואת השם הרצוי של הטבלה שתיווצר, והטבלה נוצרת מייד.

תוך כדי יצירת הטבלה, הפרוצדורה בודקת את השדות השונים, והגדרות השדות עוברות המרה מהפורמט של ADO אל הפורמט של Access .

Public Enum ETempTableActions
    CreateNewTableAndFillIt = 1
    OnlyFillExistsTable = 2
End Enum

Public Sub CreateTempLocalTable(tblName As String, ByRef rec As Object)
'                                                           פרוצדורה שיוצרת טבלה מקומית זמנית
'                                                                  על סמך רקורדסט שהועבר אליה
'                                         בהתחלה בודקים אם הטבלה קיימת ואם כן ננסה למחוק אותה
'                                                      אם היא נעולה, אז נמחק רק את תוכן הטבלה
'                                          במידה ומחקנו את הטבלה, ניצור אותה מחדש + נמלא אותה
'                                                 במידה ורק רוקנו את תוכנה, אז נמלא אותה מחדש
    On Error GoTo Error_Handel
      
    Dim dbs As Database, tdfNew As TableDef, fldTemp As Field, rst As DAO.Recordset, DAOfld As Variant, fld As Object, Proccess As Integer
    
    Set dbs = CurrentDb
    
    If isTableExists(tblName) Then
        
        If DeleteTable(tblName) = True Then
            Proccess = ETempTableActions.CreateNewTableAndFillIt
        Else
            Proccess = ETempTableActions.OnlyFillExistsTable
        End If
    
    Else
        
        Proccess = ETempTableActions.CreateNewTableAndFillIt
    
    End If
    
    Select Case Proccess
        
        Case ETempTableActions.CreateNewTableAndFillIt
            
            Call CreateNewTable(dbs, tdfNew, rec, tblName)
            Call InsertRecToTable(rec, tblName)
        
        Case ETempTableActions.OnlyFillExistsTable
            
            Call InsertRecToTable(rec, tblName)
    
    End Select
             
ExitHere:
    
    Exit Sub
Error_Handel:
    Err.Clear
    Resume ExitHere
End Sub
Private Sub InsertRecToTable(ByRef rec As Object, tblName As String)
    
    On Error Resume Next

    Dim rst As Recordset, DAOfld As Variant

    If Not rec.EOF Then
        rec.MoveFirst
        Set rst = CurrentDb.OpenRecordset(tblName) 'פותח עוד רקורדסט שיכיל את  הטבלה החדשה שנוצרה
        
        Do While Not rec.EOF
            
            rst.AddNew
            
            For Each DAOfld In rst.fields
                
                If DAOfld.Type = dbBoolean Then
                    rst.fields(DAOfld.Name).Value = CBool(rec.fields(DAOfld.Name).Value)
                Else
                    rst.fields(DAOfld.Name).Value = rec.fields(DAOfld.Name).Value
                End If
            
            Next DAOfld
            
            rst.Update
            
            rec.MoveNext
         Loop
    End If
    
    rst.Close
    Set rst = Nothing

    If Err.Number <> 0 Then Err.Clear

End Sub
Public Function isTableExists(tblName As String) As Boolean
'                       בודק אם טבלה בשם הזה קיימת
'                                מחזיר ערך בוליאני
    On Error GoTo Error_Handel
    Dim db As Database, tbl As TableDef, I As Integer
    Set db = CurrentDb()
    isTableExists = False
        
    For Each tbl In db.TableDefs
        If tbl.Name = tblName Then
             isTableExists = True
             Exit Function
        End If
     Next tbl

ExitHere:
    Exit Function
Error_Handel:
    Err.Clear
    isTableExists = False
    Resume ExitHere
End Function

Private Sub CreateNewTable(ByRef dbs As Object, ByRef tdfNew As TableDef, ByRef rec As Object, tblName As String)
    
    On Error GoTo Error_Handel
    
    Dim fldType As Variant, fld As Object, fldTemp As Field
    
    Set tdfNew = dbs.CreateTableDef(tblName)
    Set fld = CreateObject("ADOX.Column")   'CreateObject("ADODB.Field")
    
    With tdfNew
          ' Create fields and append them to the new TableDef
          ' object. This must be done before appending the
          ' TableDef object to the TableDefs collection of the
          ' database.
          For Each fld In rec.fields
                
                Select Case fld.Type
                    Case 202
                        fldType = dbText
                    Case 201
                        fldType = dbMemo
                    Case 10
                        fldType = dbText
                    Case 135
                        fldType = dbDate
                    Case 11
                        fldType = dbBoolean
                    Case Else
                        fldType = fld.Type
                End Select
        
                Set fldTemp = tdfNew.CreateField(fld.Name, fldType)
                If (fldType = dbText Or fldType = dbMemo) Then fldTemp.AllowZeroLength = True
                
                tdfNew.fields.Append fldTemp
            
            Next fld
    
    End With

    dbs.TableDefs.Append tdfNew
    dbs.TableDefs.Refresh
    DoEvents

ExitHere:
    Exit Sub
Error_Handel:
    Err.Clear
    Resume ExitHere
End Sub

Public Function DeleteTable(tblName As String) As Boolean
     
     On Error Resume Next
     Err.Clear
     Dim DeleteSql As String
     
     DoCmd.DeleteObject acTable, tblName
    
     DoEvents
'           לפעמים הטבלה נעולה ותתקבל במקרה הזה תקלה
        '                  במקרה כזה, נרוקן את הטבלה מרשומות
        '      ונמשיך מייד למילוי הטבלה , בלי ליצור אותה מחדש
     If Err.Number <> 0 Then '= 3211 Or Err.Number = 3021 Then
            
            DeleteSql = "DELETE * FROM " & tblName & ";"
                
                DoCmd.SetWarnings False
                DoCmd.RunSQL DeleteSql
                DoCmd.SetWarnings True
            
            DoEvents
            Err.Clear
            DeleteTable = False
     Else
            DeleteTable = True
     End If
   
End Function

ב- Access פעמים מסויימות צריך ליצור שאילתא תוך כדי ריצה

למשל כאשר רוצים ליצור שאילתת Pivot / Transpose  מותאמת למצב מסוים.

להלן 2 פונקציות Access VBA שמטפלות בשאילתות.

בדיקה אם שאילתא קיימת

Public Function isQueryExists(qryName As String) As Boolean

    On Error GoTo ErrorHandel


 Dim db As Database
 Dim qry As QueryDef
 Dim I As Integer
 Set db = CurrentDb()
 isQueryExists = False
 
 
 For Each qry In db.QueryDefs
               If qry.Name = qryName Then
                    isQueryExists = True
                    Exit Function
               End If
          Next qry

ExitHere:
    Exit Function
ErrorHandel:
    Err.Clear
    isQueryExists = False
    Resume ExitHere
End Function

מחיקת שאילתא

Public Sub DeleteQuery(qryName As String)
On Error Resume Next
    

    If isQueryExists(qryName) Then
        DoCmd.DeleteObject acQuery, qryName
        DoEvents
    End If

If Err.Number <> 0 Then Err.Clear
End Sub