Norie
05-07-2005, 10:49 AM
Option Compare Database
Option Explicit
Sub AddQueryCombo()
Dim cmdContracts As CommandBar
Dim cmdQueries As CommandBarComboBox
Dim db As Database
Dim qdf As QueryDef
Dim Exists
Set cmdContracts = CommandBars("Contracts")
Exists = IsCmdCtrl(cmdContracts, "cboqueries")
If Exists Then
Set cmdQueries = CommandBars.FindControl(msoControlComboBox, , "cboQueries")
Else
Set cmdQueries = cmdContracts.Controls.Add(msoControlComboBox, , "cboQueries")
cmdQueries.Tag = "cboQueries"
End If
Set db = CurrentDb
cmdQueries.Clear
cmdQueries.AddItem "New Query"
For Each qdf In db.QueryDefs
If Left(qdf.Name, 1) <> "~" Then
cmdQueries.AddItem qdf.Name
End If
Next
cmdQueries.ListIndex = 1
cmdQueries.Width = 130
End Sub
Function IsCmdCtrl(cmdBar, ctrlTag) As Boolean
Dim cmdctrl
For Each cmdctrl In cmdBar.Controls
IsCmdCtrl = (cmdctrl.Tag = ctrlTag)
If IsCmdCtrl Then Exit Function
Next
End Function
Function GotoQuery(qryView As Integer)
Dim qryName As String
qryName = CommandBars.FindControl(msoControlComboBox, , "cboQueries").Text
If qryName <> "New Query" Then
DoCmd.OpenQuery qryName, qryView
Else
NewQuery
End If
End Function
Public Function InStrRev(SearchText As String, FindText As String) As Long
Dim RevSearchText As String
Dim LengthSearchText As Long
Dim I%
LengthSearchText = Len(SearchText)
For I = LengthSearchText To 1 Step -1
RevSearchText = RevSearchText & Mid(SearchText, I, 1)
Next I
InStrRev = InStr(RevSearchText, FindText)
InStrRev = LengthSearchText - InStrRev + 1
End Function
Function IsQuery(qryName As String) As Boolean
' returns true if there is a query called qryName
Dim db As Database
Dim qdf As QueryDef
Set db = CurrentDb
For Each qdf In db.QueryDefs
IsQuery = (qdf.Name = qryName)
If IsQuery Then Exit Function
Next
End Function
Function IsTable(tblName As String) As Boolean
' returns true if there is a query called qryName
Dim db As Database
Dim tdf As TableDef
Set db = CurrentDb
For Each tdf In db.TableDefs
IsTable = (tdf.Name = tblName)
If IsTable Then Exit Function
Next
End Function
Public Function NewQuery() As Boolean
' this will create then open a new query called qryName
On Error GoTo Err_NewQuery
Dim qryName
Dim db As Database
qryName = InputBox("Please enter a name for the query:", "Create new query")
If qryName = "" Then
Exit Function
Else
Set db = CurrentDb
db.CreateQueryDef qryName
DoCmd.OpenQuery qryName, acViewDesign
End If
NewQuery = True
Exit_NewQuery:
Exit Function
Err_NewQuery:
MsgBox Err.Description, vbInformation, "Error message"
NewQuery = False
Resume Exit_NewQuery
End Function
Public Sub SearchProcs()
' this will search each form's module for a string
' and leave it open if it is found
Dim frm As Form, mdl As Module
Dim dbs As Database, ctr As Container, doc As Document
Dim X As Long
Dim strString As String
strString = InputBox("What text do you wish to search for?", "Search text")
If strString = "" Then Exit Sub
Set dbs = CurrentDb
Set ctr = dbs.Containers!Forms
For Each doc In ctr.Documents
If Not IsLoaded(doc.Name) Then DoCmd.OpenForm doc.Name, acDesign
Set frm = Forms(doc.Name)
Set mdl = frm.Module
Set mdl = frm.Module
If Not mdl.Find(strString, X, X, X, X) Then DoCmd.Close acForm, doc.Name
Next
End Sub
Function LetEdit(frmName As String, Optional ctrlFocus As String) As Boolean
' allows form frmName to be edited and sets the focus to
' control ctrlFocus
Dim frm As Form, ctrl As Control
Dim CType%
On Error GoTo Err_LetEdit
Set frm = Forms(frmName)
If Not (IsControl(frmName, ctrlFocus)) Then GoTo Exit_LetEdit
For Each ctrl In frm
CType = ctrl.ControlType
If (CType = acTextBox) Or (CType = acComboBox) Then
If Not ctrl.Locked Then ctrl.BackColor = vbWhite
End If
Next
frm.AllowEdits = True
DoCmd.GoToRecord acDataForm, frm.Name, acFirst
If Not IsMissing(ctrlFocus) Then
frm.Controls(ctrlFocus).SetFocus
End If
LetEdit = True
Exit_LetEdit:
Exit Function
Err_LetEdit:
MsgBox Err.Description, vbInformation, "Error message"
LetEdit = False
Resume Exit_LetEdit
End Function
Option Explicit
Sub AddQueryCombo()
Dim cmdContracts As CommandBar
Dim cmdQueries As CommandBarComboBox
Dim db As Database
Dim qdf As QueryDef
Dim Exists
Set cmdContracts = CommandBars("Contracts")
Exists = IsCmdCtrl(cmdContracts, "cboqueries")
If Exists Then
Set cmdQueries = CommandBars.FindControl(msoControlComboBox, , "cboQueries")
Else
Set cmdQueries = cmdContracts.Controls.Add(msoControlComboBox, , "cboQueries")
cmdQueries.Tag = "cboQueries"
End If
Set db = CurrentDb
cmdQueries.Clear
cmdQueries.AddItem "New Query"
For Each qdf In db.QueryDefs
If Left(qdf.Name, 1) <> "~" Then
cmdQueries.AddItem qdf.Name
End If
Next
cmdQueries.ListIndex = 1
cmdQueries.Width = 130
End Sub
Function IsCmdCtrl(cmdBar, ctrlTag) As Boolean
Dim cmdctrl
For Each cmdctrl In cmdBar.Controls
IsCmdCtrl = (cmdctrl.Tag = ctrlTag)
If IsCmdCtrl Then Exit Function
Next
End Function
Function GotoQuery(qryView As Integer)
Dim qryName As String
qryName = CommandBars.FindControl(msoControlComboBox, , "cboQueries").Text
If qryName <> "New Query" Then
DoCmd.OpenQuery qryName, qryView
Else
NewQuery
End If
End Function
Public Function InStrRev(SearchText As String, FindText As String) As Long
Dim RevSearchText As String
Dim LengthSearchText As Long
Dim I%
LengthSearchText = Len(SearchText)
For I = LengthSearchText To 1 Step -1
RevSearchText = RevSearchText & Mid(SearchText, I, 1)
Next I
InStrRev = InStr(RevSearchText, FindText)
InStrRev = LengthSearchText - InStrRev + 1
End Function
Function IsQuery(qryName As String) As Boolean
' returns true if there is a query called qryName
Dim db As Database
Dim qdf As QueryDef
Set db = CurrentDb
For Each qdf In db.QueryDefs
IsQuery = (qdf.Name = qryName)
If IsQuery Then Exit Function
Next
End Function
Function IsTable(tblName As String) As Boolean
' returns true if there is a query called qryName
Dim db As Database
Dim tdf As TableDef
Set db = CurrentDb
For Each tdf In db.TableDefs
IsTable = (tdf.Name = tblName)
If IsTable Then Exit Function
Next
End Function
Public Function NewQuery() As Boolean
' this will create then open a new query called qryName
On Error GoTo Err_NewQuery
Dim qryName
Dim db As Database
qryName = InputBox("Please enter a name for the query:", "Create new query")
If qryName = "" Then
Exit Function
Else
Set db = CurrentDb
db.CreateQueryDef qryName
DoCmd.OpenQuery qryName, acViewDesign
End If
NewQuery = True
Exit_NewQuery:
Exit Function
Err_NewQuery:
MsgBox Err.Description, vbInformation, "Error message"
NewQuery = False
Resume Exit_NewQuery
End Function
Public Sub SearchProcs()
' this will search each form's module for a string
' and leave it open if it is found
Dim frm As Form, mdl As Module
Dim dbs As Database, ctr As Container, doc As Document
Dim X As Long
Dim strString As String
strString = InputBox("What text do you wish to search for?", "Search text")
If strString = "" Then Exit Sub
Set dbs = CurrentDb
Set ctr = dbs.Containers!Forms
For Each doc In ctr.Documents
If Not IsLoaded(doc.Name) Then DoCmd.OpenForm doc.Name, acDesign
Set frm = Forms(doc.Name)
Set mdl = frm.Module
Set mdl = frm.Module
If Not mdl.Find(strString, X, X, X, X) Then DoCmd.Close acForm, doc.Name
Next
End Sub
Function LetEdit(frmName As String, Optional ctrlFocus As String) As Boolean
' allows form frmName to be edited and sets the focus to
' control ctrlFocus
Dim frm As Form, ctrl As Control
Dim CType%
On Error GoTo Err_LetEdit
Set frm = Forms(frmName)
If Not (IsControl(frmName, ctrlFocus)) Then GoTo Exit_LetEdit
For Each ctrl In frm
CType = ctrl.ControlType
If (CType = acTextBox) Or (CType = acComboBox) Then
If Not ctrl.Locked Then ctrl.BackColor = vbWhite
End If
Next
frm.AllowEdits = True
DoCmd.GoToRecord acDataForm, frm.Name, acFirst
If Not IsMissing(ctrlFocus) Then
frm.Controls(ctrlFocus).SetFocus
End If
LetEdit = True
Exit_LetEdit:
Exit Function
Err_LetEdit:
MsgBox Err.Description, vbInformation, "Error message"
LetEdit = False
Resume Exit_LetEdit
End Function