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
Creating a Multi-Value field using Alphabet
Copy Fields Down from above Record
Loop thru records and OutPutTo seperate .RTF or .PDF
Modified Spell Check
Lock\Unlock Bound Controls
Loop while renumbering two columns
Create a Table with Dynamic Field Names
Snippets for Exporting to Excel
Log Field Changes
Log Record Deletions
Check for Duplicate Values
ValidateData()
ClearClipboard()
Selecting an Excel Worksheet from Access
Send eMail to Multiple Recipients
Cancel Save in a Bound Form
Automatically Send eMail Notifications
fFindBookmark()
Looping Records to Send eMail
fxlFindReplace()
fMouseOverCurrent()
fHighlightRequiredControls()
Check if Table Exists
fAmortization()
Insert (or Remove) Blank Line
Click to send feedback...
This site uses cookies to collect data on usage. By continuing to browse this site you consent to this policy. Find out more here.