Adding an image to Rich Text Box in VB6

[tw_scannell]

I spent a stupid amount of time figuring this out. The standard RTF
methods suck.
When I added an image to the Rich Text Box it would also appear in MS
Paint or Paint shop Pro.
That or the controls that I looked at didn't really save as RTF.
anyway here is a vb6 Form in full text format. I am just displaying
the form as text.
Create a new project and add the MS Common Dialog control and the rich
text box to your controls panel.
copy and save the text below as "form2.frm" and add it to a project
then delete form1 and rename this to form1.
It will save images and text to the RTF box and save them to file.

Good luck.
twscannell at the google mail place.

VERSION 5.00
Object = "{3B7C8863-D78F-101B-B9B5-04021C009402}#1.2#0";
"richtx32.ocx"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0";
"COMDLG32.OCX"
Begin VB.Form Form2
Caption = "Rich Text Demo"
ClientHeight = 8430
ClientLeft = 60
ClientTop = 345
ClientWidth = 11190
LinkTopic = "Form1"
ScaleHeight = 8430
ScaleWidth = 11190
StartUpPosition = 3 'Windows Default
Begin MSComDlg.CommonDialog CommonDialog1
Left = 5355
Top = 3975
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin RichTextLib.RichTextBox RTB
Height = 5910
Left = 120
TabIndex = 5
Top = 2130
Width = 10965
_ExtentX = 19341
_ExtentY = 10425
_Version = 393217
ScrollBars = 2
TextRTF = $"Form2.frx":0000
End
Begin VB.CommandButton kmdAddText
Caption = "Add Text"
Height = 420
Left = 0
TabIndex = 4
Top = 0
Width = 1500
End
Begin VB.TextBox TextAdd
Height = 1455
Left = 30
MultiLine = -1 'True
TabIndex = 3
Top = 540
Width = 11610
End
Begin VB.CommandButton kmdSaveText
Caption = "Save RTF File"
Height = 420
Left = 4650
TabIndex = 2
Top = 0
Width = 1500
End
Begin VB.CommandButton kmdOpenFile
Caption = "Open RTF File"
Height = 420
Left = 3105
TabIndex = 1
Top = 0
Width = 1500
End
Begin VB.CommandButton kmdAddGraphic
Caption = "Add Image"
Height = 420
Left = 1545
TabIndex = 0
Top = -15
Width = 1500
End
Begin VB.Image Image1
Height = 780
Left = 7005
Top = 45
Width = 1335
End
End
Attribute VB_Name = "Form2"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'
'
' You can load and save files in 2 different formats; RTF and Plain
Text.
' To load a file use the following syntax:
'
' RichTextBox1.LoadFile filepath, Format
' Where format is either the constant rtfRTF(Rich Text Format) or
rtfText(Plain Text).
'
' RichTextBox1.LoadFile "C:Document1.rtf", rtfRTF
' Loads C:Document1.rtf into RichTextBox1 in RTF
'
' To Save a file use the following syntax:
' RichTextBox1.SaveFile filepath, Format
'
' So
'
' RichTextBox1.SaveFile RichTextBox1.FileName, rtfRTF

Option Explicit

Const WM_CUT = &H300 ' Cut the selected text to the clipboard (Ctrl+X)
Const WM_COPY = &H301 ' Copy the selected text to the clipboard (Ctrl
+C)
Const WM_PASTE = &H302 ' Pastes the text from the clipboard (Ctrl+V)
Const WM_CLEAR = &H303 ' Clears the selected text (Del)
Const WM_UNDO = &H304 ' Undos the last action (Ctrl+Z)

Private Declare Function SendMessage Lib "user32" Alias
"SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam
As Long, lParam As Any) As Long


Public Function fncSaveFile(ByVal FileType As String, ByVal
NewFileName As String, ByVal InitDir As Variant, ByVal DialogCaption
As String) As Variant
On Error GoTo ErrorHandle
CommonDialog1.InitDir = InitDir


' Set CancelError is True
CommonDialog1.CancelError = True ' Set flags

CommonDialog1.Flags = cdlOFNHideReadOnly + cdlOFNOverwritePrompt +
cdlOFNPathMustExist

' Set filters

CommonDialog1.Filter = FileType

' Specify default filter
CommonDialog1.FilterIndex = 0

CommonDialog1.FileName = NewFileName

CommonDialog1.DialogTitle = DialogCaption

' Display the Open dialog box
CommonDialog1.ShowSave


' Display name of selected file
fncSaveFile = CommonDialog1.FileName


'************************ Error Handling Procedure
************************
Exit Function
ErrorHandle:
If Err.Number = 32755 Then
'User pressed the Cancel button
fncSaveFile = "Cancel"
End If 'Err.Number = 32755


End Function


Public Function fncOpenFile(ByVal FileType As String, ByVal
NewFileName As String, ByVal InitDir As Variant, ByVal DialogCaption
As String, Optional ByVal OptionalFlags As Variant) As Variant
On Error GoTo ErrorHandle
' "All Files (*.*)|*.*|Text Files(*.txt)|*.txt|Batch Files (*.bat)|
*.bat"

If IsMissing(InitDir) Then
CommonDialog1.InitDir = CurDir

Else
CommonDialog1.InitDir = InitDir

End If


If Not IsMissing(NewFileName) Then
CommonDialog1.FileName = NewFileName
Else
CommonDialog1.FileName = ""
End If ' Not IsMissing(NewFileName)

' Set CancelError is True
CommonDialog1.CancelError = True ' Set flags

If IsMissing(OptionalFlags) = True Then
CommonDialog1.Flags = cdlOFNNoReadOnlyReturn +
cdlOFNHideReadOnly '+ cdlOFNFileMustExist

Else 'If IsMissing(OptionalFlags) = True
CommonDialog1.Flags = OptionalFlags

End If ' IsMissing(OptionalFlags) = True

' Set filters
'
CommonDialog1.Filter = FileType

' Specify default filter
CommonDialog1.FilterIndex = 2

' CommonDialog1.DialogTitle = "Type or Select File to Open"
' CommonDialog1.DialogTitle = "Select File to Open"
CommonDialog1.DialogTitle = DialogCaption

' Display the Open dialog box
CommonDialog1.ShowOpen

' Display name of selected file
fncOpenFile = CommonDialog1.FileName




'************************ Error Handling Procedure
************************
Exit Function
ErrorHandle:

If Err.Number = 32755 Then
Err.Clear
'User pressed the Cancel button
fncOpenFile = "Cancel"
End If 'Err.Number = 32755


End Function

Private Sub Form_Load()

TextAdd.Text = TextAdd.Text & "This is a bunch of text 1" & vbCrLf
TextAdd.Text = TextAdd.Text & "This is a bunch of text 2" & vbCrLf
TextAdd.Text = TextAdd.Text & "This is a bunch of text 3" & vbCrLf
TextAdd.Text = TextAdd.Text & "This is a bunch of text 4" & vbCrLf &
vbCrLf

End Sub

Private Sub kmdAddGraphic_Click()


Dim MyPath As String


MyPath = fncOpenFile("JPEG Files(*.jpg)|*.jpg|GIF files (*.gif)|
*.gif|Bitmap files (*.bmp)|*.bmp", "", "", "Open the OldReg to
NewReg.txt")

If MyPath = "Cancel" Then Exit Sub

' RTB.OLEObjects.Add , , MyPath

Image1.Picture = LoadPicture(MyPath)
Clipboard.SetData Image1.Picture

SendMessage RTB.hwnd, WM_PASTE, 0, 0
Clipboard.Clear
Image1.Picture = Nothing


End Sub

Private Sub kmdAddText_Click()

Clipboard.Clear
Clipboard.SetText TextAdd.Text
SendMessage RTB.hwnd, WM_PASTE, 0, 0

End Sub


Private Sub kmdOpenFile_Click()

Dim MyPath As String

MyPath = fncOpenFile("(*.rtf)|*.rtf|All files (*.*)|*.*", "OldReg
to NewReg.txt", "", "Open the OldReg to NewReg.txt")
If MyPath = "Cancel" Then Exit Sub

RTB.LoadFile MyPath, rtfRTF

End Sub


Private Sub kmdSaveText_Click()
Dim MyPath As String


MyPath = fncSaveFile("Rich Text file (*.RTF)|*.RTF", "MyNew.RTF",
"", "Save As")
' fncSaveFile("FAST export file (*.txt)|*.txt|All files
(*.*)|*.*", TempFileName, TempPath, "Save As")

If MyPath = "Cancel" Then Exit Sub

RTB.SaveFile MyPath, rtfRTF

End Sub