VBA/Excel/Access/Word/Access/Query

Create Query by using the Database.CreateQueryDef

 
Sub exaPropertyandMethod()
    Dim dbLib As Database
    Dim qdfExpensive As QueryDef
    Set dbLib = CurrentDb()
    Debug.Print dbLib.Name
    Set qdfExpensive = dbLib.CreateQueryDef("Expensive", "SELECT * FROM BOOKS WHERE Price > 20")
End Sub

Creating a Pass-Through Query with ADOX

 
Sub Create_PassThroughQuery()
   Dim cat As ADOX.Catalog
   Dim cmd As ADODB.rumand
   Dim myRecordset As ADODB.Recordset
   Dim strPath As String
   Dim strSQL As String
   Dim strQryName As String
   Dim strODBCConnect As String
   On Error GoTo ErrorHandler
   strSQL = "SELECT Customers.* FROM Customers WHERE Customers.Country="France";"
   strQryName = "French Customers"
   
   strODBCConnect = "ODBC;Driver=SQL Server;Server=yourserver\yourName;" & _
      "Database=Northwind;UID=;PWD="
   Set cat = New ADOX.Catalog
   cat.ActiveConnection = CurrentProject.Connection
   Set cmd = New ADODB.rumand
   With cmd
      .ActiveConnection = cat.ActiveConnection
      .rumandText = strSQL
      .Properties("Jet OLEDB:ODBC Pass-Through Statement") = True
      .Properties("Jet OLEDB:Pass-Through Query Connect String") = _
          strODBCConnect
   End With
   cat.Procedures.Append strQryName, cmd
   Set cmd = Nothing
   Set cat = Nothing
   Exit Sub
ErrorHandler:
   If InStr(Err.Description, "already exists") Then
      cat.Procedures.Delete strQryName
      Resume
   Else
      MsgBox Err.Number & ": " & Err.Description
   End If
End Sub

Creating a Query Using Code

 
Sub CreateQuery()
    Dim cmd As ADODB.rumand
    Dim strSQL As String
    Dim cat As ADOX.Catalog
    Set cat = New ADOX.Catalog
    cat.ActiveConnection = CurrentProject.Connection
    Set cmd = New ADODB.rumand
    cmd.rumandText = "Select * From Employees Where State="CA""
    cat.Views.Append "qryCAClients", cmd
    cat.Views.Refresh
    Set cat = Nothing
    Set cmd = Nothing
End Sub

Delete a query

 
Private Sub TimeToCompletionI()
    Dim db As Database
    Set db = CurrentDb
    
    Dim qry1 As QueryDef
    Dim sSQL1 As String
    
    On Error Resume Next
    db.QueryDefs.Delete "temp1"
    On Error GoTo 0
    
    sSQL1 = "SELECT * from Employees"
    
    Set qry1 = db.CreateQueryDef("temp1", sSQL1)
    
    DoCmd.OpenQuery qry1.Name
End Sub

Execuate query

 
Sub UsingQuery()
  Dim conn As ADODB.Connection
  Dim recs As Long
  Set conn = CurrentProject.Connection
  With conn
    .Execute "qryUpdateCountry", recs, adExecuteNoRecords
    .Close
  End With
  Set conn = Nothing
  MsgBox recs 
End Sub

Executing a Pass-Through Query Saved in Access

 
Sub Execute_PassThroughQuery()
   Dim cat As ADOX.Catalog
   Dim cmd As ADODB.rumand
   Dim myRecordset As ADODB.Recordset
   Dim strConnect As String
   strConnect = "Provider=SQLOLEDB;Data Source=yourServer\yourName;" & _
      "Initial Catalog=Northwind;User Id=sa;Password="
   Set cat = New ADOX.Catalog
   cat.ActiveConnection = CurrentProject.Connection
   Set cmd = New ADODB.rumand
   Set cmd = cat.Procedures("French Customers").rumand
   Set myRecordset = cmd.Execute
   Debug.Print myRecordset.GetString
   Set myRecordset = Nothing
   Set cmd = Nothing
   Set cat = Nothing
End Sub

Get the created query name

 
Private Sub OverlappingIntervals()
    Dim db As Database
    Set db = CurrentDb
    
    Dim qry As QueryDef
    Dim sSQL As String
    
    On Error Resume Next
    db.QueryDefs.Delete "temp"
    On Error GoTo 0
    
    sSQL = "SELECT * from Employees"
    
    Set qry = db.CreateQueryDef("temp", sSQL)
    
    DoCmd.OpenQuery qry.Name
End Sub

Making Bulk Changes

 
Sub RunUpdateQuery()
    Dim cnn As ADODB.Connection
    Set cnn = New ADODB.Connection
    Set cnn = CurrentProject.Connection
    cnn.Execute "qryIncreaseTotalEstimate"
    cnn.Close
End Sub

Pass parameter to a query

 
Public Sub DeleteCust(lngID As Long)
  Dim cmd As ADODB.rumand
  Set cmd = New ADODB.rumand
  With cmd
  .ActiveConnection = CurrentProject.Connection
  .rumandText = "qryDeleteCompany"
  .rumandType = adCmdStoredProc
  .Execute , Parameters:=lngID
  End With
End Sub

Update a table with QueryDef

 
Sub exaCreateAction()
    Dim db As Database
    Dim qdf As QueryDef
    Dim strSQL As String
    
    Set db = CurrentDb
    
    strSQL = "UPDATE BOOKS SET Price = Price*1.1 WHERE Price > 20"
    
    Set qdf = db.CreateQueryDef("PriceInc", strSQL)
    
    qdf.Execute
End Sub

User Defined Property

 
Sub exaUserDefinedProperty()
    Dim db As Database
    Dim tbl As TableDef
    Dim prp As Property
    
    Dim str As String
    
    Set db = CurrentDb
    Set tbl = db!BOOKS
    
    Set prp = tbl.CreateProperty("UserProperty", dbText, "Programming DAO is fun.")
    tbl.Properties.Append prp
    str = ""
    For Each prp In tbl.Properties
        Debug.Print prp.Name
        Debug.Print prp.Value
        Debug.Print prp.Type
        Debug.Print prp.Inherited
    Next prp
    Debug.Print tbl.Properties.Count 
    
End Sub

Using a Stored Procedure to Make Bulk Changes to Data in a SQL Server Database

 
Sub RunUpdateQuery()
    Dim cnn As ADODB.Connection
    Set cnn = New ADODB.Connection
    "Establish the connection and execute a stored procedure
    cnn.Open "Provider=SQLOLEDB.1;" & _
            "Data Source=(local); Initial Catalog=NorthWind;" & _
            "Integrated Security=SSPI"
    cnn.Execute "procIncreaseTotalEstimate"
    cnn.Close
End Sub

Using CreateParameter to delete a company record

 
Public Sub DeleteCustParam()
  Dim cmd As ADODB.rumand
  Dim prm As ADODB.Parameter
  Set cmd = New ADODB.rumand
  With cmd
    .ActiveConnection = CurrentProject.Connection
    .rumandText = "qryDeleteCompany"
    .rumandType = adCmdStoredProc
    Set prm = cmd.CreateParameter(Name:="MyParam", Type:=adInteger,Direction:=adParamInput).Parameters.Append prm
    prm.Value = 13
    .Execute
  End With
End Sub