crtftext.cls

用VB6开发的读写rtf文档的源码,支持插入表格,图片及多字体样式

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cRTFText"
Attribute VB_GlobalNameSpace = True
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"No"
'#########################################################################
'★★★★★         http://www.cnpopsoft.com [华普软件]         ★★★★★
'★★★★★             VB专业论文与源码荟萃                    ★★★★★
'#########################################################################

Option Explicit

'保持属性值的局部变量
Private mvarText As String
Private mvarBold As Boolean
Private mvarItalic As Boolean
Private mvarForeColor As ColorEnum
Private mvarFontSizeFixup As FontSizeEnum
Private mvarFontStyle As FontStyleEnum
Private mvarCharStyle As CharStyleEnum
Private mvarAnimType As AnimTypeEnum
Private mvarScaleX As Long
Private mvarEmbo As EmboEnum
Private mvarExpand As Long
Private mvarOutLine As Boolean
Private mvarShadow As Boolean
Private mvarStrike As Boolean
Private mvarStrikeD As Boolean
Private mvarSubChar As Boolean
Private mvarSuperChar As Boolean
Private mvarUnderLineType As UnderLineTypeEnum
Private mvarUnderLineColor As ColorEnum
Private mvarHided As Boolean
Private mvarWebHidden As Boolean
Private mvarCharBorder As Boolean
Private mvarCharShadow As Long
Private mvarCharPatForeColor As ColorEnum
Private mvarCharPatBackColor As ColorEnum
Private mvarPatType As PatTypeEnum
Private mvarHighlight As Boolean
Private mvarHighlightColor As ColorEnum
Private mvarAlignment As AlignTypeEnum
Private mvarListType As ListTypeEnum
Private mvarIsInTable As Boolean
Private mvarFontName As String              '目前只支持“宋体”和“黑体”
Private mvarSpaceAfter As Long
Private mvarSpaceBefore As Long
Private mvarSpaceLine As Long
Private mvarSpaceFirstLine As Long
Private mvarFontSizeDefault As Long
Private mvarFontSize As Long

Public Property Let FontSize(ByVal vData As Long)
Attribute FontSize.VB_Description = "字体大小。整形值。"
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.FontSize = 5
    mvarFontSize = vData
End Property


Public Property Get FontSize() As Long
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.FontSize
    FontSize = mvarFontSize
End Property




Public Property Let FontSizeDefault(ByVal vData As Long)
Attribute FontSizeDefault.VB_Description = "默认字体尺寸。一般是18。"
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.FontSizeDefault = 5
    mvarFontSizeDefault = vData
End Property


Public Property Get FontSizeDefault() As Long
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.FontSizeDefault
    FontSizeDefault = mvarFontSizeDefault
End Property




Public Property Let SpaceFirstLine(ByVal vData As Long)
Attribute SpaceFirstLine.VB_Description = "首行缩进的字符数。"
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.SpaceFirstLine = 5
    mvarSpaceFirstLine = vData
End Property


Public Property Get SpaceFirstLine() As Long
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.SpaceFirstLine
    SpaceFirstLine = mvarSpaceFirstLine
End Property




Public Property Let SpaceLine(ByVal vData As Long)
Attribute SpaceLine.VB_Description = "行间距。"
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.SpaceLine = 5
    mvarSpaceLine = vData
End Property


Public Property Get SpaceLine() As Long
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.SpaceLine
    SpaceLine = mvarSpaceLine
End Property



Public Property Let SpaceBefore(ByVal vData As Long)
Attribute SpaceBefore.VB_Description = "段后间距。"
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.SpaceBefore = 5
    mvarSpaceBefore = vData
End Property


Public Property Get SpaceBefore() As Long
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.SpaceBefore
    SpaceBefore = mvarSpaceBefore
End Property



Public Property Let SpaceAfter(ByVal vData As Long)
Attribute SpaceAfter.VB_Description = "段前间距。"
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.SpaceAfter = 5
    mvarSpaceAfter = vData
End Property


Public Property Get SpaceAfter() As Long
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.SpaceAfter
    SpaceAfter = mvarSpaceAfter
End Property





Public Property Let FontName(ByVal vData As String)
Attribute FontName.VB_Description = "字体名称。目前只支持宋体和黑体。"
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.FontName = 5
    mvarFontName = vData
End Property


Public Property Get FontName() As String
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.FontName
    FontName = mvarFontName
End Property




Public Property Let IsInTable(ByVal vData As Boolean)
Attribute IsInTable.VB_Description = "是否包含与表格中。默认：False"
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.IsInTable = 5
    mvarIsInTable = vData
End Property


Public Property Get IsInTable() As Boolean
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.IsInTable
    IsInTable = mvarIsInTable
End Property




Public Property Let ListType(ByVal vData As ListTypeEnum)
Attribute ListType.VB_Description = "项目符号类型。1～15。默认：0"
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.ListType = 5
    mvarListType = vData
End Property


Public Property Get ListType() As ListTypeEnum
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.ListType
    ListType = mvarListType
End Property


Public Property Let Alignment(ByVal vData As AlignTypeEnum)
Attribute Alignment.VB_Description = "段落文本对齐方式。1～4，默认：0"
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.Alignment = 5
    mvarAlignment = vData
End Property


Public Property Get Alignment() As AlignTypeEnum
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.Alignment
    Alignment = mvarAlignment
End Property


Public Function GetTextRTF() As String
'获取最终RTF文本
    Dim strR As String
    
    Dim strAlignment As String
    Select Case mvarAlignment
    Case alm2_居中对齐
        strAlignment = "\qc"
    Case alm3_居右对齐
        strAlignment = "\qr"
    Case alm4_两端对齐
        strAlignment = "\qj"
    Case alm5_分散对齐
        strAlignment = "\qd"
    Case Else
        strAlignment = "\ql"
    End Select
    
    Dim strIsInTable As String
    If mvarIsInTable Then strIsInTable = "\intbl"
    
    '默认字体大小及间距处理
    Dim strSB As String, strSA As String, strSL As String, strFL As String
    Dim strFontSize As String
    
    If mvarFontSize <> 0 Then   '字体大小优先权：FontSize > FontSizeFixup > FontSizeDefault
        strFontSize = "\fs" & mvarFontSize * 2
    Else
        If mvarFontSizeFixup <> fs00_默认 Then
            strFontSize = "\fs" & mvarFontSizeFixup * 2
        Else
            If mvarFontSizeDefault <> 0 Then
                strFontSize = "\fs" & mvarFontSizeDefault * 2
            Else
                strFontSize = "\fs18"
            End If
        End If
    End If
    If mvarSpaceBefore <> 0 Then
        strSB = "\sb" & mvarSpaceBefore
    Else    '默认段前间距为0
        If mvarIsInTable Then
            strSB = "\sb0"
        Else
            strSB = "\sb0"
        End If
    End If
    If mvarSpaceAfter <> 0 Then
        strSA = "\sa" & mvarSpaceAfter
    Else    '默认段后间距为0
        If mvarIsInTable Then
            strSA = "\sa0"
        Else
            strSA = "\sa0"
        End If
    End If
    If mvarSpaceLine <> 0 Then
        strSL = "\sl" & mvarSpaceLine & "\slmult0"
    Else    '默认行间距为30
        If mvarIsInTable Then
            strSL = "\sl0\slmult0"
        Else
            strSL = "\sl30\slmult0"
        End If
    End If
    If mvarSpaceFirstLine <> 0 Then
        strFL = "\fi" & mvarSpaceFirstLine * 210
    Else    '默认首行缩进为0
        If mvarIsInTable Then
            strFL = "\fi0"
        Else
            strFL = "\fi0"
        End If
    End If
    
    If ListType <> ltp00_无 Then
        Dim strListString As String
        Select Case ListType
        Case ltp09_符号1
            strListString = "\'6c"
        Case ltp10_符号2
            strListString = "\'6e"
        Case ltp11_符号3
            strListString = "\'75"
        Case ltp12_符号4
            strListString = "\'a8"
        Case ltp13_符号5
            strListString = "\'fc"
        Case ltp14_符号6
            strListString = "\'d8"
        Case ltp15_符号7
            strListString = "\'b2"
        End Select
        
        If ListType <= ltp08_文本8 Then
            strR = "\pard\plain " & strAlignment & strIsInTable & " \fi-420\li3360\ri0\nowidctlpar\jclisttab\tx260\aspalpha\aspnum\faauto\ls1\ilvl" & CStr(mvarListType - 1) & "\adjustright\rin0\lin240\itap0 "
        Else
            strR = "\pard\plain " & strAlignment & strIsInTable & " \li0\ri0\nowidctlpar\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0 " & _
                    "{\listtext\pard\plain\f10\fs18\kerning2 \loch\af10\dbch\af13\hich\f10 " & strListString & " \tab}" & _
                    "\pard\plain " & strAlignment & strIsInTable & " \fi-420\li3360\ri0\nowidctlpar\jclisttab\tx260\aspalpha\aspnum\faauto\ls2\ilvl" & CStr(mvarListType - 9) & "\adjustright\rin0\lin240\itap0"
        End If
    Else
        If mvarFontStyle = ft0_正文 Then
            '处理间距
            
            strR = strR & "\pard\plain " & strAlignment & strIsInTable & strFL & "\li0\ri0" & strSB & strSA & strSL & "\nowidctlpar\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0 \fs18\lang1033\langfe2052\kerning2\loch\af0\hich\af0\dbch\af13\cgrid\langnp1033\langfenp2052 "
        ElseIf mvarFontStyle = ft1_标题1 Then
            strR = strR & "\pard\plain \s1" & strAlignment & strIsInTable & " \li0\ri0\sb340\sa330\sl578\slmult1\keep\keepn\nowidctlpar\aspalpha\aspnum\faauto\outlinelevel0\adjustright\rin0\lin0\itap0 \b\fs44\lang1033\langfe2052\kerning44\loch\af0\hich\af0\dbch\af13\cgrid\langnp1033\langfenp2052 "
        ElseIf mvarFontStyle = ft2_标题2 Then
            strR = strR & "\pard\plain \s2" & strAlignment & strIsInTable & " \li0\ri0\sb260\sa260\sl416\slmult1\keep\keepn\nowidctlpar\aspalpha\aspnum\faauto\outlinelevel1\adjustright\rin0\lin0\itap0 \b\fs32\lang1033\langfe2052\kerning2\loch\af1\hich\af1\dbch\af17\cgrid\langnp1033\langfenp2052 "
        ElseIf mvarFontStyle = ft3_标题3 Then
            strR = strR & "\pard\plain \s3" & strAlignment & strIsInTable & " \li0\ri0\sb260\sa260\sl416\slmult1\keep\keepn\nowidctlpar\aspalpha\aspnum\faauto\outlinelevel2\adjustright\rin0\lin0\itap0 \b\fs32\lang1033\langfe2052\kerning2\loch\af0\hich\af0\dbch\af13\cgrid\langnp1033\langfenp2052 "
        End If
    End If
    
    If mvarFontStyle = ft0_正文 Then
        '字体：\fN，黑体或者宋体
        If mvarFontName = "黑体" Then strR = strR & "\f17"
        
        '字体尺寸
        strR = strR & strFontSize
        
        If mvarBold Then
            strR = strR & "\b"
        Else
            strR = strR & "\b0"
        End If
        If mvarItalic Then
            strR = strR & "\i"
        Else
            strR = strR & "\i0"
        End If
        If mvarForeColor <> clr00_默认 Then
            strR = strR & "\cf" & mvarForeColor
        End If
        If mvarCharStyle = 0 Then
            strR = strR & "\cs10"
        Else
            strR = strR & "\cs" & mvarCharStyle
        End If
        If mvarAnimType <> ani0_无 Then
            strR = strR & "\animtext" & mvarAnimType
        End If
        If mvarScaleX <> 100 Then
            strR = strR & "\charscalex" & mvarScaleX
        End If
        If mvarEmbo = emb1_浮雕效果 Then
            strR = strR & "\embo"
        ElseIf mvarEmbo = emb2_雕刻效果 Then
            strR = strR & "\impr"
        End If
        If mvarExpand <> 0 Then
            strR = strR & "\expnd" & mvarExpand & "\expndtw" & mvarExpand
        End If
        
        If mvarOutLine Then
            strR = strR & "\outl"
        Else
            strR = strR & "\outl0"
        End If
        If mvarShadow Then
            strR = strR & "\shad"
        Else
            strR = strR & "\shad0"
        End If
        If mvarStrike Then
            strR = strR & "\strike"
        Else
            strR = strR & "\strike0"
        End If
        If mvarStrikeD Then
            strR = strR & "\striked1"
        Else
            strR = strR & "\striked0"
        End If
        If mvarSubChar Then strR = strR & "\sub"
        If mvarSuperChar Then strR = strR & "\super"
        
        If mvarUnderLineType <> udl00_无 Then
            Select Case mvarUnderLineType
                Case udl01_连续线:
                    strR = strR & "\ul"
                Case udl02_点线:
                    strR = strR & "\uld"
                Case udl03_短划线:
                    strR = strR & "\uldash"
                Case udl04_点划线:
                    strR = strR & "\uldashd"
                Case udl05_双点划线:
                    strR = strR & "\uldashdd"
                Case udl06_双线:
                    strR = strR & "\uldb"
                Case udl07_加重波浪线:
                    strR = strR & "\ulhwave"
                Case udl08_长划线:
                    strR = strR & "\ulldash"
                Case udl09_粗线:
                    strR = strR & "\ulth"
                Case udl10_粗点线:
                    strR = strR & "\ulthd"
                Case udl11_粗短划线:
                    strR = strR & "\ulthdash"
                Case udl12_粗点划线:
                    strR = strR & "\ulthdashd"
                Case udl13_粗双点划线:
                    strR = strR & "\ulthdashdd"
                Case udl14_粗长划线:
                    strR = strR & "\ulthldash"
                Case udl15_双波浪线:
                    strR = strR & "\ululdbwave"
                Case udl16_字下加线:
                    strR = strR & "\ulw"
                Case udl17_波浪线:
                    strR = strR & "\ulwave"
                Case Else
                    strR = strR & "\ulnone"
            End Select
            If mvarUnderLineColor <> clr00_默认 Then
                strR = strR & "\ulc" & mvarUnderLineColor
            Else
                strR = strR & "\ulc" & mvarUnderLineColor
            End If
        End If
        If mvarHided Then strR = strR & "\v"
        If mvarWebHidden Then strR = strR & "\webhidden"
        If mvarCharBorder Then strR = strR & "\chbrdr"
        If mvarPatType <> ptt00_无 Then
            Select Case mvarPatType
            Case ptt01_横线:
                strR = strR & "\chbghoriz"
            Case ptt02_竖线:
                strR = strR & "\chbgvert"
            Case ptt03_下斜线:
                strR = strR & "\chbgfdiag"
            Case ptt04_上斜线:
                strR = strR & "\chbgbdiag"
            Case ptt05_网格线:
                strR = strR & "\chbgcross"
            Case ptt06_斜网格线:
                strR = strR & "\chbgdcross"
            Case ptt07_粗横线:
                strR = strR & "\chbgdkhoriz"
            Case ptt08_粗竖线:
                strR = strR & "\chbgdkvert"
            Case ptt09_粗下斜线:
                strR = strR & "\chbgdkfdiag"
            Case ptt10_粗上斜线: