Question about Saving RichText Data to an Access Database

[Lyzarus]

Hello everyone! This is my first post here, so if I am missing something please let me know!

I work with a vb5 program written 20 years ago by someone who doesn't work here anymore. He did not know how to code and was teaching himself as he was building it. The programs use is to sort and interact with archaeological collections. It has been in use since he built it and while it isn't perfect by any means it does work.

Around 2011 someone in the collection took over handling of human remains and build his own access form to handle it. It never worked right and the data was spotty at best. This year someone else is taking over so I planned on merging the data set from the access form to the old program (since we have about 20 modules there and they all work together anyway). I have hit a bit of a snag.

The main problem is Rich Text. The 2011 access form uses rich text to display everything and of course, the old data base is done entirely with plain text txtData boxes. Between this and the control array used I'm not sure how to handle the situation as my knowledge of coding isn't exactly the strongest, particularly in VB5.

I have gotten everything to work so far, but I can't get it to prompt to save changes on removal of focus.

No matter what I do the Rich Text box will not prompt a message box. Since he has this... gibberish way of doing things I can't even really translate what he is doing. Is there a simple way to check an RTB for changes, pop a message box confirming, and write said changes to an access table?

Or is there a way to display rich text in a textbox without the coded symbols?

Thanks for taking the time to read through it. I can supply anything needed to help answer it.

Jeremy

[Elroy]

Hi Lyzarus,

First and foremost, welcome to the forums.

From what you've said, it's somewhat difficult to understand exactly what you need. But I'll give a few ideas that, maybe, will help.

First, if it were me, I'd convert that VB5 project to VB6 (with the Service Pack 6 (SP6) installed in the VB6 IDE (development environment)). Any VB5 program should directly load, run, and compile in the VB6 IDE. Again, if you install the VB6 IDE, be sure to also install SP6. The SP6 is cumulative so no need to mess with prior SPs. (However, when going to .NET, things are very different, and I'd stay away from .NET).

Next, I'm unclear on exactly what you're trying to save. The RTB (rich text box) has a .Text property. So, in a sense, it can be used much like the regular TextBox if that's all you want. Now, however, if you load text into the RTB using its .Text property, you will lose any formatting you had. Also, if you had any pictures (or other non-text objects) you will lose those as well.

I just don't know how involved you were getting with the RTB.

Now, if you're wishing to save formatting, the RTB also has a .TextRTF property. I hope you're a bit familiar with the Rich Text Format (RTF). This is ASCII text with ASCII codes that indicate the formatting. This RTF can also contain pictures and other objects (like tables, etc). So, as an alternative, you could use this.TextRTF property of the RTB to load and save your text. Now, this .TextRTF can get quite large (with all the coding for formatting), so you will need to use a Memo field (and not a Text field) in your database to save it.

Also, if you needed to, you could load your old text (non RTF) into the .Text field of a RTB, and then use the .TextRTF property from that point forward.

Maybe that'll help you. Also, possibly consider posting some code.

Be sure to use the # button (above on the toolbar) to create a code-block for your posted code.

Good Luck,
Elroy

[Lyzarus]

Thanks for the reply!

Sorry I wasn't super clear, let me explain the system:

There is an access database with a single table and a number of fields. One of these fields contains a "correspondence" section that contains all of the information of the back and forths between people involved in the cases. Since each case is a single line each section of the correspondence is a single "cell" (Access doesn't really use cells, as you probably already know). Some of these cells are up to 10 pages in length in a word document.

This is an AWFUL design but it is the way it was implemented 20 years ago and I don't have a way to change it now. We are working on purchasing software to fix this, so I don't want to work too deeply on that just now. The program made with VB5 has a search box. Once a search is entered the found information from the access database populates the fields in the form. Any changes in the form are then saved to the database itself once confirmed.

The original code was written with just textboxes but a few years ago someone started using rich text format in the database which causes the textboxes to either be full of ASCII or to be one long jumbled mess of text without any breaks. 10 pages of that is impossible to deal with.

If there is no way to view rich text without ASCII and with the formatting in a textbox (which I don't think there is) then I just need to get the one rich text box that pulls that Rich text formatted data to confirm changes when changes have been made in the form.

I hope I cleared that up. The code is a mess, but I can post it if you want it.

Thanks again!

[dreammanor]

You could post the source code so that others could understand your problem more clearly. It doesn't seem too complicated.

[Lyzarus]

I'll have to break it up, it is about 8k characters too long for the box. Here is the first half:

Option Explicit
Public boxTrack As Long

Private Sub CheckMe()

 Dim Mess As String
 Dim Temp1 As String
 Dim J As Long
 Dim Verify As Integer
 Dim NoChange As Boolean
 '''''''''''''''''''''''''''''''
 If Val(txtData(boxTrack)) = 0 Then Exit Sub
 NoChange = True
 For J = 0 To txtData.Count - 1 ' Track
  If UCase(txtData(J)) <> UCase(CheckSave(J)) Then
   NoChange = False
   Temp1 = UCase(Trim(lblFieldName(J)))
   If Len(CheckSave(J)) < 100 Then
    Mess = Mess & Temp1 & " Field has changed from ' " & UCase(CheckSave(J)) & " ' To ' " & UCase(txtData(J)) & " '" & Chr(13)
   Else
    If Right(Temp1, 1) = ":" Then Temp1 = Left(Temp1, Len(Temp1) - 1)
    Mess = Mess & Temp1 & " Field has changed, (field too large for message box)." & Chr(13)
   End If
  End If
 Next J
 If NoChange = True Then Exit Sub
 Mess = Mess & Chr(13) & Chr(13) & "DO YOU WISH TO SAVE CHANGES"
 Verify = MsgBox(Mess, vbYesNo, txtData(0) & " (" & txtData(9) & ") RECORD CHANGED BUT NOT SAVED")
 If Verify = vbNo Then Exit Sub
 J = CheckSave(txtData.Count)
 lstView.ListItems(J).Selected = True
 Call cmdUpDate_Click
 
End Sub
Private Sub CheckHUMR(mSiteID As String)
 Dim db As Database
 Dim rst As Recordset
 Dim sqlQuery As String
 Dim CRtype As String
 ''''''''''''''''''''''''''''''''''''''''''
  lblIdHummer.Visible = False
  lblIdHummer = "No record of Hum. Remains w/ FMSF"
  txtData(3) = "NO"
  ReportForm.MousePointer = vbHourglass
  mSiteID = Mid(mSiteID, 2)  ' cut off the 8
  Set db = OpenDatabase("", dbDriverNoPrompt, False, FSFCONNECT)
  sqlQuery = "SELECT * FROM ID_HUMR WHERE SITEID LIKE '" & mSiteID & "*';"
  Set rst = db.OpenRecordset(sqlQuery, dbOpenSnapshot)
  If rst.RecordCount > 0 Then
   lblIdHummer = "FMSF record in ID_HUMR"
   txtData(3) = "YES"
  Else
   sqlQuery = "SELECT * FROM ID_JOIN WHERE SITEID LIKE '" & mSiteID & "*';"
   Set rst = db.OpenRecordset(sqlQuery, dbOpenSnapshot)
   If rst.RecordCount > 0 Then
    CRtype = Trim(rst.Fields("CR_TYPE"))
    sqlQuery = "SELECT * FROM tblFieldList WHERE Code LIKE '*" & CRtype & "*' "
    sqlQuery = sqlQuery & " AND ParentId = 3318;"
    Set rst = db.OpenRecordset(sqlQuery, dbOpenSnapshot)
    If rst.RecordCount > 0 Then
      lblIdHummer = "NO, " & rst.Fields("Instruction")
      If InStr(UCase(lblIdHummer), "CEMETERY") > 0 Then
       txtData(3) = "YES"
       lblIdHummer = "FMSF record as Cemetery"
      End If
    End If
   End If
  End If
  lblIdHummer.Visible = True
  ReportForm.MousePointer = vbNormal
End Sub
Private Sub FindHummers()  ' used by tools
 Dim db As Database
 Dim rst As Recordset
 Dim sqlQuery As String
 Dim J As Long
 Dim mSiteID As String
''''''''''''''''''''''''''
 lstView.ListItems.Clear
 Call Clear_txtBox
 Set db = OpenDatabase(mdb872)
 sqlQuery = "SELECT * FROM Reports WHERE (SiteID NOT LIKE '*00000') "
 sqlQuery = sqlQuery & "AND (RemainsEncountered LIKE '*YES*' OR RemainsRemoved LIKE '*YES*') "
 Set rst = db.OpenRecordset(sqlQuery, dbOpenSnapshot)
 Call lstView_Populate(rst)
 lblFound = rst.RecordCount & " records"
 If rst.RecordCount = 0 Then Exit Sub
 J = lstView.ListItems.Count
 Do While J > 0
  mSiteID = lstView.ListItems(J)
  Call CheckHUMR(mSiteID)
  If UCase(Left(lblIdHummer, 2)) = "NO" Then
   lstView.ListItems(J).ForeColor = vbRed
  Else
   lstView.ListItems.Remove J
  End If
  J = J - 1
 Loop
 If lstView.ListItems.Count > 0 Then
  Call lstView_Click
 Else
  Call Clear_txtBox
 End If
 lblFound = lstView.ListItems.Count & " records"
End Sub
Private Sub Find_OverDo()
 Dim db As Database
 Dim rst As Recordset
 Dim sqlQuery As String
 Dim mDate As String
''''''''''''''''''''''''''
 lstView.ListItems.Clear
 Call Clear_txtBox
 mDate = CStr(Date + 1)
 Set db = OpenDatabase(mdb872)
 sqlQuery = "SELECT * FROM Reports WHERE NextActionDate < #" & mDate & "# "
 sqlQuery = sqlQuery & "AND NOT left(ucase(STATUS),6) LIKE 'CLOSED'"
 Set rst = db.OpenRecordset(sqlQuery, dbOpenSnapshot)
 Call lstView_Populate(rst)
 lblFound = rst.RecordCount & " Expired Action Date(s)"
 Call lstView_Click
End Sub
Private Sub FindOpen()
 Dim db As Database
 Dim rst As Recordset
 Dim sqlQuery As String
''''''''''''''''''''''''''
 lstView.ListItems.Clear
 Call Clear_txtBox
 Set db = OpenDatabase(mdb872)
 sqlQuery = "SELECT * FROM Reports WHERE left(ucase(STATUS),6) NOT LIKE 'CLOSED'"
 Set rst = db.OpenRecordset(sqlQuery, dbOpenSnapshot)
 Call lstView_Populate(rst)
 lblFound = rst.RecordCount & " Open Case File(s)"
 Call lstView_Click
End Sub
Private Sub FindFedsInvolved()
 Dim db As Database
 Dim rst As Recordset
 Dim sqlQuery As String
''''''''''''''''''''''''''
 lstView.ListItems.Clear
 Call Clear_txtBox
 Set db = OpenDatabase(mdb872)
 sqlQuery = "SELECT * FROM Reports WHERE left(ucase(FedsInvolved),2) NOT LIKE 'NO'"
 Set rst = db.OpenRecordset(sqlQuery, dbOpenSnapshot)
 Call lstView_Populate(rst)
 lblFound = rst.RecordCount & " Case(s) flagged having Federal Involvement"
 Call lstView_Click
End Sub

Private Sub chkADDtoLIST_Click()
 txtFind.SetFocus
 If cmdEmptyList.Visible = True Then
  cmdEmptyList.Visible = False
 Else
  cmdEmptyList.Visible = True
 End If
End Sub

Private Sub chkOpenOnly_Click()
 txtFind.SetFocus
End Sub

Private Sub cmdAF_Click()
 Call mnuFind_AdvancedFind_Click
End Sub

Private Sub cmdCancel_Click()
 frameFirstReport.Visible = False
End Sub

Private Sub cmdDelete_Click()
 Dim rst As Recordset
 Dim db As Database
 Dim sqlQuery As String
 Dim Yndex As Long
 Dim J As Long
 Dim Mess As String
 ''''''''''''''''''
 txtFind.SetFocus
 Yndex = Val(txtData(boxTrack)) 'track
 If Yndex = 0 Then Exit Sub
 sqlQuery = "SELECT * FROM Reports WHERE Track = " & CStr(Yndex)
 Set db = OpenDatabase(mdb872)
 Set rst = db.OpenRecordset(sqlQuery, dbOpenDynaset)
 If rst.RecordCount = 0 Then
  MsgBox "CAN NOT FIND INDEX VALUE (Track), NOTIFY SYSTEMS MANAGER", vbCritical, "CAN NOT DELETE THIS RECORD"
  Exit Sub
 End If
 Mess = "OK TO DELETE THIS RECORD:" & Chr(13) & Chr(13)
 For J = 0 To rst.Fields.Count - 1
  Mess = Mess & Chr(13) & rst.Fields(J).Name & ": " & rst.Fields(J)
 Next J
 J = MsgBox(Mess, vbOKCancel, "DELETE RECORD")
 If J = vbCancel Then Exit Sub
 rst.Delete
 Yndex = lstView.SelectedItem.Index
 If Yndex - 1 > 0 Then Yndex = Yndex - 1
 Call Clear_txtBox
 lstView.ListItems.Remove lstView.SelectedItem.Index
 If lstView.ListItems.Count > 0 Then
  lstView.ListItems(Yndex).Selected = True
 End If
 Call lstView_Click
 
End Sub

Private Sub cmdEmptyList_Click()
 lstView.ListItems.Clear
 Call Clear_txtBox
 lblFound = ""
 txtFind.SetFocus
End Sub

Private Sub cmdFind_Click()
 Dim rst As Recordset
 Dim db As Database
 Dim sqlQuery As String
 Dim FormatThis As String
 Dim CancelEdit As Boolean
 Dim J As Long
 Dim Verify As Integer
 Dim Mess As String
 '''''''''''''''''''''''''
 If txtData(0).BackColor = vbBlack Then
  For J = 0 To txtData.Count - 1
   If Len(txtData(J)) > 0 Then
    Mess = "The NEW RECORD you started is not saved (new record is not Updated))." & Chr(13)
    Mess = Mess & "Do you wish to SAVE this record?" & Chr(13) & Chr(13)
    Verify = MsgBox(Mess, vbYesNoCancel, "UPDATE button also saves a new entry or edit.")
    If Verify = vbCancel Then txtData(0).SetFocus: Exit Sub
    If Verify = vbYes Then Call cmdUpDate_Click
    If Verify = vbNo Then WriteNew = False
    Exit For
   End If
  Next J
 End If
 
 
 txtFind.SetFocus
 If Val(txtData(boxTrack)) > 0 Then
  Call CheckMe
 End If
 
 For J = 0 To txtData.Count - 1
  txtData(J).BackColor = txtNormalColor
  txtData(J).ForeColor = vbBlack
 Next J
 Call Clear_txtBox
 If mnuFind_All.Checked = False And Len(Trim(txtFind)) = 0 Then Exit Sub
 If (mnuFind_All.Checked = False And chkADDtoLIST.Value = 0) Or mnuFind_All.Checked = True Then
  lstView.ListItems.Clear
 End If
 Set db = OpenDatabase(mdb872)
 If mnuFind_AnyField.Checked = True Then
  sqlQuery = "[SiteID] LIKE '*" & txtFind & "*' "
  sqlQuery = sqlQuery & "OR [Status] LIKE '*" & txtFind & "*' "
  sqlQuery = sqlQuery & "OR [872File] LIKE '*" & txtFind & "*' "
  sqlQuery = sqlQuery & "OR [AdHoc] LIKE '*" & txtFind & "*' "
  sqlQuery = sqlQuery & "OR [UpDateFMSF] LIKE '*" & txtFind & "*' "
  sqlQuery = sqlQuery & "OR [RemainsEncountered] LIKE '*" & txtFind & "*' "
  sqlQuery = sqlQuery & "OR [RemainsRemoved] LIKE '*" & txtFind & "*' "
  sqlQuery = sqlQuery & "OR [LocationOfRemains] LIKE '*" & txtFind & "*' "
  sqlQuery = sqlQuery & "OR [Comment] LIKE '*" & txtFind & "*' "
  sqlQuery = sqlQuery & "OR [Summary] LIKE '*" & txtFind & "*' "
  sqlQuery = sqlQuery & "OR [NoticeDetails] LIKE '*" & txtFind & "*' "
  sqlQuery = sqlQuery & "OR [NativeAmerican] LIKE '*" & txtFind & "*' "
  sqlQuery = sqlQuery & "OR [NoticeNeeded] LIKE '*" & txtFind & "*' "
  sqlQuery = sqlQuery & "OR [CaseNum] LIKE '*" & txtFind & "*' "
  If IsDate(txtFind) = True Then
   sqlQuery = sqlQuery & "OR [FirstReportDate] LIKE '#" & txtFind & "#' "
  End If
 End If
 If mnuFind_All.Checked = True Then
   sqlQuery = "[Track] > -1 "
 End If
 If mnuFind_SiteID.Checked = True Then
  CancelEdit = False
  FormatThis = txtFind
  Call Formats.Format_SiteId(FormatThis, CancelEdit)
  If CancelEdit = False Then txtFind = FormatThis
  sqlQuery = sqlQuery & " SiteID LIKE '" & txtFind & "*' "
 End If
 If mnuFind_CaseNum.Checked = True Then
  sqlQuery = sqlQuery & " CaseNum LIKE '" & txtFind & "*' "
 End If
 If mnuFind_Contact.Checked = True Then
  sqlQuery = sqlQuery & " Contact LIKE '*" & txtFind & "*' "
 End If
 If chkOpenOnly.Value = 1 Then
  sqlQuery = "SELECT * FROM Reports WHERE (" & sqlQuery & " ) AND NOT Status Like 'CLOSED*' "
 Else
  sqlQuery = "SELECT * FROM Reports WHERE " & sqlQuery
 End If
 sqlQuery = sqlQuery & "ORDER BY [FirstReportDate];"
 Set rst = db.OpenRecordset(sqlQuery, dbOpenSnapshot)
 If rst.RecordCount = 1 Then
  lblFound = rst.RecordCount & " record matching " & txtFind
 Else
  lblFound = rst.RecordCount & " records matching " & txtFind
 End If
 If rst.EOF = True Then Exit Sub
 Call lstView_Populate(rst)
 txtFind = ""
End Sub

Private Sub lstView_FormatColumns()
 lstView.ColumnHeaders.Clear
 lstView.View = lvwReport ' Set View property to Report.
 lstView.ColumnHeaders.Add 1, , "SiteID"
 lstView.ColumnHeaders.Add 2, , "Status" ''' no txtbox
 lstView.ColumnHeaders.Add 3, , "872File"
 lstView.ColumnHeaders.Add 4, , "UpDateFMSF" ''' no txtbox
 lstView.ColumnHeaders.Add 5, , "RemainsEncountered"
 lstView.ColumnHeaders.Add 6, , "RemainsRemoved"
 lstView.ColumnHeaders.Add 7, , "AdHoc"
 lstView.ColumnHeaders.Add 8, , "LocationOfRemains"
 lstView.ColumnHeaders.Add 9, , "Comment"
 lstView.ColumnHeaders.Add 10, , "FirstReportDate"
 lstView.ColumnHeaders.Add 11, , "Track"
 lstView.ColumnHeaders.Add 12, , "NextActionDate"
 lstView.ColumnHeaders.Add 13, , "Contact"
 lstView.ColumnHeaders.Add 14, , "Federal Involvement"
 lstView.ColumnHeaders.Add 15, , "NoticeNeeded"
 lstView.ColumnHeaders.Add 16, , "NoticeDetails"
 lstView.ColumnHeaders.Add 17, , "Summary"
 lstView.ColumnHeaders.Add 18, , "NativeAmerican"
 lstView.ColumnHeaders.Add 19, , "CaseNum"
 
 Call LstView_RestoreDimensions
 boxTrack = 10

End Sub
Private Sub LstView_RestoreDimensions()
 Dim X As Integer
 lstView.ColumnHeaders(1).Width = 890       'column widths
 lstView.ColumnHeaders(2).Width = 1560
 lstView.ColumnHeaders(3).Width = 2085
 lstView.ColumnHeaders(4).Width = 930
 lstView.ColumnHeaders(5).Width = 1695
 lstView.ColumnHeaders(6).Width = 2040
 lstView.ColumnHeaders(7).Width = 1215
 lstView.ColumnHeaders(8).Width = 930
 lstView.ColumnHeaders(9).Width = 1000
 lstView.ColumnHeaders(10).Width = 1000
 lstView.ColumnHeaders(11).Width = 100
 lstView.ColumnHeaders(12).Width = 1000
 lstView.ColumnHeaders(13).Width = 1000
 lstView.ColumnHeaders(14).Width = 1000
 lstView.ColumnHeaders(15).Width = 1000
 lstView.ColumnHeaders(16).Width = 1000
 lstView.ColumnHeaders(17).Width = 1000
 lstView.ColumnHeaders(18).Width = 1000
 lstView.ColumnHeaders(19).Width = 1000

 
 lstView.ColumnHeaders(1).Position = 1       'column order/position
 lstView.ColumnHeaders(2).Position = 2
 lstView.ColumnHeaders(3).Position = 3
 lstView.ColumnHeaders(4).Position = 4
 lstView.ColumnHeaders(5).Position = 5
 lstView.ColumnHeaders(6).Position = 6
 lstView.ColumnHeaders(7).Position = 7
 lstView.ColumnHeaders(8).Position = 8
 lstView.ColumnHeaders(9).Position = 9
 lstView.ColumnHeaders(10).Position = 10
 lstView.ColumnHeaders(11).Position = 13
 lstView.ColumnHeaders(12).Position = 11
 lstView.ColumnHeaders(13).Position = 12
 lstView.ColumnHeaders(14).Position = 14
 lstView.ColumnHeaders(15).Position = 15
 lstView.ColumnHeaders(16).Position = 16
 lstView.ColumnHeaders(17).Position = 17
 lstView.ColumnHeaders(18).Position = 18
 lstView.ColumnHeaders(19).Position = 19

 
 lstView.SortOrder = lvwAscending
 lstView.SortKey = 1
End Sub

Public Sub lstView_Populate(rst As Recordset)
 Dim ItmX As ListItem
 Dim Temp1 As String
 Dim J As Long
 Dim AddMe As Boolean
 '***************************************************
 If rst.EOF = True Then Exit Sub
 With rst
  .MoveFirst
  Do While .EOF = False
    AddMe = True
    If chkADDtoLIST.Value = 1 Then
     For J = 1 To lstView.ListItems.Count
      If rst.Fields("Track") = lstView.ListItems(J).SubItems(10) Then AddMe = False
     Next J
    End If
    
    If AddMe = True Then
     If IsNull(rst.Fields("SiteID")) = True Then
      Temp1 = "No Data"
     Else
      Temp1 = .Fields("SiteId")
     End If
     Set ItmX = lstView.ListItems.Add(, , Temp1)
      If Not IsNull(.Fields("Status")) Then ItmX.SubItems(1) = CStr(.Fields("Status"))
      If Not IsNull(.Fields("872File")) Then ItmX.SubItems(2) = CStr(.Fields("872File"))
      If Not IsNull(.Fields("UpDateFMSF")) Then ItmX.SubItems(3) = CStr(.Fields("UpDateFMSF"))
      If Not IsNull(.Fields("RemainsEncountered")) Then ItmX.SubItems(4) = CStr(.Fields("RemainsEncountered"))
      If Not IsNull(.Fields("RemainsRemoved")) Then ItmX.SubItems(5) = CStr(.Fields("RemainsRemoved"))
      If Not IsNull(.Fields("AdHoc")) Then ItmX.SubItems(6) = CStr(.Fields("AdHoc"))
      If Not IsNull(.Fields("LocationOfRemains")) Then ItmX.SubItems(7) = CStr(.Fields("LocationOfRemains"))
      If Not IsNull(.Fields("Comment")) Then ItmX.SubItems(8) = CStr(.Fields("Comment"))
      If Not IsNull(.Fields("FirstReportDate")) Then ItmX.SubItems(9) = CStr(.Fields("FirstReportDate"))
      If Not IsNull(.Fields("Track")) Then ItmX.SubItems(10) = CStr(.Fields("Track"))
      If Not IsNull(.Fields("NextActionDate")) Then ItmX.SubItems(11) = CStr(.Fields("NextActionDate"))
      If Not IsNull(.Fields("Contact")) Then ItmX.SubItems(12) = CStr(.Fields("Contact"))
      If Not IsNull(.Fields("FedsInvolved")) Then ItmX.SubItems(13) = CStr(.Fields("FedsInvolved"))
      If Not IsNull(.Fields("NativeAmerican")) Then ItmX.SubItems(14) = CStr(.Fields("NativeAmerican"))
      If Not IsNull(.Fields("NoticeNeeded")) Then ItmX.SubItems(15) = CStr(.Fields("NoticeNeeded"))
      If Not IsNull(.Fields("NoticeDetails")) Then ItmX.SubItems(16) = CStr(.Fields("NoticeDetails"))
      If Not IsNull(.Fields("Summary")) Then ItmX.SubItems(17) = CStr(.Fields("Summary"))
      If Not IsNull(.Fields("CaseNum")) Then ItmX.SubItems(18) = CStr(.Fields("CaseNum"))

    End If  'if addme true
    rst.MoveNext
  Loop
 End With
 lstView.SortKey = 0
 lstView.ListItems(1).Selected = True
 Call lstView_Click
End Sub

[Lyzarus]

And here is the second half:

Private Sub cmdFindFirstDate_Click()
 Dim db As Database
 Dim rst As Recordset
 Dim sqlQuery As String
 Dim mDate1 As String
 Dim mDate2 As String
''''''''''''''''''''''''''''''''''''''''''''''' DATA VALIDATIONS
 If IsDate(txtStartDate) = False Then
  MsgBox "START DATE IS NOT A VALID DATE", vbInformation, "PLEASE ENTER A DATE"
  txtStartDate.SetFocus
  Exit Sub
 End If
 If IsDate(txtEndDate) = False Then
  MsgBox "END DATE IS NOT A VALID DATE", vbInformation, "PLEASE ENTER A DATE"
  txtEndDate.SetFocus
  Exit Sub
 End If
 mDate1 = CDate(txtStartDate)
 mDate2 = CDate(txtEndDate)
 If CDate(mDate1) > CDate(mDate2) Then
  MsgBox "START DATE MUST BE EARLIER THAN END DATE", vbInformation, "PLEASE ENTER A DATE"
  txtStartDate.SetFocus
  Exit Sub
 End If
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 Set db = OpenDatabase(mdb872)
 sqlQuery = "SELECT * FROM Reports WHERE FirstReportDate >= #" & mDate1 & "# "
 sqlQuery = sqlQuery & "AND FirstReportDate <= #" & mDate2 & "#"
 
 If chkOpenOnly.Value = 1 Then
  sqlQuery = sqlQuery & " AND NOT Status Like 'CLOSED*'"
 End If


Set rst = db.OpenRecordset(sqlQuery, dbOpenSnapshot)
 If rst.RecordCount = 0 Then
  MsgBox "NO NEW RECORDS IN RANGE " & mDate1 & " TO " & mDate2, vbInformation, "FIRST REPORT DATE"
  cmdCancel.SetFocus
  Exit Sub
 End If
 lstView.ListItems.Clear
 Call Clear_txtBox
 Call lstView_Populate(rst)
 lblFound = rst.RecordCount & " First Report Date(s)"
 Call lstView_Click
End Sub

Private Sub cmdMemory_Click()
 Dim J As Long
''''''''''''''''''''''''''
 If Len(txtData(0)) = 0 Then txtFind.SetFocus: Exit Sub
 For J = 0 To txtData.Count - 1
  RememberMe(J) = txtData(J)
 Next J
 txtFind.SetFocus
End Sub

Private Sub cmdNEW_Click()
 Dim J As Long
 Dim Mess As String
 Dim Verify As Integer
 Dim db As Database
 Dim sqlQuery As String
 Dim rst As Recordset
 Dim NewCaseNum As String
 Dim NewCaseNumber As String
 
'''''''''''''''''''''''''''''''
 If txtData(0).BackColor = vbBlack Then
  For J = 0 To txtData.Count - 1
   If Len(txtData(J)) > 0 Then
    Mess = "The NEW RECORD you started is not saved (new record is not Updated))." & Chr(13)
    Mess = Mess & "Do you wish to SAVE this record?" & Chr(13) & Chr(13)
    Verify = MsgBox(Mess, vbYesNoCancel, "UPDATE button also saves a new entry or edit.")
    If Verify = vbCancel Then txtData(0).SetFocus: Exit Sub
    If Verify = vbYes Then Call cmdUpDate_Click: Exit Sub
    If Verify = vbNo Then WriteNew = False 'kinda useless in this procedure...
    Exit For
   End If
  Next J
 End If
 
 
 WriteNew = True
 
  For J = 0 To txtData.Count - 1
  txtData(J).BackColor = vbBlack
  txtData(J).ForeColor = vbWhite
  txtData(J) = ""
 Next J
 
 
 Set db = OpenDatabase(mdb872)
 Set rst = db.OpenRecordset("NewCaseNum")
 txtData(18) = CStr(rst.Fields("NewCaseNumber"))

 
 txtData(9) = Date
 lblIdHummer = ""
 txtData(0).SetFocus
End Sub

Private Sub cmdProgrammersUseOnly_Click()
 Dim rst As Recordset
 Dim db As Database
 Dim sqlQuery As String
 Dim Temp1 As String
 Dim J As Long
 ''''''''''''''''''
 Temp1 = "NO DATA, RECORD EXISTED BEFORE FIELD WAS CREATED ON 5/29/2008"
 sqlQuery = "SELECT * FROM Reports"
 Set db = OpenDatabase(mdb872)
 Set rst = db.OpenRecordset(sqlQuery, dbOpenDynaset)
 rst.MoveLast: rst.MoveFirst
 Do While rst.EOF = False
  rst.Edit
  rst.Fields("FedsInvolved") = Temp1
  rst.Update
  rst.MoveNext
 Loop
 MsgBox "done"
End Sub

Private Sub cmdUpDate_Click()
 Dim rst As Recordset
 Dim db As Database
 Dim sqlQuery As String
 Dim Temp1 As String
 Dim Yndex As Long
 Dim J As Long
 Dim CancelEdit As Boolean
 ''''''''''''''''''
 If Len(txtData(0)) = 0 Then txtData(0).SetFocus: Exit Sub
 Temp1 = txtData(0)
 Call Formats.Format_SiteId(Temp1, False)
 Call CheckHUMR(Temp1)
 
 If WriteNew = True Then ' its a WRITE NEW RECORD ACTION
  For J = 0 To txtData.Count - 1
   txtData(J).ForeColor = vbBlack
   txtData(J).BackColor = txtNormalColor
   RememberMe(J) = txtData(J)  ' string array activated by  ctrl-'
  Next J
  Call AddNew(db, rst)
  
  txtFind = txtData(0)
  Call Clear_txtBox
  If optFindSite.Value = False Then Call optFindSite_Click
  Call cmdFind_Click
  If lstView.ListItems.Count > 1 Then
   For J = 1 To lstView.ListItems.Count
    If lstView.ListItems(J).SubItems(10) = rst.Fields("Track") Then
     lstView.ListItems(J).Selected = True
     Call lstView_Click
     Exit For
    End If
   Next J
  End If
  
  WriteNew = False
  Exit Sub
 End If
 ''' its AN EDIT RECORD ACTION
 txtFind.SetFocus
 Yndex = Val(txtData(boxTrack)) 'track
 If Yndex = 0 Then Exit Sub
 Call CheckSaveWrite

 sqlQuery = "SELECT * FROM Reports WHERE Track = " & CStr(Yndex)
 Set db = OpenDatabase(mdb872)
 Set rst = db.OpenRecordset(sqlQuery, dbOpenDynaset)
 If rst.RecordCount = 0 Then
  MsgBox "CAN NOT FIND INDEX VALUE (Track), NOTIFY SYSTEMS MANAGER", vbCritical, "CAN NOT EDIT THIS RECORD"
  Exit Sub
 End If
  
  With rst
    Temp1 = txtData(0)
  Call Formats.Format_SiteId(Temp1, CancelEdit)
  If CancelEdit = False Then txtData(0) = Temp1
  If IsDate(txtData(9)) Then
   Temp1 = txtData(9)
   Temp1 = Format(Temp1, "mm/dd/yyyy")
   txtData(9) = Temp1
  End If
  txtData(2) = UCase(txtData(2)) '872file
  txtData(3) = UCase(txtData(3)) 'updateFMSF
  txtData(4) = UCase(txtData(4)) 'RemainsEncountered
  txtData(5) = UCase(txtData(5)) 'RemainsRemoved
  .Edit
  !SiteID = txtData(0)
  !Status = txtData(1)
   rst.Fields("872File") = txtData(2)
  !UpDateFMSF = txtData(3)
  !RemainsEncountered = txtData(4)
  !RemainsRemoved = txtData(5)
  !AdHoc = txtData(6)
  !NoticeNeeded = txtData(15)
  !NoticeDetails = txtData(16)
  !Summary = txtData(17)
  !NativeAmerican = txtData(14)
  !LocationOfRemains = txtData(7)
  !Comment = RichTextBox(0)
  If IsDate(txtData(9)) = True Then
   !FirstReportDate = txtData(9)
  End If
  'txtdata(10) is Track (key index autonumber)
  'RichTextBox(1) Is Track as well (Auto number as TxtData(10))
  If IsDate(txtData(11)) = True Then
   !NextActionDate = txtData(11)
  End If
  !Contact = txtData(12)
  !FedsInvolved = txtData(13)
  .Update
 End With
 lstView.SelectedItem.Text = txtData(0)
 lstView.SelectedItem.SubItems(1) = txtData(1)
 lstView.SelectedItem.SubItems(2) = txtData(2)
 lstView.SelectedItem.SubItems(3) = txtData(3)
 lstView.SelectedItem.SubItems(4) = txtData(4)
 lstView.SelectedItem.SubItems(5) = txtData(5)
 lstView.SelectedItem.SubItems(6) = txtData(6)
 lstView.SelectedItem.SubItems(7) = txtData(7)
 lstView.SelectedItem.SubItems(8) = RichTextBox(0)
 lstView.SelectedItem.SubItems(9) = txtData(9)
 lstView.SelectedItem.SubItems(11) = txtData(11)
 lstView.SelectedItem.SubItems(12) = txtData(12)
 lstView.SelectedItem.SubItems(13) = txtData(13)
 lstView.SelectedItem.SubItems(14) = txtData(14)
 lstView.SelectedItem.SubItems(15) = txtData(15)
 lstView.SelectedItem.SubItems(16) = txtData(16)
 lstView.SelectedItem.SubItems(17) = txtData(17)
 lstView.SelectedItem.SubItems(18) = txtData(18)

 Call lstView_Click


End Sub

Private Sub Form_Load()
 Call lstView_FormatColumns
 Call Clear_txtBox
 'Call Formats.Format_txtData_Size
 ReDim CheckSave(txtData.Count)   ' extra element for listitem index
 lblFound.BackColor = ReportForm.BackColor
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
 Call CheckMe
 End
End Sub

Private Sub Form_Resize()
 Dim A As Long
 '''''''''''''''''''
 A = (ReportForm.Height - lstView.Top) - 800
 If A < 700 Then A = 700
 lstView.Height = A
 A = (ReportForm.Width - lstView.Left) - 195
 If A < 195 Then A = 195
 lstView.Width = A
End Sub

Private Sub lstView_Click()
 Dim Temp1 As String
 Dim Temp2 As String
 Dim J As Long
 Dim Verify As Integer
 Dim Mess As String
 ''''''''''''''''''''''''''''''''''
 On Error Resume Next
 txtFind.SetFocus
 On Error GoTo 0
 If txtData(0).BackColor = vbBlack Then
  For J = 0 To txtData.Count - 1
   If Len(txtData(J)) > 0 Then
    Mess = "The NEW RECORD you started is not saved (new record is not Updated))." & Chr(13)
    Mess = Mess & "Do you wish to SAVE this record?" & Chr(13) & Chr(13)
    Verify = MsgBox(Mess, vbYesNoCancel, "UPDATE button also saves a new entry or edit.")
    If Verify = vbCancel Then txtData(0).SetFocus: Exit Sub
    If Verify = vbYes Then Call cmdUpDate_Click
    If Verify = vbNo Then WriteNew = False
    Exit For
   End If
  Next J
 End If
 For J = 0 To txtData.Count - 1
  txtData(J).BackColor = txtNormalColor
  txtData(J).ForeColor = vbBlack
 Next J
 
 If lstView.ListItems.Count = 0 Then GoTo ByeBye:
 If Val(txtData(boxTrack)) > 0 And txtData(boxTrack) <> lstView.SelectedItem.SubItems(boxTrack) Then
  Call CheckMe
 End If
 If lstView.ListItems.Count = 0 Then txtFind.SetFocus: Exit Sub
  txtData(0) = lstView.SelectedItem               ' siteid
  txtData(1) = lstView.SelectedItem.SubItems(1)   'Status
  txtData(2) = lstView.SelectedItem.SubItems(2)   '872File
  txtData(3) = lstView.SelectedItem.SubItems(3)   'updateFMSF
  txtData(4) = lstView.SelectedItem.SubItems(4)   'RemainsEncountered
  txtData(5) = lstView.SelectedItem.SubItems(5)   'RemainsRemoved
  txtData(6) = lstView.SelectedItem.SubItems(6)   'AdHoc
  txtData(7) = lstView.SelectedItem.SubItems(7)   'LocationOfRemains
  RichTextBox(0) = lstView.SelectedItem.SubItems(8)   'comment
  txtData(8) = lstView.SelectedItem.SubItems(8)    'comment
  txtData(9) = lstView.SelectedItem.SubItems(9)   'FirstReportDate
  txtData(10) = lstView.SelectedItem.SubItems(10)  'Track
  RichTextBox(1) = lstView.SelectedItem.SubItems(10)  'Track
  txtData(11) = lstView.SelectedItem.SubItems(11)  'NextActionDate
  txtData(12) = lstView.SelectedItem.SubItems(12)  'contact
  txtData(13) = lstView.SelectedItem.SubItems(13)  'FedsInvolved
  txtData(14) = lstView.SelectedItem.SubItems(14)
  txtData(15) = lstView.SelectedItem.SubItems(15)
  txtData(16) = lstView.SelectedItem.SubItems(16)
  txtData(17) = lstView.SelectedItem.SubItems(17)
  txtData(18) = lstView.SelectedItem.SubItems(18)
  Call CheckSaveWrite
  Call CheckHUMR(txtData(0))
  txtData(3).BackColor = vbWhite
  If UCase(Left(lblIdHummer, 2)) = "NO" And Right(Trim(txtData(0)), 5) <> "00000" Then
   If UCase(Left(txtData(4), 1)) = "Y" Or UCase(Left(txtData(5), 1)) = "Y" Then
    txtData(3).BackColor = vbRed
   End If
  End If
 Exit Sub
ByeBye:
 For J = 0 To txtData.Count - 1
  txtData(J).BackColor = txtNormalColor
  txtData(J).ForeColor = vbBlack
 Next J
End Sub
Private Sub lstView_ColumnClick(ByVal ColumnHeader As ColumnHeader)
 Call Formats.ListView_ColumnSort(lstView, ColumnHeader)
End Sub
Public Sub Clear_txtBox()
 Dim J As Long
 ''''''''''''
 For J = 0 To txtData.Count - 1
  txtData(J) = ""
 Next J
 RichTextBox(0).Text = ""
End Sub

Private Sub lstView_KeyUp(KeyCode As Integer, Shift As Integer)
 If lstView.ListItems.Count = 0 Then txtFind.SetFocus: Exit Sub
 If KeyCode = vbKeyUp Or KeyCode = vbKeyDown Then
   Call lstView_Click
 End If
End Sub

Private Sub mnuAccessions_Click()
 Dim MyAppID
 ''''''''''''''''''''''''''''''''''''''''''''''
 MyAppID = Shell(OtherCollectionsEXE & "\AccessionsStaffVersion.EXE", 1)
 AppActivate MyAppID
End Sub

Private Sub mnuCrat_Click()
 Dim MyAppID
 ''''''''''''''''''''''''''''''''''''''''''''''
 MyAppID = Shell("P:\CRAT\CRATLOG\CRAT0.exe", 1)
 AppActivate MyAppID
End Sub

Private Sub mnuExit_Click()
 End
End Sub

Private Sub mnuFind_AdvancedFind_Click()
 AdvancedFindForm.Show
 If AdvancedFindForm.WindowState = vbMinimized Then AdvancedFindForm.WindowState = vbNormal
End Sub

Private Sub mnuFind_All_Click()
 Call mnuFind_Uncheck
 mnuFind_All.Checked = True
 txtFind.Locked = True
 cmdFind.Caption = "FIND ALL"
 Call cmdFind_Click
 optFindAny.Value = 0
 optFindSite.Value = 0

End Sub

Private Sub mnuFind_AnyField_Click()
 Call mnuFind_Uncheck
 mnuFind_AnyField.Checked = True
 optFindAny.Value = True
 cmdFind.Caption = "FIND ANY"
End Sub
Private Sub mnuFind_Uncheck()
 If mnuFind_All.Checked = True Then Call cmdEmptyList_Click
 mnuFind_All.Checked = False
 mnuFind_AnyField.Checked = False
 mnuFind_SiteID.Checked = False
 mnuFind_Contact.Checked = False
 mnuFind_CaseNum.Checked = False
 txtFind.Locked = False
 txtFind.SetFocus
End Sub

Private Sub mnuFind_Contact_Click()
 Call mnuFind_Uncheck
 mnuFind_Contact.Checked = True
 cmdFind.Caption = "FIND Contact"
 optFindAny.Value = 0
 optFindSite.Value = 0
 mnuFind_CaseNum.Checked = False
End Sub

Private Sub mnuFind_FirstReport_Click()
 frameFirstReport.Visible = True
 txtStartDate.SetFocus
End Sub

Private Sub mnuFind_SiteID_Click()
 Call mnuFind_Uncheck
 mnuFind_SiteID.Checked = True
 optFindSite.Value = True
 mnuFind_CaseNum.Checked = False
 cmdFind.Caption = "FIND SITEID"
End Sub

Private Sub mnuFind_CaseNum_Click()
 Call mnuFind_Uncheck
 mnuFind_CaseNum.Checked = True
 optFindCaseNum.Value = True
 mnuFind_All.Checked = False
 mnuFind_AnyField.Checked = False
 mnuFind_SiteID.Checked = False
 mnuFind_Contact.Checked = False
 txtFind.Locked = False
 cmdFind.Caption = "FIND Case #"
End Sub



Private Sub mnuPrint_Click()
 If Val(txtData(boxTrack)) = 0 Then Exit Sub ' no selected record field track is empty
 Dim J As Long
 Dim I As Long
 Dim PrintMe As String
 Dim StartSeg As Long
 Dim EndSeg As Long
 Dim PrintSegs()
 Dim PrintLen As Long
 Dim LastSeg
 ''''''''''''''''''
 Printer.Print "Print Date: " & Date
 Printer.Print ""
 
 For J = 0 To txtData.Count - 1
    If J <> 8 Then  'notes = 8
     If J = 0 Or J = 1 Then  ' 0 siteid, 1 Status
       Printer.Font.Bold = True
     Else
      Printer.Font.Bold = False
     End If
     Printer.Print lblFieldName(J) & ": " & Trim(txtData(J))
  Else   ' notes = J = 8
    Printer.Font.Bold = True
    Printer.Print lblFieldName(J)
    Printer.Font.Bold = False
    PrintMe = Trim(txtData(J))
    PrintLen = 75
    LastSeg = (Len(PrintMe) / PrintLen) + 0.5
    If LastSeg < 1 Then LastSeg = 1
    LastSeg = CLng(LastSeg)
    ReDim PrintSegs(1 To LastSeg)
    If LastSeg > 1 Then
     I = 1
     J = 1
     StartSeg = 1
     Do While J <= Len(PrintMe)
      If Mid(PrintMe, J, 1) = Chr(32) Then
       If J > I * PrintLen Then
        If J - StartSeg > 0 Then
         EndSeg = J - StartSeg
        Else
         EndSeg = 1
        End If
        PrintSegs(I) = Mid(PrintMe, StartSeg, EndSeg)
        If I > 1 Then PrintSegs(I) = "   " & PrintSegs(I)
        StartSeg = J + 1
        I = I + 1
       End If
      End If
      J = J + 1
     Loop
     If I = LastSeg Then
        PrintSegs(I) = Mid(PrintMe, StartSeg, EndSeg)
        If I > 1 Then PrintSegs(I) = "   " & PrintSegs(I)
     End If
    Else
     PrintSegs(1) = PrintMe
    End If
    For I = 1 To LastSeg
      Printer.Print PrintSegs(I)
      'Debug.Print PrintMe
    Next I
  End If   ' if j= 8 = notes
  Printer.Print ""
 Next J
 Printer.EndDoc
End Sub

Private Sub mnuTools_FedsInvolved_Click()
 Call FindFedsInvolved
End Sub


Private Sub mnuTools_NoID_Humr_Click()
 Call FindHummers
End Sub

Private Sub mnuTools_OpenCases_Click()
 Call FindOpen
End Sub

Private Sub mnuTools_OverDue_Click()
 Call Find_OverDo  ' TERRIBLE PUN
End Sub

Private Sub optFindAny_Click()
 Call mnuFind_AnyField_Click
End Sub

Private Sub optFindSite_Click()
 Call mnuFind_SiteID_Click
End Sub
Private Sub optFindCaseNum_Click()
 Call mnuFind_CaseNum_Click
End Sub
Private Sub txtData_Change(Index As Integer)
 If Index = boxTrack And Val(txtData(boxTrack)) > 0 Then Call CheckSaveWrite
End Sub
Private Sub CheckSaveWrite()
 Dim J As Long
 '''''''''''''''''''''''''
   For J = 0 To txtData.Count - 1
    CheckSave(J) = txtData(J)
   Next J
   CheckSave(J) = lstView.SelectedItem.Index
End Sub

Private Sub txtData_DblClick(Index As Integer)
 If Index <> 0 Then Exit Sub   ' if not siteid box
 If Len(txtData(0)) = 0 Then Exit Sub
 Dim rst As Recordset
 Dim db As Database
 Dim sqlQuery As String
 Dim Mess As String
 Dim J
 ''''''''''''''''''''''''''
 Set db = OpenDatabase(mdbACCESSIONS)
 sqlQuery = "SELECT * FROM Accessions WHERE SiteID LIKE '*" & txtData(0) & "*'"
 Set rst = db.OpenRecordset(sqlQuery)
 If rst.RecordCount = 0 Then
  Mess = "No Accessions"
  MsgBox Mess, vbInformation, "BAR ACCESSIONS"
 Else
  Do While rst.EOF = False
   Mess = Mess & rst.Fields("Accno") & Chr(13)
   rst.MoveNext
  Loop
  Mess = Mess & Chr(13) & Chr(13) & "COPY TO LOCATION?"
  J = MsgBox(Mess, vbYesNo, "BAR ACCESSIONS")
  If J = vbYes Then
   Mess = ""
   rst.MoveFirst
   Do While rst.EOF = False
     Mess = Mess & rst.Fields("Accno") & " "
     rst.MoveNext
   Loop
   txtData(7) = "BAR " & Mess & txtData(7) 'location of remains
  End If
 End If
End Sub

Private Sub txtData_GotFocus(Index As Integer)
 If WriteNew = False Then txtData(Index).BackColor = txtSelectColor
' If Index <> 8 Then Exit Sub  puts cursor at BOTTOM of NOTES field. Discontinued 5/10/2006
' txtData(Index).SelStart = Len(txtData(Index))
End Sub

Private Sub txtData_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)
 If Shift = 2 And KeyCode = 222 Then    ' control single quote    ctrl-'
   txtData(Index) = RememberMe(Index)
 End If
End Sub

Private Sub txtData_LostFocus(Index As Integer)
 If WriteNew = False Then
  txtData(Index).BackColor = txtNormalColor
  txtData(Index).ForeColor = vbBlack
 End If
End Sub

Private Sub txtFind_KeyPress(KeyAscii As Integer)
 If KeyAscii = 13 Then Call cmdFind_Click
End Sub
Private Sub AddNew(db As Database, rst As Recordset)
 Dim Temp1 As String
 Dim J As Long
 Dim CancelEdit As Boolean
 ''''''''''''''''''''''
 Set db = OpenDatabase(mdb872)
 Set rst = db.OpenRecordset("Reports", dbOpenDynaset)
 With rst
  Temp1 = txtData(0)
  Call Formats.Format_SiteId(Temp1, CancelEdit)
  If CancelEdit = False Then txtData(0) = Temp1
  If IsDate(RichTextBox(0)) Then
   Temp1 = RichTextBox(0)
   Temp1 = Format(Temp1, "mm/dd/yyyy")
   RichTextBox(0) = Temp1
  End If
  
  txtData(2) = UCase(txtData(2)) '872file
  txtData(3) = UCase(txtData(3)) 'updateFMSF
  txtData(4) = UCase(txtData(4)) 'RemainsEncountered
  txtData(5) = UCase(txtData(5)) 'RemainsRemoved
  .AddNew
  !SiteID = txtData(0)
  !Status = txtData(1)
   rst.Fields("872File") = txtData(2)  ' wont allow ! format with number in field name....
  !UpDateFMSF = txtData(3)
  !RemainsEncountered = txtData(4)
  !RemainsRemoved = txtData(5)
  !AdHoc = txtData(6)
  !NoticeNeeded = txtData(15)
  !NoticeDetails = txtData(16)
  !Summary = txtData(17)
  !NativeAmerican = txtData(14)
  !LocationOfRemains = txtData(7)
  !CaseNum = txtData(18)
  !Comment = RichTextBox(0)
  If IsDate(txtData(9)) = True Then
   !FirstReportDate = txtData(9)
  End If
  If IsDate(txtData(11)) = True Then
   !NextActionDate = txtData(11)
  End If
  !Contact = txtData(12)
  !FedsInvolved = txtData(13)
  .Update
  .Bookmark = .LastModified
 End With
End Sub

[dreammanor]

Hi Lyzarus, could you upload a zip file of the project? You could click "Go Advanced" to upload pictures or zip files.

[Elroy]

Ok Lyzarus,

I'm basically replying to what you said in post #3. And let me summarize, at least what I "think" are the pertinent parts. You've got an Access table. And it's got fields that may have either straight-up ASCII text in them or RTF text in them.

Therefore, you need to load that field into a string and do a bit of testing on it to determine whether it's ASCII or RTF. If it's RTF, it should always start with the string "{\rtf". I might also do an LCase$(LTrim$()) on it, just to head off any problems.

Now, let's assume you've got your new program that's using RichTextBoxes (RTBs). When loading those RTBs from the database, just test to see if your string is ASCII or RTF. If it's ASCII, load it into the .Text property. If it's RTF, load it into the .TextRTF property.

And then, to preserve that RTF formatting, just always save back to the database using the .TextRTF property.

Good Luck,
Elroy

EDIT1: Here's a bit of conceptual code for you:

    Dim bItsRtf As Boolean
    bItsRtf = LCase$(Left$(LTrim$(sFieldInString), 5)) = "{\rtf"

    If bItsRtf Then
        SomeRTB.TextRTF = sFieldInString
    Else
        SomeRTB.Text = sFieldInString
    End If

[Lyzarus]

I think I did this right? If not I'll try it again.

[dreammanor]

The zip file should include * .frm, *.frx, *.bas, *.mdb files

[dreammanor]

Hi Elroy, I checked his code and found that the RichTextBox control was used only in the following procedure:

Private Sub lstView_Click()
 ...
 ...

 RichTextBox(0) = lstView.SelectedItem.SubItems(8)   'comment
 RichTextBox(1) = lstView.SelectedItem.SubItems(10)  'Track

 ...

end Sub

Private Sub AddNew(db As Database, rst As Recordset)
 ...
 ...
 If IsDate(RichTextBox(0)) Then
   Temp1 = RichTextBox(0)
   Temp1 = Format(Temp1, "mm/dd/yyyy")
   RichTextBox(0) = Temp1
  End If
 
  ...

  rst!Comment = RichTextBox(0)
  ...

end Sub

Private Sub cmdUpDate_Click()
...
rst!Comment = RichTextBox(0)
...

end Sub

In other words, the software doesn't use the RichTextBox.TextRTF property, just use the RichTextBox.Text (plain text)

[Lyzarus]

Sorry, is there an easy way to upload files bigger than 10 megs?

Also, most of the data in the database is sensitive. I've narrowed it down to one single record to give an idea of what is there, but I can't really send much more than that.

The file is 11 megs.

[Lyzarus]

Sorry, that was probably me. Originally I dove into this trying to fix it myself. There is a txtData(8) I think (might not be 8) that was there to begin with.

I swapped it to RTF myself in order to try and get the format to load from the database, which worked fine. Just can't get the saving side of things to work.

[Elroy]

@dreammanor: Yeah, I think maybe you're willing to dive into his code a bit more than I am, especially if this is a large and spaghetti code project (which is sounds like it is).

@Lyzarus: Yeah, as dreammanor said, you need to gather up your VBP, BAS, FRM, FRX, & CLS files for us. There are other types, but I'm thinking your project doesn't use them. Ideally, you'd put them all into one folder. You can use the right-click, save-as option from the Project Window in the IDE to do that. The last piece would be a Save-As from the File menu option to actually save the VBP file there as well.

Once that's all gathered up, zip it and attach it. If you're just sending us source code (which is all that's allowed in these forums), it shouldn't be anywhere near 11 megs. In fact, it should be quite small.

Good Luck,
Elroy

EDIT1: Just an FYI, if you give us an EXE file, you'll get your hand slapped, and it'll be deleted.

EDIT2: Also, as far as I know, the .Text (and not the .TextRTF) property is the default property of the RTB control. Therefore, if you don't specify a property, it'll use the .Text property, which may not be what you want. That could be your "save" problem too.

[Lyzarus]

The only item of large size is the database itself.

Here is the rest of it without the database. Even with a single line in it the database is 11 megs.

[Lyzarus]

EDIT1: Just an FYI, if you give us an EXE file, you'll get your hand slapped, and it'll be deleted.

I'm not well versed in code, I don't think I'm THAT bad though :P

[Elroy]

Ahhh, you're trying to get us your MDB file. I'm not absolutely sure we need it. But, to make it smaller, load it up with Access and run the "Compact and Repair Database" procedure on it. After that, it'll probably be MUCH smaller.

And take a look at my EDIT2 in post #14.

[dreammanor]

@dreammanor: Yeah, I think maybe you're willing to dive into his code a bit more than I am, especially if this is a large and spaghetti code project (which is sounds like it is).

This is his first time to vbForums, I hope his problem can be resolved satisfactorily.

Although there is no access DB, I can already open his project. It's a very simple program, but I don't know what the OP's problem is?

@Lyzarus:
The following two small procedures may be useful to you: (I used Elroy's code)

Private Sub LoadRichTextDataFromDB(daoRs As DAO.Recordset, fieldName As String, RTB As RichTextBox)
    Dim sText As String
    Dim bIsRTF As Boolean
    
    If IsNull(daoRs.Fields(fieldName)) = False Then
        sText = daoRs.Fields(fieldName)
    End If
    
    bIsRTF = LCase$(Left$(LTrim$(sText), 5)) = "{\rtf"

    If bIsRTF Then
        RTB.TextRTF = sText
    Else
        RTB.Text = sText
    End If
    
End Sub

Private Sub SaveRichTextDataToDB(daoRs As DAO.Recordset, fieldName As String, RTB As RichTextBox)
    If RTB.Text = vbNullString Then
         daoRs.Fields(fieldName) = vbNullString
    Else
        daoRs.Fields(fieldName) = RTB.TextRTF
    End If
End Sub

[Lyzarus]

Alrighty. What I am actually trying to do is more simple than I am making it sound, please forgive me. I am fine with the rich text formatting being in the database, the rich text box works perfectly for what I am trying to do.

My issue is saving the box back to the database when you don't actively click the update button. When the save button is pressed it works fine, but if you happen to search a different record without saving, it just deletes everything and you will never know.

I'm trying to get the Rich Text Box to have a message box confirming changes when someone moves away from it without hitting the update button.

I'm really bad at explaining what I am aiming to do since I'm in such unfamiliar territory.

[Elroy]

Ahhh, ok, I think I now see.

This is something I deal with all the time because I refuse to use any data-binding.

To deal with this issue, I typically have a module-level variable that's declared something like the following:

Dim SomethingChanged As Boolean

And then, in Click & Change events of all my controls, I put this in:

Private Sub txtCode_Change()
    SomethingChanged = True
End Sub

Private Sub txtDescription_Change()
    SomethingChanged = True
End Sub

Private Sub txtGrouping_Change()
    SomethingChanged = True
End Sub

The above is just an example out of some of my code.

And then, when changing records, I have code that checks the SomethingChanged boolean. Typically, I don't change records while on a single form, so it's just an issue for me when closing the form, but here's an example of how I handle it.

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    ' If we clicked the close button on the form, do we wish to save work.
    If UnloadMode = vbFormControlMenu And SomethingChanged Then
        If AddingOrEditing = Adding Then
            If MsgBox("Do you wish to save this new motion model?", vbQuestion + vbYesNo, App.Title) = vbYes Then
                If Not WorkSavedAndReadyToClose Then Cancel = True
            End If
        Else
            If MsgBox("Do you wish to save the changes you made to this motion model?", vbQuestion + vbYesNo, App.Title) = vbYes Then
                If Not WorkSavedAndReadyToClose Then Cancel = True
            End If
        End If
    End If
End Sub

And then, I have a standard routine called WorkSavedAndReadyToClose. It exists in MANY of my forms, but here's an example:

Function WorkSavedAndReadyToClose() As Boolean


	' Do what you need to do to save your work.

    '
    WorkSavedAndReadyToClose = True
End Function

I don't think that code above has all the call references resolved, but it gives you the idea. If you've got some RTB, you need to track changes, something like the following:

Private Sub SomeRTB_Change()
    SomethingChanged = True
End Sub

And then, whenever you're about to move off of your record, you need to check that SomethingChanged variable, and act accordingly.

Good Luck,
Elroy

EDIT1: Sorry if you saw my first attempt to post this post. Something went wrong with my colorizer.

[techgnome]

Something to remember though... when you load the RTB from the database, that will cause the changed event to fire... so after you move to a new record, and load it, you'll want to re-set the flag back to false so that you don't prompt the user even when they didn't change anything.

-tg

[dreammanor]

@Lyzarus: I modified your code, you should also study Elroy's code carefully.

[Lyzarus]

Thank you both for all the help and patience in this. I will take everything you have posted and read through it as best as I can.

I really appreciate it and our new employee will as well. I'm an Archaeologist, not a computer scientist, this is out of my realm!

[Lyzarus]

@Dreammanor

I'm gone through the code you added and had a question. The function is there, but it pops up twice, the first time a box comes up and the record is still visible in the form. No matter what option is hit the box then pops back up after the form has been cleared.

What is the trigger for it? Lost focus?

[Elroy]

Something to remember though... when you load the RTB from the database, that will cause the changed event to fire... so after you move to a new record, and load it, you'll want to re-set the flag back to false so that you don't prompt the user even when they didn't change anything.

Thanks for mentioning that. I always do that but forgot to mention it to Lyzarus. Good catch.


EDIT1: Lyzarus, just as an FYI, many call this a "dirty" flag. Way back literally decades ago, I just always called mine "SomethingChanged", but whatever you call it, I hope you get the idea.

[Lyzarus]

Yeah, I actually understood it believe it or not! I'm working on implementing yours and testing Dreams to see which works better with the actual database loaded.

[dreammanor]

@Dreammanor

I'm gone through the code you added and had a question. The function is there, but it pops up twice, the first time a box comes up and the record is still visible in the form. No matter what option is hit the box then pops back up after the form has been cleared.

What is the trigger for it? Lost focus?

The code in the RichTextBox_LostFocus is not needed, it's just to show you how to trigger a " data-changing alert message"

[dreammanor]

@Elroy, I wrote the following procedure for Lyzarus, but I didn't write comments:

Private Function CheckDataChanged() As Boolean
    Dim sMsg As String
    Dim nReturn As Long
    
    CheckDataChanged = True
    
    If m_bDataChanged = False Then Exit Function
    
    sMsg = "Data changed !" & vbCrLf & vbCrLf & _
            "Do you want to save the changed data?"
    
    nReturn = MsgBox(sMsg, vbYesNoCancel, "Data changed")
    
    If nReturn = vbYes Then
        cmdUpDate_Click
    ElseIf nReturn = vbCancel Then
        CheckDataChanged = False
    End If
 
End Function

[Elroy]

@Dreammanor: Yeah, that's similar to what I had in my Form_QueryUnload event. I knew he'd have to "bend" it to fit his situation.

[Lyzarus]

After giving it a try I have run into what I think is a fairly simple thing. The RichTextBox_Change event does not set the m_bDataChanged boolean to true. Due to this, loss of focus on the box always states there is an update even if nothing was changed, same with the search functions. It acts as if changes have been made even if they have not.

Lastly, and I think this is related to the change event not running, it appears that the ListView doesn't activate the request to save at all, so selecting a second record off the list that comes up drops changes.

Is there a database of events somewhere that I can read through?

[Elroy]

The RTB change event sure seems to be working for me:

Option Explicit

Private Sub RichTextBox1_Change()
    Debug.Print "RTB changing"
End Sub

And then, as I type:



I'm sure glad it does work because I use this in quite a few places.

Now, the ListView isn't directly editable. You can add and delete rows, but you can't edit the cells. I've got a class that allows for editing, and there are several others around as well. My class has a "SomethingChanged" property in it. I'll post my class, but it's rather specific to my needs. There are probably more universal ones around if you go this route.

Here's mine. There's also a subclassing piece that works in conjunction with this that I haven't provided (but I'm willing to).

Option Explicit
'
Dim WithEvents lvw As ListView
Dim WithEvents txt As TextBox
Dim WithEvents cbo As ComboBox
'
Dim mlColIndex As Long
Dim mlRowIndex As Long
Dim mbEditableCols() As Boolean ' One for each column, boolean for editable or not.  ZERO based with main column as 0.
Dim moEditCombo() As Control
'
Dim mbSomethingChanged As Boolean
Dim mbLoading As Boolean
'

Friend Property Set EditCombo(iColZeroBased As Long, oCombo As ComboBox)
    Set moEditCombo(iColZeroBased) = oCombo
    oCombo.Visible = False
End Property
'
'Friend Sub EditCombo(iColZeroBased As Long, oCombo As ComboBox)
'    Set moEditCombo(iColZeroBased) = oCombo
'    oCombo.Visible = False
'End Sub

Friend Property Get SomethingChanged() As Boolean
    SomethingChanged = mbSomethingChanged
End Property

Friend Property Let SomethingChanged(b As Boolean)
    mbSomethingChanged = b
End Property

Friend Sub Init(oLvw As ListView, oTxt As TextBox, ParamArray vEditableCols() As Variant)
    ' Values in vEditableCols are ONE based.
    '
    Dim i As Long
    Dim lEditableCols() As Long
    '
    Set lvw = oLvw
    Set txt = oTxt
    '
    ReDim lEditableCols(LBound(vEditableCols) To UBound(vEditableCols))
    For i = LBound(vEditableCols) To UBound(vEditableCols)
        lEditableCols(i) = CLng(vEditableCols(i))
    Next i
    '
    txt.Text = vbNullString
    txt.Visible = False
    txt.BackColor = lvw.BackColor
    txt.Borderstyle = 0
    txt.Font.Bold = lvw.Font.Bold
    txt.Font.Name = lvw.Font.Name
    txt.Font.Italic = lvw.Font.Italic
    txt.Font.Size = lvw.Font.Size
    txt.Font.Underline = lvw.Font.Underline
    '
    txt.Alignment = vbLeftJustify
    txt.Appearance = vbFlat
    '
    ' The following means that we can't add columns at runtime.
    ReDim moEditCombo(0 To lvw.ColumnHeaders.Count - 1)
    ReDim mbEditableCols(0 To lvw.ColumnHeaders.Count - 1)
    For i = LBound(lEditableCols) To UBound(lEditableCols)
        mbEditableCols(lEditableCols(i)) = True
    Next i
    '
    mbSomethingChanged = False
    mbLoading = False
End Sub

Private Sub Class_Terminate()
    Set lvw = Nothing
    Set txt = Nothing
    Erase moEditCombo
    Erase mbEditableCols
End Sub

Private Sub lvw_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim LvwHitInfo As LVHITTESTINFO
    Dim iLeft As Long
    Dim iTop As Long
    Dim iWidth As Long
    Dim iHeight As Long
    '
    If lvw.SelectedItem Is Nothing Then Exit Sub
    If Button <> vbLeftButton Then Exit Sub
    '
    ' Make sure we're allowed to edit.
    ListViewItemAndSubHitTest lvw, X, Y, LvwHitInfo
    If LvwHitInfo.lItem < 1 Then Exit Sub
    If LvwHitInfo.lSubItem < 0 Then Exit Sub
    If LvwHitInfo.lSubItem >= lvw.ColumnHeaders.Count - 1 Then Exit Sub  ' We MUST have a thin last column.  Last column can NOT be selected.
    If Not mbEditableCols(LvwHitInfo.lSubItem) Then Exit Sub
    '
    ' Save for restoring text.
    mlRowIndex = LvwHitInfo.lItem
    mlColIndex = LvwHitInfo.lSubItem + 1
    '
    ' Figure out position of TextBox.  WARNING:  This assumes FORM is set to vbTwips SCALEMODE.
    iLeft = lvw.Left + lvw.ColumnHeaders(mlColIndex).Left
    iTop = lvw.Top + lvw.SelectedItem.Top
    iHeight = lvw.SelectedItem.Height ' It is assumed we NEVER have a horizontal scrollbar.
    iWidth = (lvw.ColumnHeaders(mlColIndex + 1).Left - lvw.ColumnHeaders(mlColIndex).Left)
    '
    ' Why isn't lvw.SelectedItem.Width used?  That way, we could get the last column.
    ' Debug.Print txt.Width, lvw.SelectedItem.Width
    '
    ' Put text in control and show it.
    mbLoading = True
    If moEditCombo(LvwHitInfo.lSubItem) Is Nothing Then
        If LvwHitInfo.lSubItem = 0 Then
            txt.Text = lvw.SelectedItem.Text
        Else
            txt.Text = lvw.SelectedItem.SubItems(LvwHitInfo.lSubItem)
        End If
        If mlColIndex = 1 Then ' First column is spaced a bit differently.
            txt.Left = iLeft + Screen.TwipsPerPixelX * 6
        Else
            txt.Left = iLeft + Screen.TwipsPerPixelX * 8
        End If
        txt.Top = iTop + Screen.TwipsPerPixelX * 3
        txt.Width = iWidth - Screen.TwipsPerPixelX * 7
        txt.Height = iHeight
        txt.Visible = True
        txt.SelStart = Len(txt.Text)
        txt.SetFocus
    Else
        Set cbo = moEditCombo(LvwHitInfo.lSubItem)
        On Error Resume Next ' Some combos will error on certain text (if not in list).
            If LvwHitInfo.lSubItem = 0 Then
                cbo.Text = lvw.SelectedItem.Text
            Else
                cbo.Text = lvw.SelectedItem.SubItems(LvwHitInfo.lSubItem)
            End If
        On Error GoTo 0
        cbo.Left = iLeft + Screen.TwipsPerPixelX
        cbo.Top = iTop + Screen.TwipsPerPixelY
        cbo.Width = iWidth + Screen.TwipsPerPixelX * 20
        'cbo.Height = iHeight           ' Read-only on combos
        cbo.Visible = True
        'cbo.SelStart = Len(txt.Text)   ' Not applicable to combos.
        cbo.SetFocus
    End If
    mbLoading = False
End Sub

Private Sub cbo_Change()
    If mbLoading Then Exit Sub
    mbSomethingChanged = True
End Sub

Private Sub cbo_Click()
    If mbLoading Then Exit Sub
    mbSomethingChanged = True
End Sub

Private Sub txt_Change()
    If mbLoading Then Exit Sub
    mbSomethingChanged = True
End Sub

Private Sub cbo_KeyPress(KeyAscii As Integer)
    Select Case KeyAscii
    Case vbKeyReturn, vbKeyEscape
        KeyAscii = 0
        EndEditMode
    End Select
End Sub

Private Sub txt_KeyPress(KeyAscii As Integer)
    Select Case KeyAscii
    Case vbKeyReturn, vbKeyEscape
        KeyAscii = 0
        EndEditMode
    End Select
End Sub

Private Sub cbo_KeyUp(KeyCode As Integer, Shift As Integer)
    Select Case KeyCode
    Case vbKeyDown, vbKeyUp, vbKeyHome, vbKeyEnd, vbKeyPageDown, vbKeyPageUp
        EndEditMode
    End Select
End Sub

Private Sub txt_KeyUp(KeyCode As Integer, Shift As Integer)
    Select Case KeyCode
    Case vbKeyDown, vbKeyUp, vbKeyHome, vbKeyEnd, vbKeyPageDown, vbKeyPageUp
        EndEditMode
    End Select
End Sub

Private Sub cbo_LostFocus()
    EndEditMode
End Sub

Private Sub txt_LostFocus()
    EndEditMode
End Sub

Public Sub EndEditMode() ' Must be public because it's called with late binding.
    If cbo Is Nothing Then
        Select Case True
        Case mlColIndex = 1
            lvw.ListItems(mlRowIndex).Text = Trim$(txt.Text) ' Restore the text.
        Case mlColIndex
            lvw.ListItems(mlRowIndex).SubItems(mlColIndex - 1) = Trim(txt.Text)
        End Select
        txt.Visible = False ' Hide TextBox.
    Else
        Select Case True
        Case mlColIndex = 1
            lvw.ListItems(mlRowIndex).Text = Trim$(cbo.Text) ' Restore the text.
        Case mlColIndex
            lvw.ListItems(mlRowIndex).SubItems(mlColIndex - 1) = Trim(cbo.Text)
        End Select
        cbo.Visible = False ' Hide TextBox.
        Set cbo = Nothing
    End If
    mlRowIndex = 0
    mlColIndex = 0
End Sub

Good Luck,
Elroy

EDIT1: Just as an FYI, the subclassing piece is used to capture the listview's scroll event, as it doesn't natively have one. That's needed if we're to move our edit box around when the listview scrolls. If you don't do any scrolling, it's not needed.

[Lyzarus]

I was actually editing my post when you sent that. I had it backwards. It is working too well.

Somewhere in here it is starting when the code is started. I added a simple message box to popup when the the RichTextBox_Change was activated and it activates as soon as I load, as well as soon as I do anything else. So somewhere in there it is defaulted to true and I have to find where.

As For the listview I intend to just make an on click event for it that checks if change is true and prompts to save. I'm not worried about editing or changing data in the listview box itself.

You guys have been an immeasurable help. If I can buy you a beer or something let me know.

[Elroy]

Hi Lyzarus,

Well, I think that's the point that techgnome made in post #21.

If you load it when you pull data from the database, that will call RTB_Change. Therefore, after you load things from a record in your database, you need to be sure and immediately turn your "changed" flag off after you get things loaded.

Good Luck,
Elroy

EDIT1: As an example, this is the tail end of one of my form fill-out procedures. Remember that I tend to not allow changing records on a form, so I'm a bit different from you, but it gives you the idea:

    sRightAvgIntegralLatFore = FloatVal(FootPressureServices![RightAvgIntegralLatFore], 3)
    sRightAvgIntegralMedFore = FloatVal(FootPressureServices![RightAvgIntegralMedFore], 3)
    '
    LoadLeftPicture
    LoadRightPicture
    '
    SomethingChanged = False
    PartialSave = False
End Sub

[Lyzarus]

Yup, that was part of it.

I had to edit the way dreammanor had added the lines. Once it interacted with the database and the way the program actually loads it was loading it at strange times.

Clearing the flag and changing what he wrote to call it different worked.

It is actually functioning now.

[dreammanor]

I was actually editing my post when you sent that. I had it backwards. It is working too well.

Somewhere in here it is starting when the code is started. I added a simple message box to popup when the the RichTextBox_Change was activated and it activates as soon as I load, as well as soon as I do anything else. So somewhere in there it is defaulted to true and I have to find where.

As For the listview I intend to just make an on click event for it that checks if change is true and prompts to save. I'm not worried about editing or changing data in the listview box itself.

You guys have been an immeasurable help. If I can buy you a beer or something let me know.

Glad to see your problem solved. You could learn Elroy's code carefully, especially his coding-style.

Cheers.

[Lyzarus]

Yeah I have saved everything from this post and will be using it in the future I assume. I've been holding this software together with bandages. I'm good with computers but never really learned any coding. Thankfully you guys pulled through here. The worst part for me was that I wasn't even close, but I suppose thats what happens when you are trying to wing it.

It is still very rough around the edges and I have some errors to fix but all of those I actually know how to do.

Thanks for putting up with me again guys, I really appreciate it.

[Elroy]

Hey, I too am glad to hear you got it going. And no need to be a stranger. All kinds and all levels are welcome here.

And ... just saying ... if you see us occasionally at each-other's throats, just ignore it. It seems we just have to do that on occasion. *laughs* You know, big egos.

Lyzarus, you take care.

Elroy

[Lyzarus]

I hate to resurrect this thread, but I had one more question come up.

I got the entire program to function exactly how I want minus one little problem. The issue is that there is a list view for when you pull a list of search results. If you make a change in the above mentioned RTB and then click on the list view it asks you if you want to save as it is supposed to.

The problem is that it overwrites the record you are selecting not the record you have changed and are navigating from. Is there a way to pause it so that it changes the correct line? I assume I just have it running the save in the wrong place.

Thanks again, this entire thing is almost 100%

[jpbro]

If you use the Validate event of the RichTextBox, you can do your saving there - it will fire before focus moves to the ListView. You can even cancel the focus change to the ListView entirely.

Something like this:

Private Sub RichTextBox1_Validate(Cancel As Boolean)
   Dim l_Choice As VbMsgBoxResult
   
   If mbSomethingChanged Then
      l_Choice = MsgBox("Do you want to save the changes?", vbYesNoCancel)

      Select Case l_Choice
      Case vbYes
         ' Save changes
         MsgBox "Save Changes"

      Case vbCancel
         Cancel = True ' Prevent focus change
      End Select
   End If
End Sub

[dilettante]

I'm sure I have missed some requirements in all of these posts above. Some that I haven't missed are that (a.) this is an existing (large?) program, and (b.) it is written in VB5.

But setting that aside this doesn't seem as hard as some of those posts above might suggest.

I have thrown a quicky together. It has at least one issue (see the ReadMe.txt) that means you'll want to unzip the archive and then compile it from Explorer (right-click, Make). Otherwise take note of the ReadMe note and deal with things accordingly. If I figure out the problem I'll post a correction, but it may well be a VB6 bug and not mine.


As you can see there just isn't much here. Even some of that is dealing with the optional "compact on exit" and the majority of the code is user interface gingerbread. The rest of the modules are wrapping a RichTextBox with a toolbar as a UserControl and dealing with some database mechanics including creating a new database on first run.

Option Explicit

Private CompactOnExit As Boolean
Private CachedCaption As String

Private Property Set DataSource(ByVal RHS As Object)
    Set DataGrid1.DataSource = RHS
    Set txtThis.DataSource = RHS
    Set txtThat.DataSource = RHS
    Set rtbcMemo.DataSource = RHS
End Property

Private Sub Form_Initialize()
    CachedCaption = Caption
    Set DataSource = Module1.Recordset
    With DataGrid1
        .Columns(0).Width = 640
        .Columns(3).Visible = False
    End With
End Sub

Private Sub Form_Resize()
    Dim Gap As Single

    If WindowState <> vbMinimized Then
        Gap = ScaleY(4, vbPixels, ScaleMode)
        With DataGrid1
            .Move 0, 0, ScaleWidth, ScaleHeight * 0.375! - Gap
            Frame1.Move 0, .Height + Gap * 2, ScaleWidth, ScaleHeight - (.Height + Gap * 2)
            With Frame1
                rtbcMemo.Width = .Width
                rtbcMemo.Height = .Height - rtbcMemo.Top
            End With
        End With
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    'First unbind DataGrid1, then force updating of any pending edits:
    Set DataGrid1.DataSource = Nothing
    Module1.Recordset.MoveNext

    Set DataSource = Nothing 'Unbind all controls.
    Module1.CloseDb
    If CompactOnExit Then Module1.CommpactDb
End Sub

Private Sub mnuCompactonexit_Click()
    CompactOnExit = Not CompactOnExit
    If CompactOnExit Then
        Caption = CachedCaption & " [will compact]"
    Else
        Caption = CachedCaption
    End If
End Sub

In the screenshot I have scrolled down and picked that last row of the database table, then altered the three editable fields (leaving the ID alone). I pasted in a bunch of sample text, changed fonts, colors, etc. and even inserted and sized a picture.

Seems to work just fine aside from the development glitch spelled out in the ReadMe file.