Die Community zu .NET und Classic VB.
Menü

VB 5/6-Tipp 0706: RTF-formatierten Text in die Zwischenablage kopieren

 von 

Beschreibung 

Dieser Tipp demonstriert, wie man unter einfacher Verwendung des Clipboard-Objektes einen formatierten RTF-Text in die Zwischenablage einfügen kann, sodass dieser anschließend direkt vorformatiert in modernen Textverarbeitungsprogrammen eingefügt werden kann.

Schwierigkeitsgrad:

Schwierigkeitsgrad 1

Verwendete API-Aufrufe:

keine

Download:

Download des Beispielprojektes [3,08 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Projekt1.vbp -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Kontrollkästchen-Steuerelement "ChkBold"
' Steuerelement: Kombinationsliste "CmbFontSize"
' Steuerelement: Kombinationsliste "CmbFontName"
' Steuerelement: Schaltfläche "BtnCopy"
' Steuerelement: Textfeld "Text1"

Option Explicit
'Die verschiedenen ClipBoard Konstanten, die von VB zur
'Verfügung gestellt werden:
'vbCFText = 1
'vbCFBitmap = 2
'vbCFMetafile = 3
'vbCFDIB = 8
'vbCFPalette = 9
'vbCFEMetafile = 14
'vbCFFiles = 15
'vbCFLink = -16640 '(&HFFFFBF00)
'vbCFRTF = -16639 '(&HFFFFBF01)   <<-- wird hier gebraucht

Private Sub Form_Load()
    'Initialisieren der Fontnamen:
    Dim FNArr, fn, i As Long
    
    FNArr = Array("Courier New", _
                  "Arial", _
                  "Times New Roman", _
                  "Tahoma", _
                  "Verdana", _
                  "Wingdings")
    
    For Each fn In FNArr
        CmbFontName.AddItem fn
    Next
    CmbFontName.ListIndex = 1
    
    'Initialisieren der Schriftgrößen:
    For i = 8 To 20
        CmbFontSize.AddItem CStr(i)
    Next
    CmbFontSize.ListIndex = 1
    
    BtnCopy.Caption = "in die Zwischenablage kopieren"
    ChkBold.Caption = "Bold"
    Text1.Text = "Hier kommt der formatierte Text"
    
    Call UpdateTextBoxFont
End Sub

Private Sub BtnCopy_Click()
    If RTFTextToClipboard( _
        New_Font(CmbFontName.Text, _
        CLng(CmbFontSize.Text), _
        ChkBold.Value = vbChecked), _
        Text1.Text) Then
        
        MsgBox "Jetzt können Sie den rtf-formatierten Text in Ihr " & _
            "Textverarbeitungsprogramm einfügen"
    End If
End Sub

Private Sub CmbFontName_Click()
    UpdateTextBoxFont
End Sub

Private Sub CmbFontSize_Click()
    UpdateTextBoxFont
End Sub

Private Sub ChkBold_Click()
    Call UpdateTextBoxFont
End Sub

Private Sub UpdateTextBoxFont()
    If Len(CmbFontName.Text) > 0 And _
        IsNumeric(CmbFontSize.Text) Then
    
        Set Text1.Font = New_Font( _
            CmbFontName.Text, _
            CLng(CmbFontSize.Text), _
            ChkBold.Value = vbChecked)
    End If
End Sub

Public Function New_Font( _
    ByVal FntName As String, _
    ByVal aSize As Long, _
    ByVal bBold As Boolean, _
    Optional ByVal bItalic As Boolean, _
    Optional ByVal bStrikeThr As Boolean, _
    Optional ByVal aCharSet As Long _
    ) As StdFont

    Set New_Font = New StdFont
    With New_Font
        .Name = FntName
        .Size = aSize
        .Bold = bBold
        .Italic = bItalic
        .Strikethrough = bStrikeThr
        .Charset = aCharSet
    End With
End Function

Private Function RTFTextToClipboard( _
    ByVal aFont As StdFont, _
    ByVal aText As String) As Boolean

    On Error Goto CatchE
    Dim s As String
    Dim cp As Long ' Codepage
    Dim lg As Long ' LanguageID
    Dim df As Long ' Nummer der Defaultfont
    
    Dim f As Long
    Dim sz As Long
    
    s = s & "{\rtf1\ansi"
    If cp = 0 Then cp = &H4E4&  '1252
        s = s & "\ansicpg" & CStr(cp)
    
    If df = 0 Then df = 0 'df = 1 ' oder evtl die zweite Schrift als default ?
    
    s = s & "\deff" & CStr(df)
    s = s & "{"
    s = s & GetFontTable(aFont)
    s = s & "}"
    s = s & "\viewkind4"
    s = s & "\uc1"
    s = s & "\pard"
    
    If lg = 0 Then lg = &H407 'SprachenID &H407 = deutsch in Deutschland
    
    s = s & "\lang" & CStr(lg)
    
    If aFont.Bold Then s = s & "\b" 'Fettgedruckt oder nicht
    
    f = 0
    s = s & "\f" & CStr(f)
    
    sz = aFont.Size * 2
    s = s & "\fs" & CStr(sz) '"\fs17"
    s = s & aText 'hier kommt der Text rein
    s = s & "\par}"
    
    Call Clipboard.SetText(s, vbCFRTF)
    RTFTextToClipboard = True
    
CatchE:
    If Err = 0 Then Exit Function
    MsgBox "Fehler in Form1::RTFTextToClipboard"
End Function

Private Function GetFontTable(aFont As StdFont) As String

    Dim s As String
    Dim i As Long 'Nummer der ersten Schrift, hier 0
    
    s = s & "\fonttbl"
    s = s & "{"
    s = s & "\f" & CStr(i)
    s = s & "\fnil"
    s = s & "\fcharset"
    s = s & CStr(aFont.Charset) & " "
    s = s & CStr(aFont.Name) & ";"
    s = s & "}"
    
    GetFontTable = s
End Function


'---------- Ende Formular "Form1" alias Form1.frm  ----------
'-------------- Ende Projektdatei Projekt1.vbp --------------

Tipp-Kompatibilität:

Windows/VB-VersionWin32sWin95Win98WinMEWinNT4Win2000WinXP
VB4
VB5
VB6

Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version:

Windows-Version:

Ihre Meinung  

Falls Sie Fragen zu diesem Artikel haben oder Ihre Erfahrung mit anderen Nutzern austauschen möchten, dann teilen Sie uns diese bitte in einem der unten vorhandenen Themen oder über einen neuen Beitrag mit. Hierzu können sie einfach einen Beitrag in einem zum Thema passenden Forum anlegen, welcher automatisch mit dieser Seite verknüpft wird.

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 1 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.

Kommentar von Gipsy am 22.04.2009 um 18:09

statt

Call Clipboard.SetText(s, vbCFRTF)
einfach
Call Clipboard.SetText(s)
verwenden, dann klappt's ach mit dem Clipboard