-
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
-
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
-
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.
-
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[]
