Ritch Text Box Project . a BIG question

**PRIVATE1** · Oct 1st, 2000, 12:18 PM

This is a bigger one heres what you need .

1 command button named Command2
3 checkboxes named ChkBold , ChkItalic , and ChkUnderline .
1 commondialogbox named dlgColors
2 Rich Text Boxes named rtbChat , and RtbText .
1 ComboBox named cmbFonts

put this code in a form

Code:


Private Sub chkUnderline_Click()

   'toggle underline
   If ChkUnderline.Value = vbChecked Then
      RtbText.SelUnderline = True
   Else
      RtbText.SelUnderline = False
   End If
   
 RtbText.SetFocus
   
End Sub

Private Sub chkItalic_Click()

   'toggle italic
   If ChkItalic.Value = vbChecked Then
      RtbText.SelItalic = True
   Else
      RtbText.SelItalic = False
   End If
   
 RtbText.SetFocus
   
End Sub

Private Sub ChkBold_Click()
'toggle bold
   If ChkBold.Value = vbChecked Then
      RtbText.SelBold = True
   Else
      RtbText.SelBold = False
   End If
   
 RtbText.SetFocus
End Sub

Private Sub cmbFonts_Click()
On Error Resume Next

  'set the font
  RtbText.SelFontName = cmbFonts.List(cmbFonts.ListIndex)
  RtbText.SetFocus
End Sub

Private Sub Command1_Click()
On Error GoTo ErrorHandler

dlgColors.CancelError = True
dlgColors.ShowColor
RtbText.SelColor = dlgColors.Color
RtbText.SetFocus


ErrorHandler: 'user click 'Cancel'
End Sub

Private Sub Command2_Click()
 
  Dim strRTF As String, strFontName As String, lngFontColor As Long, lngFontSize As Long
  Dim blnBold As Boolean, blnUnderline As Boolean, blnItalic As Boolean
  
    'check if connected to someone
   ' If sckConnect.State = sckClosed Then
     '  MsgBox "You must be connected to someone."
     '  Exit Sub
   ' End If
   
  'get font-styles so we can reset them later
  blnBold = RtbText.SelBold
  blnUnderline = RtbText.SelUnderline
  blnItalic = RtbText.SelItalic
  lngFontColor& = RtbText.SelColor
  lngFontSize& = RtbText.SelFontSize
  strFontName$ = RtbText.SelFontName
  
  ''format text w/ nick and assign rtf to strRTF$
 ' RtbText.SelStart = 0
 ' RtbText.SelLength = 0
 ' RtbText.SelText = vbCrLf & txtNick.Text & ":" & vbTab
 ' RtbText.SelStart = 0
 ' RtbText.SelLength = Len(txtNick.Text) + 4 '4 = Length of vbCrLf + ':' + vbTab
 ' RtbText.SelColor = vbBlue
 ' RtbText.SelFontSize = 8
 ' RtbText.SelFontName = "Arial"
 ' RtbText.SelBold = True
 ' RtbText.SelUnderline = False
  'RtbText.SelItalic = False
  'RtbText.SelStart = 0
  'RtbText.SelLength = 0
  
  strRTF$ = RtbText.TextRTF + vbCrLf
  
  ''clear textbox
  RtbText.Text = ""
   
  ''reset font-styles
  RtbText.SelBold = blnBold
  RtbText.SelUnderline = blnUnderline
  RtbText.SelItalic = blnItalic
  RtbText.SelColor = lngFontColor&
  RtbText.SelFontSize = lngFontSize&
  RtbText.SelFontName = strFontName$
   
  ''show bottom half of textbox
  rtbChat.SelStart = Len(rtbChat.Text)
  rtbChat.SelLength = 0
  
  'print text in our rtbChat
  
  rtbChat.SelRTF = strRTF$

  Debug.Print strRTF$
  
  '**********************************
  '*********************************
  ' This is where the issue is . It's caused by VbCrLf
  ' if you remove the VbCrLf below and rerun the form     
  rtbChat.Text = rtbChat.Text + vbCrLf

  'scroll rtbChat down
  rtbChat.SelStart = Len(rtbChat.Text)
  rtbChat.SelLength = 0
  
  'set focus
  RtbText.SetFocus
  
  ''Send text to other person
  ''Call sckConnect.SendData(strRTF$)
End Sub

Private Sub Form_Load()
 
 Dim intBuffer As Integer, strFont As String
 
   'load printer fonts to combobox
   If Dir$(App.Path & "\fonts.dat") = "" Then
        'font file doesnt exist. Create it.
        Open App.Path & "\fonts.dat" For Output As #1
             For intBuffer% = 0 To Printer.FontCount - 1
                Call cmbFonts.AddItem(Printer.Fonts(intBuffer%))
                Print #1, Printer.Fonts(intBuffer%)
             Next intBuffer%
        Close #1
   Else
        'load fonts from file
        Open App.Path & "\fonts.dat" For Input As #1
             While Not EOF(1)
                Input #1, strFont$
                Call cmbFonts.AddItem(strFont$)
             Wend
        Close #1
   End If
   
 cmbFonts.ListIndex = 0
 ''cmbFonts.Sorted = True 'Alphabetize list


  'set combobox to "Arial"
  For intBuffer% = 0 To cmbFonts.ListCount - 1
    If cmbFonts.List(intBuffer%) = "Arial" Then cmbFonts.ListIndex = intBuffer%: Exit For
  Next intBuffer%
  

  'set rtbText's font-styles
  RtbText.SelBold = False
  RtbText.SelUnderline = False
  RtbText.SelItalic = False
  RtbText.SelColor = vbBlack
  RtbText.SelFontName = cmbFonts.List(cmbFonts.ListIndex)
  RtbText.SelFontSize = 10

End Sub

If you can see I'm trying to sperate the lines in the RTB
by a vbCrLf but when I do that it doesn't keep the new font settings .

Thanks for the help ,
Private

**dead** · Oct 1st, 2000, 03:44 PM

well you could just start using registry setting and call on them as needed. my guess is that it's unloading something before it has a chance to retrive it. just avoid the problem and use:

SaveSetting & GetSettings

-deadBird

Oct 1st, 2000, 04:35 PM

Never say Never, dead, for it's just a small syntax error.
I've highlighted the correction in BOLD, ITALIC, and UNDERLINE: Like This.

Code:

Private Sub chkUnderline_Click()

   'toggle underline
   If chkUnderline.Value = vbChecked Then
      rtbText.SelUnderline = True
   Else
      rtbText.SelUnderline = False
   End If
   
 rtbText.SetFocus
   
End Sub

Private Sub chkItalic_Click()

   'toggle italic
   If chkItalic.Value = vbChecked Then
      rtbText.SelItalic = True
   Else
      rtbText.SelItalic = False
   End If
   
 rtbText.SetFocus
   
End Sub

Private Sub ChkBold_Click()
'toggle bold
   If chkBold.Value = vbChecked Then
      rtbText.SelBold = True
   Else
      rtbText.SelBold = False
   End If
   
 rtbText.SetFocus
End Sub

Private Sub cmbFonts_Click()
On Error Resume Next

  'set the font
  rtbText.SelFontName = cmbFonts.List(cmbFonts.ListIndex)
  rtbText.SetFocus
End Sub

Private Sub Command1_Click()
On Error GoTo ErrorHandler

dlgColors.CancelError = True
dlgColors.ShowColor
rtbText.SelColor = dlgColors.Color
rtbText.SetFocus


ErrorHandler: 'user click 'Cancel'
End Sub

Private Sub Command2_Click()
 
  Dim strRTF As String, strFontName As String, lngFontColor As Long, lngFontSize As Long
  Dim blnBold As Boolean, blnUnderline As Boolean, blnItalic As Boolean
  
    'check if connected to someone
   ' If sckConnect.State = sckClosed Then
     '  MsgBox "You must be connected to someone."
     '  Exit Sub
   ' End If
   
  'get font-styles so we can reset them later
  blnBold = rtbText.SelBold
  blnUnderline = rtbText.SelUnderline
  blnItalic = rtbText.SelItalic
  lngFontColor& = rtbText.SelColor
  lngFontSize& = rtbText.SelFontSize
  strFontName$ = rtbText.SelFontName
  
  ''format text w/ nick and assign rtf to strRTF$
 ' RtbText.SelStart = 0
 ' RtbText.SelLength = 0
 ' RtbText.SelText = vbCrLf & txtNick.Text & ":" & vbTab
 ' RtbText.SelStart = 0
 ' RtbText.SelLength = Len(txtNick.Text) + 4 '4 = Length of vbCrLf + ':' + vbTab
 ' RtbText.SelColor = vbBlue
 ' RtbText.SelFontSize = 8
 ' RtbText.SelFontName = "Arial"
 ' RtbText.SelBold = True
 ' RtbText.SelUnderline = False
  'RtbText.SelItalic = False
  'RtbText.SelStart = 0
  'RtbText.SelLength = 0
  
  strRTF$ = rtbText.TextRTF + vbCrLf
  
  ''clear textbox
  rtbText.Text = ""
   
  ''reset font-styles
  rtbText.SelBold = blnBold
  rtbText.SelUnderline = blnUnderline
  rtbText.SelItalic = blnItalic
  rtbText.SelColor = lngFontColor&
  rtbText.SelFontSize = lngFontSize&
  rtbText.SelFontName = strFontName$

  ''show bottom half of textbox
  rtbChat.SelStart = Len(rtbChat.Text)
  rtbChat.SelLength = 0

  'print text in our rtbChat
  
  rtbChat.SelRTF = strRTF$

  Debug.Print strRTF$
  
  '**********************************
  '*********************************
  ' This is where the issue is . It's caused by VbCrLf
  ' if you remove the VbCrLf below and rerun the form

  ' No.  You used the TEXT property, which resets the formatting.  This should work.
  rtbChat.TextRTF = rtbChat.TextRTF + vbCrLf

  'scroll rtbChat down
  rtbChat.SelStart = Len(rtbChat.Text)
  rtbChat.SelLength = 0
  
  'set focus
  rtbText.SetFocus
  
  ''Send text to other person
  ''Call sckConnect.SendData(strRTF$)
End Sub

Private Sub Form_Load()
 
 Dim intBuffer As Integer, strFont As String
 
   'load printer fonts to combobox
   If Dir$(App.Path & "\fonts.dat") = "" Then
        'font file doesnt exist. Create it.
        Open App.Path & "\fonts.dat" For Output As #1
             For intBuffer% = 0 To Printer.FontCount - 1
                Call cmbFonts.AddItem(Printer.Fonts(intBuffer%))
                Print #1, Printer.Fonts(intBuffer%)
             Next intBuffer%
        Close #1
   Else
        'load fonts from file
        Open App.Path & "\fonts.dat" For Input As #1
             While Not EOF(1)
                Input #1, strFont$
                Call cmbFonts.AddItem(strFont$)
             Wend
        Close #1
   End If
   
 cmbFonts.ListIndex = 0
 ''cmbFonts.Sorted = True 'Alphabetize list


  'set combobox to "Arial"
  For intBuffer% = 0 To cmbFonts.ListCount - 1
    If cmbFonts.List(intBuffer%) = "Arial" Then cmbFonts.ListIndex = intBuffer%: Exit For
  Next intBuffer%
  

  'set rtbText's font-styles
  rtbText.SelBold = False
  rtbText.SelUnderline = False
  rtbText.SelItalic = False
  rtbText.SelColor = vbBlack
  rtbText.SelFontName = cmbFonts.List(cmbFonts.ListIndex)
  rtbText.SelFontSize = 10

End Sub

Even Megatron makes mistakes or need help sometimes, so don't be embarrassed.

**PRIVATE1** · Oct 3rd, 2000, 03:19 PM

This is bugging me ... It makes no sense

Code:

Private Sub chkUnderline_Click()

   'toggle underline
   If ChkUnderline.Value = vbChecked Then
      RtbTextSend.SelUnderline = True
   Else
      RtbTextSend.SelUnderline = False
   End If
   
 RtbText.SetFocus
   
End Sub

Private Sub chkItalic_Click()

   'toggle italic
   If ChkItalic.Value = vbChecked Then
      RtbTextSend.SelItalic = True
   Else
      RtbTextSend.SelItalic = False
   End If
   
 RtbTextSend.SetFocus
   
End Sub

Private Sub ChkBold_Click()
'toggle bold
   If ChkBold.Value = vbChecked Then
      RtbTextSend.SelBold = True
   Else
      RtbTextSend.SelBold = False
   End If
   
 RtbTextSend.SetFocus
End Sub

Private Sub cmbFonts_Click()
On Error Resume Next

  'set the font
  RtbTextSend.SelFontName = cmbFonts.List(cmbFonts.ListIndex)
  RtbTextSend.SetFocus
End Sub

Private Sub Command1_Click()
On Error GoTo ErrorHandler

dlgColors.CancelError = True
dlgColors.ShowColor
RtbText.SelColor = dlgColors.Color
RtbText.SetFocus


ErrorHandler: 'user click 'Cancel'
End Sub

Private Sub Command2_Click()
 
  Dim strRTF As String, strFontName As String, lngFontColor As Long, lngFontSize As Long
  Dim blnBold As Boolean, blnUnderline As Boolean, blnItalic As Boolean
  
    
  'get font-styles so we can reset them later
  blnBold = RtbTextSend.SelBold
  blnUnderline = RtbTextSend.SelUnderline
  blnItalic = RtbTextSend.SelItalic
  lngFontColor& = RtbTextSend.SelColor
  lngFontSize& = RtbTextSend.SelFontSize
  strFontName$ = RtbTextSend.SelFontName
  
  ''format text w/ nick and assign rtf to strRTF$
  RtbTextSend.SelStart = 0
  RtbTextSend.SelLength = 0
  RtbTextSend.SelText = TxtNick.Text & ":" & vbTab
  RtbTextSend.SelStart = 0
  RtbTextSend.SelLength = Len(TxtNick.Text) + 4 '4 = Length of vbCrLf + ':' + vbTab
  RtbTextSend.SelColor = vbBlue
  RtbTextSend.SelFontSize = 8
  RtbTextSend.SelFontName = "Arial"
  RtbTextSend.SelBold = True
  RtbTextSend.SelUnderline = False
  RtbTextSend.SelItalic = False
  RtbTextSend.SelStart = 0
  RtbTextSend.SelLength = 0
  
  strRTF$ = RtbTextSend.TextRTF '& Asc(13) & Asc(10)
  
  ''clear textbox
  RtbTextSend.Text = ""
   
  ''reset font-styles
  RtbTextSend.SelBold = blnBold
  RtbTextSend.SelUnderline = blnUnderline
  RtbTextSend.SelItalic = blnItalic
  RtbTextSend.SelColor = lngFontColor&
  RtbTextSend.SelFontSize = lngFontSize&
  RtbTextSend.SelFontName = strFontName$
   
  ''show bottom half of textbox
  rtbChat.SelStart = Len(rtbChat.Text)
  rtbChat.SelLength = 0
  
  'print text in our rtbChat
  'use this rtbChat.seltext = rtbChat.seltext & rtbNew.seltext
 'MsgBox rtbChat.SelRTF & " strRTF$ STARTS HERE " & strRTF$
 ' rtbChat.TextRTF = vbCrLf & strRTF$
  Debug.Print strRTF$
  
  Dim oldRTF, newrtf As String
  oldRTF = rtbChat.SelText
 '*******************************
 '*******************************
 'THIS Line below does not put strRTF$ on a seperate line
 'in the RTB Why ? 
 rtbChat.SelRTF = oldRTF & vbCrLf & strRTF$

  'scroll rtbChat down
  rtbChat.SelStart = Len(rtbChat.Text)
  rtbChat.SelLength = 0
  
  'set focus
  RtbTextSend.SetFocus
  
  End Sub

Private Sub Form_Load()
 
 Dim intBuffer As Integer, strFont As String
 
   'load printer fonts to combobox
   If Dir$(App.Path & "\fonts.dat") = "" Then
        'font file doesnt exist. Create it.
        Open App.Path & "\fonts.dat" For Output As #1
             For intBuffer% = 0 To Printer.FontCount - 1
                Call cmbFonts.AddItem(Printer.Fonts(intBuffer%))
                Print #1, Printer.Fonts(intBuffer%)
             Next intBuffer%
        Close #1
   Else
        'load fonts from file
        Open App.Path & "\fonts.dat" For Input As #1
             While Not EOF(1)
                Input #1, strFont$
                Call cmbFonts.AddItem(strFont$)
             Wend
        Close #1
   End If
   
 cmbFonts.ListIndex = 0
 ''cmbFonts.Sorted = True 'Alphabetize list


  'set combobox to "Arial"
  For intBuffer% = 0 To cmbFonts.ListCount - 1
    If cmbFonts.List(intBuffer%) = "Arial" Then cmbFonts.ListIndex = intBuffer%: Exit For
  Next intBuffer%
  

  'set rtbText's font-styles
  RtbTextSend.SelBold = False
  RtbTextSend.SelUnderline = False
  RtbTextSend.SelItalic = False
  RtbTextSend.SelColor = vbBlack
  RtbTextSend.SelFontName = cmbFonts.List(cmbFonts.ListIndex)
  RtbTextSend.SelFontSize = 10

End Sub

The item in question is commented in the above code

Thanks ,

Private[]

Thread: Ritch Text Box Project . a BIG question

Thread Tools

Display

Posting Permissions