ACCESS   

(Home)
Top 3 Resources

Resource

Access Support Center

Resource

MrExcel.com
Resource Formatting

Resource

ABC ~ All 'Bout Computers

Quick Reference
OpenForm  
DoCmd  
Formatting Percentage #%[Blue];(#%)[Red];"Zero"[Black];"Null"[Cyan]

Positive, Negative, Zero, Null

SendKeys (Repeat Last Value)

 SendKeys "^{'}, True
Code
Refresh Text Box me.textbox.setfocus

me.textbox = Value

me.refresh
Dir Loop (See Code @ http://allenbrowne.com/ser-59.html) Private Function FillDir(colDirList As Collection, ByVal strFolder As String, strFileSpec As String, _ bIncludeSubfolders As Boolean) 

'Build up a list of files, and then add add to this list, any additional folders Dim strTemp As String 

Dim colFolders As New Collection 

Dim vFolderName As Variant 'Add the files to the folder. 

strFolder = TrailingSlash(strFolder) 

strTemp = Dir(strFolder & strFileSpec) 

Do While strTemp <> vbNullString colDirList.Add strFolder & strTemp strTemp = Dir Loop 

If bIncludeSubfolders Then 'Build collection of additional subfolders. strTemp = Dir(strFolder, vbDirectory) 

Do While strTemp <> vbNullString If (strTemp <> ".") And (strTemp <> "..") Then If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0& Then colFolders.Add strTemp 

End If 

End If 

strTemp = Dir Loop 'Call function recursively for each subfolder. 

For Each vFolderName In colFolders 

Call FillDir(colDirList, strFolder & TrailingSlash(vFolderName),strFileSpec, True) 

Next vFolderName 

End If 

End Function
Set Menus How to Dim Menu Items or Disable Toolbar Buttons in VBA

Set Menu Items

 Private Sub Form_Open(cancel As Integer)
Dim cnn As ADODB.Connection
Dim rst As New ADODB.Recordset
Dim rst1 As New ADODB.Recordset
Dim strSQL As String
Dim cbr As Object
Dim Menu1 As String
Dim Menu2 As String
Dim Menu3 As String
Dim Menu4 As String
Dim Menu5 As String
Dim CBarTool As CommandBar
Dim i As Integer
Dim strTbrName
Dim fg_found As Boolean

Set cnn = CurrentProject.Connection
strSQL = "SELECT * FROM tblExceptions WHERE exc_StaffID = '"
strSQL = strSQL & Format(gbl_StaffID, "&&********") & "'"
strSQL = strSQL & " ORDER BY exc_type, exc_Control"
rst.Open strSQL, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
If rst.RecordCount > 0 Then
Do While Not rst.EOF
'short menu settings
If rst![exc_Type] = 1 Then
Menu1 = Trim(rst![exc_Menu1])
Menu2 = Trim(rst![exc_Menu2])
Menu3 = Trim(rst![exc_Control])
'MsgBox rst![exc_Type] & " " & rst![exc_Control]
'If Menu3 = "Work Status Summary" Then
' MsgBox "here"
'End If
Select Case Menu3
Case "Find"
Menu3 = "Find..."
Case "Replace"
Menu3 = "Replace..."
Case "Print"
Menu3 = "Print..."
Case "Page Setup"
Menu3 = "Page Setup..."
Case "Paste Special"
Menu3 = "Paste Special..."
Case Else

End Select

'determine whether to enable or not!
If Menu3 = "Quality Manager" Then
fg_found = False
strSQL = "SELECT * FROM tblQAAssign"
rst1.Open strSQL, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
If rst1.RecordCount > 0 Then
Do While Not rst1.EOF
If gbl_TechID = rst1![qaa_technician] Then
'enable menu item
Set cbr = CommandBars(Menu1).Controls(Menu2).Controls(Menu3)
cbr.Enabled = True
fg_found = True
'Exit Do
End If
rst1.MoveNext
Loop
If fg_found = False Then
'disable menu item
Set cbr = CommandBars(Menu1).Controls(Menu2).Controls(Menu3)
cbr.Enabled = False
End If
Else
'disable menu item
Set cbr = CommandBars(Menu1).Controls(Menu2).Controls(Menu3)
cbr.Enabled = False
End If
rst1.Close
Set rst1 = Nothing
Else
'set to tblException value
Set cbr = CommandBars(Menu1).Controls(Menu2).Controls(Menu3)
cbr.Enabled = rst![exc_Apply]
End If
End If

'long menu settings
If rst![exc_Type] = 2 Then
Menu1 = rst![exc_Menu1]
Menu2 = rst![exc_Menu2]
Menu3 = rst![exc_Menu3]
Menu4 = rst![exc_Control]

Select Case Menu4
Case "Work Orders"
Menu4 = "Work Orders..."
Case "Unlock Records"
Menu4 = "Unlock Records..."
Case "Complete Work Order"
Menu4 = "Complete Work Order..."
Case "Reprint"
Menu4 = "Reprint..."
Case "Lock Invoices"
Menu4 = "Lock Invoices..."
Case "Unlock Invoices"
Menu4 = "Unlock Invoices..."
Case Else

End Select

Set cbr = CommandBars(Menu1).Controls(Menu2).Controls(Menu3)._ Controls(Menu4)
cbr.Enabled = rst![exc_Apply]
End If

'toolbar settings
If rst![exc_Type] = 3 Then
Menu1 = rst![exc_Menu1]
Menu2 = rst![exc_Control]
Set cbr = CommandBars(Menu1).Controls(Menu2)
cbr.Enabled = rst![exc_Apply]
End If
'command button settings
If rst![exc_Type] = 4 Then
Menu4 = rst![exc_Control]
Set cbr = Me.Controls(Menu4)
cbr.Enabled = rst![exc_Apply]
End If
'longest menu settings
If rst![exc_Type] = 5 Then
Menu1 = rst![exc_Menu1]
Menu2 = rst![exc_Menu2]
Menu3 = rst![exc_Menu3]
Menu4 = rst![exc_Menu4]
Menu5 = rst![exc_Control]
'Select Case Menu5
' Case "Lock Records"
' Menu4 = "Lock Records..."
' Case "Unlock Records"
' Menu4 = "Unlock Records..."
' Case "Complete Work Order"
' Menu4 = "Complete Work Order..."
' Case "Reprint"
' Menu4 = "Reprint..."
' Case "Lock Invoices"
' Menu4 = "Lock Invoices..."
' Case "Unlock Invoices"
' Menu4 = "Unlock Invoices..."
' Case Else
'
'End Select
Set cbr = CommandBars(Menu1).Controls(Menu2).Controls(Menu3)._ Controls(Menu4).Controls(Menu5)
cbr.Enabled = rst![exc_Apply]
End If
rst.MoveNext
Loop
Else
'MsgBox "No user logged on!"
rst.Close
Set rst = Nothing
DoCmd.Quit
Exit Sub
End If
rst.Close
Set rst = Nothing

'only show MetNav related Menu Bars and toolbars
For i = 1 To CommandBars.count
Set CBarTool = CommandBars.Item(i)
strTbrName = CBarTool.Name
If CBarTool.Name = "Menu Bar" Then
DoCmd.ShowToolbar strTbrName, acToolbarNo
ElseIf CBarTool.Name = "NAV" Then
DoCmd.ShowToolbar strTbrName, acToolbarYes
ElseIf CBarTool.Name = "Navigator" Then
DoCmd.ShowToolbar strTbrName, acToolbarYes
Else
DoCmd.ShowToolbar strTbrName, acToolbarNo
End If
Next i

'display user name in main menu titlebar
Me.Caption = "Main Menu - " & gbl_UserName

'welcome user from the status bar
Application.Echo False
Application.Echo True, "Welcome to METROLOGY NAVIGATOR"

End Sub
Excel SpreadSheet Dim MyXL As Object, xlFileAttribute As String
Dim xlFile As String, xlpw As String

DoCmd.SetWarnings False

xlFile = "c:\excel\book1.xls"

'Set file attributes here
xlFileAttribute = GetAttr(xlFile) ' Returns 1.
If xlFileAttribute = 1 Then
SetAttr (xlFile), vbNormal
End If

'Defer error trapping.
'If the application isn't running, an error occurs.
On Error Resume Next
Set MyXL = GetObject(, "Excel.Application")
Set MyXL = CreateObject("Excel.Application")

'Clear err object
Err.Clear

'Disarm all warnings
MyXL.Application.DisplayAlerts = False
MyXL.Application.AlertBeforeOverwriting = False
MyXL.Application.Visible = True
MyXL.Workbooks.Open (xlFile)

'Update Pivottables and Save the File

MyXL.Application.Activeworkbook.Sheets
("sheet1").Select
MyXL.Application.ActiveSheet.Range("A16").Value
= "opened"
MyXL.Application.Activeworkbook.Save
MyXL.Application.Activeworkbook.Close

'Save Excel file, close & destroy all Excel objects
'Arm all warnings before quiting Excel
MyXL.Application.DisplayAlerts = True
MyXL.Application.AlertBeforeOverwriting = True
MyXL.Application.Quit
Set MyXL = Nothing

Courtesy of Gary B.
Weekday dim i as integer    

i = weekday(date)
Stored Procedure with parameters Sub ExecuteStoredProcedureExample()
Dim intNoteId As Integer
Dim strNote As String
Dim strUserid As String
Dim dateNote As Date

'initialize
intNoteId = 209
strNote = "Test from below"
strUserid = "jxm"
dateNote = Now()

Set cnn = New ADODB.Connection
cnn.ConnectionString = "Provider=SQLOLEDB;Data Source=myServer;Initial Catalog='myDatabase';Integrated Security='SSPI';"
cnn.ConnectionTimeout = 5
cnn.Open
Set cmd = CreateObject("ADODB.Command")
Set cmd.ActiveConnection = cnn
cmd.CommandType = adCmdStoredProc
cmd.CommandText = "WMLData1.dbo.spMR_Insert_Note"

'id
cmd.Parameters.Append _
cmd.CreateParameter("@mrNote_ID", adInteger, adParamInput, 8, intNoteId)
'note
cmd.Parameters.Append _
cmd.CreateParameter("@mrNote_note", adVarChar, adParamInput, 150, strNote)
'date
cmd.Parameters.Append _
cmd.CreateParameter("@mrNote_date", adDate, adParamInput, 8, dateNote)
'userid
cmd.Parameters.Append _
cmd.CreateParameter("@mrNote_userid", adVarChar, adParamInput, 15, strUserid)

cmd.Execute
Set cmd = Nothing
cnn.Close
Set cnn = Nothing

End Sub
Setfocus To SubForm From MainForm 'be sure and use all of the lines of code to execute!

Me![fsubNotes].SetFocus

' Select the nested Orders Subform subform control.
Me![fsubNotes].Form![note_note].SetFocus

Stored Procedure with parameters Dim objCmd As New ADODB.Command
Dim msg, style, Title, Response, MyString

With objCmd
'Insert Work Order
DoCmd.Echo True, "Inserting Work Order into Edit Table!"
Set .ActiveConnection = CurrentProject.Connection
'Name of the Stored Procedure
.CommandText = "spWorkOrder_EditInsert"
.CommandType = adCmdStoredProc
'***************************************
'Define The Input Parameters
'***************************************
.Parameters.Append .CreateParameter("workorder", adInteger, adParamInput)
.Parameters("workorder") = Forms!frmWorkOrder!WorkOrder
.Parameters.Append .CreateParameter("LaboratoryID", adVarChar, adParamInput, 50)
.Parameters("LaboratoryID") = Me![LaboratoryID]
.Parameters.Append .CreateParameter("ClientAccountNumber", adVarChar, adParamInput, 15)
.Parameters("ClientAccountNumber") = Forms!frmWorkOrder!AccountNumber
.Parameters.Append .CreateParameter("DateReceived", adDate, adParamInput)
.Parameters("DateReceived") = Forms!frmWorkOrder![Date Received]
.Parameters.Append .CreateParameter("QACheck", adBoolean, adParamInput)
.Parameters("QACheck") = Forms!frmWorkOrder![QACheck]
.Parameters.Append .CreateParameter("LaborRate", adCurrency, adParamInput)
.Parameters("LaborRate") = Forms!frmWorkOrder![Labor]


'Execute the Stored Procedure
.Execute
End With
Set objCmd = Nothing
Listbox Value List

Dim cmb As ComboBox

Set cmb = me.ControlName

cmb.RowSourceType = "Value List"

cmb.RowSource = "Excellent;Good;Average;Poor"

The row source is just a string that is semi colon delimited!

SubForm SelTop Method

(Subforms have no SelTop)

 If TabWorkOrder.Value = 7 Then
   fsubWOCalRecord.Requery
   Me!fsubWOCalRecord.SetFocus
   Me!fsubWOCalRecord.Form!CertificateNumber.SetFocus
            If Len(gbl_strFind) > 0 Then
               DoCmd.FindRecord gbl_strFind                                                                    End If
End If

This really works! I spent hours covering the net and came up with nothing that could access a specific row on a subform. As long as your displaying a unique key of some sort in your subform, it's easy.

 

You could probably add

DoCmd.RunCommand acCmdNextRecord or something that!

GET SUBFORM SELTOP SELHEIGHT Create two public variables at the module level

Public t = objectname.selTop

Public h = objectname.selHeight

Populate the variables at the form level in the click event.

ISLASTWEEKOFMONTH FUNCTION Private Function IsLastWeekOfMonth(curDate As Date) As Boolean
   IsLastWeekOfMonth = False
   Dim x As Integer
   'what year month and day is it?
   x = GetMonthDays(curDate)
   If x - Day(curDate) <= 6 Then
       IsLastWeekOfMonth = True
   End If
End Function
GETMONTHDAYS FUNCTION Public Function GetMonthDays(ByVal vdat As Date) As Integer
 GetMonthDays = Day(DateSerial(Year(vdat), Month(vdat) + 1, 0))
End Function
EXPORT TABLE TO EXCEL dim strsql as string
strsql = "Select * from table1"
DoCmd.OutputTo acOutputTable, strsql, acFormatXLS, "c:\tester1.xls",
True
SETFOCUS TO DATABASE WINDOW    'SETSFOCUS TO DATABASE WINDOW
   DoCmd.SelectObject acStoredProcedure, , True
   
   SendKeys "{F5}", False
ITERATE THRU SUBFORM On Error GoTo Err_SelectTechnician_Click:
   Dim i As Integer
   Dim holdKey As Long
   Dim strSQL As String
   Dim cnn As ADODB.Connection
   Dim rst As New ADODB.Recordset
   
   DoCmd.OpenForm "fdlgTechnician", , , , , acDialog
   If fg_cancel = True Then Exit Sub
   If fg_authenticate = True Then
       Forms!frmaddOn.TimerInterval = 0
       For i = t To (t + h) - 1
           DoCmd.GoToRecord , , acGoTo, i
           holdKey = Me.ct_ID
                               
           'print report
           DoCmd.OpenReport "rpt AddOn Verification", , , "[ct_ID = '" &
holdKey & "'"
   
           'update all related records to Add-On User
           strSQL = "SELECT * FROM tblAddOnLog_Codes WHERE AddOnLogID = '"
& Me.ct_ID & "'"
           Set cnn = CurrentProject.Connection
           rst.Open strSQL, CurrentProject.Connection, adOpenKeyset,
adLockPessimistic
           Do While Not rst.EOF
               rst![AddOnstatus] = 1
               rst.Update
             rst.MoveNext
           Loop
           rst.Close
           Set rst = Nothing
       Next i
       'refresh screen
       Forms!frmAddOns!fsubAddOns_New.Requery
   End If
Exit_SelectTechnician_Click:
       Forms!frmaddOn.TimerInterval = 3000
Err_SelectTechnician_Click:
   MsgBox "Error " & Err.Number & " " & Err.Description
   Resume Exit_SelectTechnician_Click: