crtfdocument.cls

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

'Syntax: Debug.Print X.FontSizeDefault
    FontSizeDefault = mvarFontSizeDefault
End Property



Public Property Let SpaceFirstLine(ByVal vData As Long)
Attribute SpaceFirstLine.VB_Description = "首行缩进字符数。默认为0。"
'向属性指派值时使用，位于赋值语句的左边。
'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 = "行间距。默认为30。如果为负数，则表示精确行间距。"
Attribute SpaceLine.VB_UserMemId = 0
'向属性指派值时使用，位于赋值语句的左边。
'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 SpaceAfter(ByVal vData As Long)
Attribute SpaceAfter.VB_Description = "段后间距。默认为0。如果为负数，则表示精确间距。"
'向属性指派值时使用，位于赋值语句的左边。
'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 SpaceBefore(ByVal vData As Long)
Attribute SpaceBefore.VB_Description = "段前间距。默认为0。如果为负数，则表示精确间距。"
'向属性指派值时使用，位于赋值语句的左边。
'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 PageFooterAlign(ByVal vData As AlignTypeEnum)
Attribute PageFooterAlign.VB_Description = "页脚文本对齐方式。"
'向属性指派对象时使用，位于 Set 语句的左边。
'Syntax: Set x.PageFooterAlign = Form1
    mvarPageFooterAlign = vData
End Property
Public Property Get PageFooterAlign() As AlignTypeEnum
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.PageFooterAlign
    PageFooterAlign = mvarPageFooterAlign
End Property

Public Property Let PageHeadAlign(ByVal vData As AlignTypeEnum)
Attribute PageHeadAlign.VB_Description = "页眉文本对齐方式。"
'向属性指派对象时使用，位于 Set 语句的左边。
'Syntax: Set x.PageHeadAlign = Form1
    mvarPageHeadAlign = vData
End Property
Public Property Get PageHeadAlign() As AlignTypeEnum
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.PageHeadAlign
    PageHeadAlign = mvarPageHeadAlign
End Property

Public Property Let PageNumberAlign(ByVal vData As AlignTypeEnum)
Attribute PageNumberAlign.VB_Description = "页码文本对齐方式。"
'向属性指派对象时使用，位于 Set 语句的左边。
'Syntax: Set x.PageNumberAlign = Form1
    mvarPageNumberAlign = vData
End Property


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



Public Property Let PageNumber(ByVal vData As Boolean)
Attribute PageNumber.VB_Description = "是否显示页码。默认为否。"
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.PageNumber = 5
    mvarPageNumber = vData
End Property


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



Public Property Let PageFooter(ByVal vData As String)
Attribute PageFooter.VB_Description = "页脚文本。"
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.PageFooter = 5
    mvarPageFooter = vData
End Property


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



Public Property Let PageHead(ByVal vData As String)
Attribute PageHead.VB_Description = "页眉文本。"
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.PageHead = 5
    mvarPageHead = vData
End Property


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




Public Function LastTable() As cRTFTable
Attribute LastTable.VB_Description = "获取文档中最后添加的表格对象。"
    Set LastTable = Tables(Tables.Count)
End Function

Public Function LastText() As cRTFText
Attribute LastText.VB_Description = "获取文档中最后添加的文本对象。"
    Set LastText = Texts(Texts.Count)
End Function

Public Function LastPicture() As cRTFPicture
Attribute LastPicture.VB_Description = "获取文档中最后添加的图片对象。"
    Set LastPicture = Pictures(Pictures.Count)
End Function

Public Function LastParagraph() As cRTFParagraph
    Set LastParagraph = Paragraphs(Paragraphs.Count)
End Function

Private Function GetImageSize(sFileName As String) As ImageSizeInf
   On Error Resume Next
   Dim bTemp(3) As Byte, lPos As Long, lFlen As Long
   Open sFileName For Binary As #1
       lFlen = LOF(1)
       Get #1, 1, bTemp()
       
       If bTemp(0) = &H89 And bTemp(1) = &H50 And bTemp(2) = &H4E And bTemp(3) = &H47 Or bTemp(0) = &H42 And bTemp(1) = &H4D Then
'       Debug.Print "\PNG OR BMP\"
           Get #1, 19, bTemp
           GetImageSize.Width = Byte2Long(bTemp(0), bTemp(1))
           Get #1, 23, bTemp
           GetImageSize.Height = Byte2Long(bTemp(0), bTemp(1))
       End If
       
       'JPG
       If bTemp(0) = &HFF And bTemp(1) = &HD8 And bTemp(2) = &HFF Then
'           Debug.Print "\JPEG\"
           lPos = 4
           Do
               Do
                   Get #1, lPos, bTemp
                   lPos = lPos + 1
               Loop Until (bTemp(0) = &HFF And bTemp(1) <> &HFF) Or lPos > lFlen
           
               Get #1, lPos, bTemp
                   
               If bTemp(0) >= &HC0 And bTemp(0) <= &HC3 Then
                   Get #1, lPos + 4, bTemp
                   Exit Do
               Else
                   lPos = lPos + (Byte2Long(bTemp(2), bTemp(1))) + 1
               End If
           Loop While lPos < lFlen
           GetImageSize.Width = Byte2Long(bTemp(3), bTemp(2))
           GetImageSize.Height = Byte2Long(bTemp(1), bTemp(0))
       End If

       'GIF file
       If bTemp(0) = &H47 And bTemp(1) = &H49 And bTemp(2) = &H46 And bTemp(3) = &H38 Then
'           Debug.Print "\GIF\"
           Get #1, 7, bTemp
           GetImageSize.Width = Byte2Long(bTemp(0), bTemp(1))
           GetImageSize.Height = Byte2Long(bTemp(2), bTemp(3))
       End If
           
       'PSD
       If bTemp(0) = &H38 And bTemp(1) = &H42 And bTemp(2) = &H50 And bTemp(3) = &H53 Then
'           Debug.Print "\PSD\"
           Get #1, 17, bTemp
           GetImageSize.Width = Byte2Long(bTemp(1), bTemp(0))
           Get #1, 21, bTemp
           GetImageSize.Height = Byte2Long(bTemp(1), bTemp(0))
       End If
       
       'TIF
       If bTemp(0) = &H4D And bTemp(1) = &H4D And bTemp(2) = &H0 And bTemp(3) = &H2A Then
'           Debug.Print "\TIF1\"
           Get #1, 31, bTemp
           GetImageSize.Width = Byte2Long(bTemp(1), bTemp(0))
           Get #1, 43, bTemp
           GetImageSize.Height = Byte2Long(bTemp(1), bTemp(0))
       End If
       
       If bTemp(0) = &H49 And bTemp(1) = &H49 And bTemp(2) = &H2A And bTemp(3) = &H0 Then
           Get #1, 5, bTemp
           If bTemp(0) = &H8 And bTemp(1) = &H0 And bTemp(2) = &H0 And bTemp(3) = &H0 Then
               'TIF
'               Debug.Print "\TIF2-1\"
               Get #1, 31, bTemp
               GetImageSize.Width = Byte2Long(bTemp(0), bTemp(1))
               Get #1, 43, bTemp
               GetImageSize.Height = Byte2Long(bTemp(0), bTemp(1))
           Else
               'TIF
'               Debug.Print "\TIF2-2\"
               lPos = Byte2Long(bTemp(0), bTemp(1)) + Byte2Long(bTemp(2), bTemp(3)) * 65536 + 11
               Get #1, lPos, bTemp
               GetImageSize.Width = Byte2Long(bTemp(0), bTemp(1))
               Get #1, lPos + 12, bTemp
               GetImageSize.Height = Byte2Long(bTemp(0), bTemp(1))
           End If
       End If

   Close #1
End Function

Private Function Byte2Long(ByVal lsb As Long, ByVal msb As Long) As Long
   Byte2Long = lsb + (msb * 256)
End Function


Public Property Let TextRTF(ByVal vData As String)
Attribute TextRTF.VB_Description = "文档的RTF文本字符串。"
'向属性指派值时使用，位于赋值语句的左边。
    mvarTextRTF = vData
End Property

Public Property Get TextRTF() As String
'检索属性值时使用，位于赋值语句的右边。
    TextRTF = mvarTextRTF
End Property

Public Property Let FileName(ByVal vData As String)
Attribute FileName.VB_Description = "文档目标文件名。"
'向属性指派值时使用，位于赋值语句的左边。
    mvarFileName = vData
End Property

Public Property Get FileName() As String
'检索属性值时使用，位于赋值语句的右边。
    FileName = mvarFileName
End Property

Private Sub Class_Initialize()
'类初始化代码
    '默认模板调入
    mRTFHead = LoadResString(101)
    PageNumber = True
    PageNumberAlign = alm3_居右对齐
    PageHeadAlign = alm2_居中对齐
    PageFooterAlign = alm2_居中对齐
    
    Set Nodes = New cRTFNodes
    Set Texts = New cRTFTexts
    Set Pictures = New cRTFPictures
    Set Tables = New cRTFTables
    Set Paragraphs = New cRTFParagraphs
    
End Sub

Private Sub Class_Terminate()
'必须处理错误事件
    On Error Resume Next
    Set Texts = Nothing
    Set Pictures = Nothing
    Set Texts = Nothing
    Set Paragraphs = Nothing
End Sub

Public Function Save(Optional strFileName As String) As Boolean
Attribute Save.VB_Description = "保存文档为磁盘文件。"
On Error GoTo LL
'组织数据
    If Trim(strFileName) <> "" Then mvarFileName = strFileName
    Dim i As Long, j As Long
    For i = 1 To Nodes.Count
        Select Case Nodes(i).NodeType
        Case "文本"
            '对段落间距与缩进进行处理
            If mvarSpaceAfter <> 0 Then
                If Texts(Nodes(i).SubID).SpaceAfter = 0 Then Texts(Nodes(i).SubID).SpaceAfter = mvarSpaceAfter
            End If
            If mvarSpaceBefore <> 0 Then
                If Texts(Nodes(i).SubID).SpaceBefore = 0 Then Texts(Nodes(i).SubID).SpaceBefore = mvarSpaceBefore
            End If
            If mvarSpaceLine <> 0 Then
                If Texts(Nodes(i).SubID).SpaceLine = 0 Then Texts(Nodes(i).SubID).SpaceLine = mvarSpaceLine
            End If
            If mvarSpaceFirstLine <> 0 Then
                If Texts(Nodes(i).SubID).SpaceFirstLine = 0 Then Texts(Nodes(i).SubID).SpaceFirstLine = mvarSpaceFirstLine
            End If
            If mvarFontSizeDefault <> 0 Then
                If Texts(Nodes(i).SubID).FontSizeDefault = 0 Then Texts(Nodes(i).SubID).FontSizeDefault = mvarFontSizeDefault
            End If
            mRTFBody = mRTFBody & Texts(Nodes(i).SubID).GetTextRTF
        Case "图片"
            mRTFBody = mRTFBody & Pictures(Nodes(i).SubID).GetTextRTF
        Case "表格"
            mRTFBody = mRTFBody & Tables(Nodes(i).SubID).GetTextRTF
        Case "段落"
            '对段落间距与缩进进行处理
            If mvarSpaceAfter <> 0 Then
                If Paragraphs(Nodes(i).SubID).SpaceAfter = 0 Then Paragraphs(Nodes(i).SubID).SpaceAfter = mvarSpaceAfter
            End If
            If mvarSpaceBefore <> 0 Then
                If Paragraphs(Nodes(i).SubID).SpaceBefore = 0 Then Paragraphs(Nodes(i).SubID).SpaceBefore = mvarSpaceBefore
            End If
            If mvarSpaceLine <> 0 Then
                If Paragraphs(Nodes(i).SubID).SpaceLine = 0 Then Paragraphs(Nodes(i).SubID).SpaceLine = mvarSpaceLine
            End If
            If mvarSpaceFirstLine <> 0 Then
                If Paragraphs(Nodes(i).SubID).SpaceFirstLine = 0 Then Paragraphs(Nodes(i).SubID).SpaceFirstLine = mvarSpaceFirstLine
            End If
            If mvarFontSizeDefault <> 0 Then
                If Paragraphs(Nodes(i).SubID).FontSizeDefault = 0 Then Paragraphs(Nodes(i).SubID).FontSizeDefault = mvarFontSizeDefault
            End If
            mRTFBody = mRTFBody & Paragraphs(Nodes(i).SubID).GetTextRTF
        Case Else