Access-Diva Code Snippets

Code Snippets...

Most code here has been tested and, in some cases, used. Any code untested will be marked accordingly. We offer no support for the code or your ability to implement it. If you require assistance please post in one of the newsgroups listed here. It is strongly recommended you test the code in a copy of your database. In other words, use at your own risk!

= Click to view where Code Block was used

Create a Custom ID...

Add a custom Record Count...

Limit the amount of Records that can be entered in a Continuous Form...

Change Control Source of Combo Box based on previous Combo Box...

Sort Records using Labels...

Traffic Light changes colors based on conditions (well, really the Image changes)...

Original Image

The code below demonstrates how *change* the light based on Contract parameters...

As you can see I don't store my images in the database. I create a subfolder images to store all images including logos used in the database on forms and reports. (I name all logos *MyLogo.png* so I have less coding to amend.)

Images take up space and cause bloating which would push your database to its max size (2 GIG) very quickly, especially if your database is image intensive. Try this link which has MANY samples of how to insert/display images in forms and reports without storing them in the database... Image Handling

The difficult I do immediately, the impossible takes a little bit longer.

Private Sub cmdAddNewQuote_Click()
On Error Resume Next
'501121
If Not IsNull([cboCompanyID]) Then
     DoCmd.GoToRecord , , acNewRec
     Me.txtQuoteID = StrReverse(Format(Date, "yy")) & Format(Date, "m") & Format(Date, "d") & "-" & DMax(Right([qQuoteID], 1), "tblQuote") + 1
     Me.cboQuoteID = Me.txtQuoteID
Else
     MsgBox "You MUST select a Company first!", vbCritical, "New Quote"
End If
 
End Sub

With Me.RecordsetClone
     .MoveLast
     Me.txtPage = Me.CurrentRecord & " of " & .RecordCount & " line(s)"
End With

Private Sub Form_BeforeInsert(Cancel As Integer)
On Error Resume Next
If Not IsNull([txtFFESpecificationID]) Then
     If DCount("ffessFFESpecificationID", "tblFFESpecificationSize", "[ffessFFESpecificationID]=" & Me![txtFFESpecificationID]) = 4 Then
          MsgBox "Only 4 sizes allowed per sheet!", vbExclamation + vbOKOnly, "FF&E Size"
          Me!txtFFESpecificationID.Undo
          Me!txtSize.Undo
          DoCmd.RunCommand acCmdUndo
          DoCmd.GoToRecord , , acPrevious
     End If
End If
End Sub

Private Sub cboInvoiceTo_AfterUpdate()
On Error Resume Next
Select Case Me!cboInvoiceTo
     Case 0: Me!cboInvoiceToID.RowSource = ""
          MsgBox "You don't need to add an Invoice To!"
     Case 1: Me!cboInvoiceToID.RowSource = ""
          MsgBox "You don't need to add an Invoice To!"
     Case 2: Me!cboInvoiceToID.RowSource = "SELECT DISTINCT tblInvoiceTo.itInvoiceToID, tblInvoiceTo.itCompanyName FROM tblInvoiceTo ORDER BY tblInvoiceTo.itCompanyName;"
     Case 3: Me!cboInvoiceToID.RowSource = "SELECT DISTINCT tblInvoiceTo.itInvoiceToID, tblInvoiceTo.itCompanyName FROM tblInvoiceTo ORDER BY tblInvoiceTo.itCompanyName;"
     Case 4: Me!cboInvoiceToID.RowSource = "SELECT DISTINCT tblInvoiceTo.itInvoiceToID, tblInvoiceTo.itCompanyName FROM tblInvoiceTo ORDER BY tblInvoiceTo.itCompanyName;"
     Case 5: Me!cboInvoiceToID.RowSource = "SELECT DISTINCT tblInvoiceTo.itInvoiceToID, tblInvoiceTo.itCompanyName FROM tblInvoiceTo ORDER BY tblInvoiceTo.itCompanyName;"
End Select
  On Error GoTo 0
End Sub

Private Sub lblBuyerName_Click()
On Error Resume Next
     Me.txtBuyerName.SetFocus
 
         If Me.lblBuyerName.BackColor = -2147483633 Then
              DoCmd.RunCommand acCmdSortDescending
              Me.lblBuyerName.BackColor = 6697728  'Golden Yellow
              Me.lblBuyerName.Caption = vbCrLf & " Buyer's Name " & Chr(118)
              Me.lblLastLogDate.Caption = "Last" & vbCrLf & "Log Date"
              Me.lblState.Caption = vbCrLf & "State"
         Else
              DoCmd.RunCommand acCmdSortAscending
              Me.lblBuyerName.BackColor = -2147483633  'Transparent
              Me.lblBuyerName.Caption = vbCrLf & " Buyer's Name " & Chr(94)
              Me.lblLastLogDate.Caption = "Last" & vbCrLf & "Log Date"
              Me.lblState.Caption = vbCrLf & "State"
         End If
End Sub

Private Sub Form_Current()
On Error Resume Next
'From http://www.access-diva.com
If Me.txtEndDate < Date Then
     Me.imgTrafficLight.Picture = "C:/GTC/Images/TrafficLightRed.png"
     Me.txtNoContract = "Expired Contract!"
Else
     Me.txtNoContract = ""
End If
 
If Me.chkOverride = -1 Then
     Me.imgTrafficLight.Picture = "C:/GTC/Images/TrafficLightRed.png"
Else
     If Me.txtEndDate > Date Or IsNull([txtInvoicePaidDate]) Then
          Me.imgTrafficLight.Picture = "C:/GTC/Images/TrafficLightYellow.png"
 
          If Me.txtEndDate > Date And Not IsNull([txtInvoicePaidDate]) Then
               Me.imgTrafficLight.Picture = "C:/GTC/Images/TrafficLightGreen.png"
          End If
     End If
End If
End Sub

VBA

Tips (Main)

Home