vbAccelerator - Contents of code file: fSimpleRTFClipboard.frm

VERSION 5.00
Begin VB.Form frmSimpleRTFClipboard 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "Simple RTF Format Clipboard Sample"
   ClientHeight    =   3480
   ClientLeft      =   3510
   ClientTop       =   2055
   ClientWidth     =   5685
   Icon            =   "fSimpleRTFClipboard.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   3480
   ScaleWidth      =   5685
   ShowInTaskbar   =   0   'False
   Begin VB.CommandButton cmdPaste 
      Caption         =   "&Paste"
      BeginProperty Font 
         Name            =   "Tahoma"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   4320
      TabIndex        =   3
      Top             =   960
      Width           =   1275
   End
   Begin VB.CommandButton cmdCopy 
      Caption         =   "&Copy"
      BeginProperty Font 
         Name            =   "Tahoma"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   4320
      TabIndex        =   2
      Top             =   540
      Width           =   1275
   End
   Begin VB.TextBox txtRTF 
      BeginProperty Font 
         Name            =   "Lucida Console"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   2835
      Left            =   60
      MultiLine       =   -1  'True
      ScrollBars      =   2  'Vertical
      TabIndex        =   0
      Text            =   "fSimpleRTFClipboard.frx":014A
      Top             =   540
      Width           =   4155
   End
   Begin VB.Label lblInfo 
      Caption         =   "Visit vbAccelerator for advanced, free VB source
       code at http://vbaccelerator.com"
      BeginProperty Font 
         Name            =   "Tahoma"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   1500
      TabIndex        =   1
      Top             =   60
      Width           =   4155
   End
   Begin VB.Image Image1 
      Height          =   330
      Left            =   60
      Picture         =   "fSimpleRTFClipboard.frx":0150
      Top             =   60
      Width           =   1275
   End
End
Attribute VB_Name = "frmSimpleRTFClipboard"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private m_cClip As New cCustomClipboard
Private m_lID As Long

Private Sub cmdCopy_Click()
On Error GoTo ErrorHandler
   
   ' Open the clipboard:
   If (m_cClip.ClipboardOpen(Me.hWnd)) Then
      ' Put the RTF in there:
      If (m_cClip.SetTextData(m_lID, txtRTF.Text)) Then
         ' Success!
         MsgBox "Put RTF on the clipboard.", vbInformation
      End If
      ' Allow other apps access to the clipboard again:
      m_cClip.ClipboardClose
   End If
   Exit Sub
   
ErrorHandler:
   ' Failed somehow -
   MsgBox "An error occurred: " & Err.Description & " [" & Err.Number & "]",
    vbExclamation
   ' ensure clipboard is closed:
   m_cClip.ClipboardClose
   
End Sub

Private Sub cmdPaste_Click()
On Error GoTo ErrorHandler
   
Dim sRtf As String
   
   ' Open the clipboard:
   If (m_cClip.ClipboardOpen(Me.hWnd)) Then
      ' Check if RTF is available:
      If (m_cClip.IsDataAvailableForFormat(m_lID)) Then
         ' Get the RTF:
         If m_cClip.GetTextData(m_lID, sRtf) Then
            ' Success!
            txtRTF.Text = sRtf
         End If
      Else
         MsgBox "No RTF data on the clipboard.", vbInformation
      End If
      m_cClip.ClipboardClose
   End If
   Exit Sub

ErrorHandler:
   ' Failed somehow -
   MsgBox "An error occurred: " & Err.Description & " [" & Err.Number & "]",
    vbExclamation
   ' ensure clipboard is closed:
   m_cClip.ClipboardClose
   
End Sub

Private Sub Form_Load()
   
   ' Add Rich Text Format.
   ' If another application has already registered this
   ' format, e.g. Word, WordPad, IE etc, then you will
   ' get the ID that is already registered.
   m_lID = m_cClip.AddFormat("Rich Text Format")
   If (m_lID = 0) Then
      ' Exceptional circumstance (API call failed):
      MsgBox "Add RTF Format Failed.", vbExclamation
   End If
   
   ' Load a sample RTF File:
   Dim iFile As Long, sBuf As String
   iFile = FreeFile
   Open App.Path & "\toptips.rtf" For Binary Access Read As #iFile
   sBuf = String$(LOF(iFile), 32)
   Get #iFile, , sBuf
   Close #iFile
   txtRTF.Text = sBuf
   
End Sub