printsource.cls

最完美的托盘功能及气泡提示控件最完美的托盘功能及气泡提示控件最完美的托盘功能及气泡提示控件最完美的托盘功能及气泡提示控件

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "PrintSource"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True

Option Explicit
Option Compare Text

' Module Name:  PrintSource.cls
' Author:       Santiago
' email:        [e-mail]
' Date:         23-Abr-01
' Description:  The purpose of this Class module is to print the code in the active code pane window of
'               VB IDE.  The way the code is printed is to determine the amount of lines (selected or
'               total module lines) to print, then sends line by line to printer.

Private Type CodeLine                   'IS USED TO CLASSIFY THE CODE LINE PRINTED
    IsSub As Boolean                    'LINE IS A SUB DECLARATION
    IsFunction As Boolean               'LINE IS A FUNCTION DECLARATION
    IsEnumType As Boolean               'LINE IS A TYPE DEFINITION
    IsEndProc As Boolean                'LINE IS A END SUB/FUNCTION
    IsEndType As Boolean                'LINE IS A END TYPE DEFINITION
    IsComment As Boolean                'LINE IS A COMMENT LINE ('/Rem)
End Type

Private m_PrinterLeft As Single
Private m_PrinterRigth As Single
Private m_PrinterTop As Single
Private m_PrinterBottom As Single
Private m_PrinterHeight As Single
Private m_PrinterWidth As Single


Public Property Let PrinterBottom(ByVal Data As Single)
    m_PrinterBottom = Data
End Property

Public Property Get PrinterBottom() As Single
    PrinterBottom = m_PrinterBottom
End Property

Public Property Let PrinterLeft(ByVal Data As Single)
    m_PrinterLeft = Data
End Property

Public Property Get PrinterLeft() As Single
    PrinterLeft = m_PrinterLeft
End Property

Public Property Let PrinterRigth(ByVal Data As Single)
    m_PrinterRigth = Data
End Property

Public Property Get PrinterRigth() As Single
    PrinterRigth = m_PrinterRigth
End Property

Public Property Let PrinterTop(ByVal Data As Single)
    m_PrinterTop = Data
End Property

Public Property Get PrinterTop() As Single
    PrinterTop = m_PrinterTop
End Property

'*--- Function to Print Entire Module or Selected text from current code pane window
Public Sub PrintSourceCode(PrintSelection As Boolean, PrintIndex As Boolean)
    Dim StartLine&, EndLine&, i&, J&, LineaTexto$, sBuffer$, Indice(), Prop As Property
    Dim DeclarationLines&, a&, b&, c&, d&, sBuffer2$, CodeLineType As CodeLine, PadLeft$
    
    Printer.ScaleMode = vbCentimeters         'CM AS UNIT WHEN SETTING CurrentX, CurrentY IN PRINTER OBJECT
    
    '计算打印区
    m_PrinterHeight = Printer.ScaleHeight - m_PrinterTop
    m_PrinterWidth = Printer.ScaleWidth - m_PrinterLeft - m_PrinterRigth
    PadLeft = String(m_PrinterLeft / Printer.TextWidth(" "), " ")
    
    '字体
    Printer.FontName = "Courier New"
    Printer.FontSize = 9
    
    If PrintSelection Then
        VBI.ActiveCodePane.GetSelection StartLine, J, EndLine, i                'GET RANGE OF LINES SELECTED IN WINDOW
    Else
        StartLine = 1
        EndLine = VBI.ActiveCodePane.CodeModule.CountOfLines                    'COUNT OF LINES IN MODULE
    End If
    DeclarationLines = VBI.ActiveCodePane.CodeModule.CountOfDeclarationLines    'DECLARATIONS AT BEGINNING OF MODULE
    
    PrintHeader True
    
    ReDim Preserve Indice(1, 0)
    For i = StartLine To EndLine
        Printer.FontBold = False
        Printer.FontItalic = False
        
        LineaTexto = VBI.ActiveCodePane.CodeModule.Lines(i, 1)   '获取文字行
        sBuffer = Trim(LineaTexto)
        
        CheckLineWidth LineaTexto
        
        'CHECK IF LINE ENDS WITH LINE-CONTINUATION CHARACTER
        If Right(LineaTexto, 1) = "_" Then
            J = i
            Do
                J = J + 1
                sBuffer = VBI.ActiveCodePane.CodeModule.Lines(J, 1)
                
                CheckLineWidth sBuffer
                LineaTexto = LineaTexto & vbCr & sBuffer
                If Right(sBuffer, 1) <> "_" Then Exit Do
            Loop
            i = J
        End If
        sBuffer = Trim(LineaTexto)
        
        'CHECK IF NEXT LINE FITS ON CURRENT PAGE
        If Printer.CurrentY + Printer.TextHeight(LineaTexto) > m_PrinterHeight Then
            Printer.NewPage
            PrintHeader True
        End If
        
        '打印代码行
        PrintTextLine LineaTexto, CodeLineType
        
        If CodeLineType.IsFunction Or CodeLineType.IsSub Then       'IF SUB/FUNCTION ADD TO INDEX
            ReDim Preserve Indice(1, UBound(Indice, 2) + 1)
            
            J = InStr(sBuffer, "(") - 1
            Indice(0, UBound(Indice, 2)) = Left(sBuffer, J)         'SUB/FUNCTION NAME
            Indice(1, UBound(Indice, 2)) = Printer.Page             'PAGE WHERE IS PRINTED
            
        ElseIf CodeLineType.IsEndProc Then                          'IF END OF PROCEDURE PRINT A LINE
            PrintLine
        End If
        
        If i = DeclarationLines Then PrintLine                      'IF END OF DECLARATIONS SECTION PRINT A LINE
    Next
    
    '打印索引
    If PrintIndex Then
        
        PrintHeaderIndex EndLine - StartLine + 1
        
        '程序数组循环
        For i = 1 To UBound(Indice, 2)
            '在当前页中检查下一行是否适合
            If Printer.CurrentY + Printer.TextHeight(Indice(0, i)) > m_PrinterHeight Then
                PrintHeaderIndex EndLine - StartLine + 1
            End If
            
            'Printer.CurrentX = 1
            Printer.CurrentX = m_PrinterLeft + 1
            Printer.Print Indice(0, i);             '过程/函数 名称
            ImprimirPuntos
            PrintRight Indice(1, i) & Space(3)      '# 页号
        Next
    End If
    
    Printer.EndDoc
    
End Sub

'*--- 检查行宽
Private Sub CheckLineWidth(ByRef LineaTexto As String)
    Dim sBuffer$, a&, b&, c&, d&
    
    If Printer.TextWidth(LineaTexto) > m_PrinterWidth Then
        sBuffer = ""
        
        a = Printer.TextWidth(LineaTexto) \ m_PrinterWidth
        
        c = 1
        For b = 1 To a
            Do
                d = d + 1
            Loop Until Printer.TextWidth(Mid(LineaTexto, c, d - 1)) > m_PrinterWidth
            
            sBuffer = sBuffer & Mid(LineaTexto, c, d - 2) & vbCr
            c = c + d - 2
            d = 0
        Next
        sBuffer = sBuffer & Mid(LineaTexto, c)
        LineaTexto = sBuffer
    End If
End Sub

'*--- 打印索引页眉
Private Sub PrintHeaderIndex(CountLines As Long)
   Dim Prop As Property, sBuffer$
    
    Printer.FontItalic = False
    Printer.NewPage
    PrintHeader False
    
    Printer.CurrentY = m_PrinterTop + 3     '左边空出3厘米
    
    Printer.FontBold = True
    Printer.CurrentX = m_PrinterLeft + 1
    Printer.Print "模块名称:";
    Printer.FontBold = False
    Printer.CurrentX = m_PrinterLeft + 5
    Printer.Print VBI.ActiveCodePane.CodeModule.Parent.Name;                '模块名
    Printer.Print
    Printer.FontBold = True
    Printer.CurrentX = m_PrinterLeft + 1
    Printer.Print "路径:";
    Printer.FontBold = False
    Printer.CurrentX = m_PrinterLeft + 5
    
    sBuffer = VBI.ActiveCodePane.CodeModule.Parent.FileNames(1)             '文件名
    
    CheckLineWidth sBuffer
    PrintText sBuffer, False, True
    
    If CountLines > 0 Then
        Printer.FontBold = True
        Printer.CurrentX = m_PrinterLeft + 1
        Printer.Print "行数:";
        Printer.FontBold = False
        Printer.CurrentX = m_PrinterLeft + 5
        Printer.Print Format(CountLines, "###,##0")
        Printer.Print
    End If
    Printer.Print
    
    On Error Resume Next
    '打印程序的属性，如果是类型或者模块
    If VBI.ActiveCodePane.CodeModule.Parent.Type <= vbext_ct_ClassModule + vbext_ct_ClassModule Then
        For Each Prop In VBI.ActiveCodePane.CodeModule.Parent.Properties
            Printer.CurrentX = m_PrinterLeft + 1
            Printer.Print Prop.Name;        '属性名
            Printer.CurrentX = m_PrinterLeft + 7
            Printer.Print Prop.Value;       '属性值
            Printer.Print
        Next
    End If
    On Error GoTo 0
    
    Printer.Print       '2 个空行
    Printer.Print
    
    Printer.FontBold = True
    Printer.FontUnderline = True
    Printer.CurrentX = m_PrinterLeft + 1
    Printer.Print "程序";
    PrintRight "页 #"
    Printer.Print
    Printer.FontBold = False
    Printer.FontUnderline = False
End Sub

'*--- 打印一行虚线 (索引页)
Private Sub ImprimirPuntos()
    Dim Fin!
    Fin = m_PrinterWidth - 1.5
    
    Printer.Print " ";
    Do
        Printer.Print ".";
    Loop Until Printer.CurrentX >= Fin
    
    Printer.Print " ";
End Sub

'*--- 文字居右
Private Sub PrintRight(Texto As String)
    Printer.CurrentX = m_PrinterWidth - Printer.TextWidth(Texto) + m_PrinterLeft
    Printer.Print Texto
End Sub

'*--- 打印页面，选择打印页码
Private Sub PrintHeader(PrintPageNumber As Boolean)
    Dim sBuffer$, i%
    
    '打印日期、时间、模块名和页码
    
    sBuffer = VBI.ActiveCodePane.CodeModule.Parent.Name
    If PrintPageNumber Then sBuffer = sBuffer & "-" & Printer.Page
    sBuffer = Format(Now, "yyyy-mm-dd HH:mm AM/PM") & Space(10) & sBuffer
    
    With Printer
        .CurrentX = m_PrinterLeft
        .CurrentY = m_PrinterTop
        .FontBold = True
        .FontItalic = True
        PrintRight sBuffer
        
        i = .FontSize
        .FontSize = 2                   '打印双行
        Printer.Line (m_PrinterLeft, .CurrentY)-(m_PrinterWidth + m_PrinterLeft, .CurrentY)
        Printer.Print
        Printer.Line (m_PrinterLeft, .CurrentY)-(m_PrinterWidth + m_PrinterLeft, .CurrentY)
        .FontSize = i \ 2
        Printer.Print
        .FontSize = i
        .FontBold = False
        .FontItalic = False
    End With
End Sub

'*--- 打印进行格式化
Private Sub PrintTextLine(ByVal LineaTexto As String, ByRef RetTypeLine As CodeLine)
    Dim sBuffer$, J%, LineCode As CodeLine
    
    RetTypeLine = LineCode          '复位 RetTypeLine 值
    
    sBuffer = Trim(LineaTexto)
    If Left(sBuffer, 11) = "Private Sub" Or _
        Left(sBuffer, 10) = "Friend Sub" Or _
        Left(sBuffer, 10) = "Static Sub" Or _
        Left(sBuffer, 10) = "Public Sub" Or _
        Left(sBuffer, 3) = "Sub" Then                           'SUB
            RetTypeLine.IsSub = True
    
    ElseIf Left(sBuffer, 16) = "Private Function" Or _
        Left(sBuffer, 15) = "Public Function" Or _
        Left(sBuffer, 15) = "Friend Function" Or _
        Left(sBuffer, 15) = "Static Function" Or _
        Left(sBuffer, 8) = "Function" Then                      '函数
        
            RetTypeLine.IsFunction = True
    
    ElseIf Left(sBuffer, 20) Like "Private Property [LGS]et" Or _
        Left(sBuffer, 19) Like "Public Property [LGS]et" Or _
        Left(sBuffer, 19) Like "Friend Property [LGS]et" Or _
        Left(sBuffer, 16) Like "Property [LGS]et" Then          '属性 GET/LET/SET
        
        RetTypeLine.IsFunction = True
    
    ElseIf Left(sBuffer, 11) = "Public Type" Or _
            Left(sBuffer, 12) = "Private Type" Then             '类型定义
            RetTypeLine.IsEnumType = True
    
    ElseIf Left(sBuffer, 8) = "End Type" Then                   '类型定义结束
            RetTypeLine.IsEndType = True
            
    ElseIf Left(sBuffer, 7) = "End Sub" Or _
            Left(sBuffer, 12) = "End Function" Or _
            Left(sBuffer, 12) = "End Property" Then            '程序定义结束
            RetTypeLine.IsEndProc = True
    
    ElseIf Left(sBuffer, 1) = "'" Or Left(sBuffer, 3) = "Rem" Then      '注释
            RetTypeLine.IsComment = True
    End If
    
    '打印代码行
    
    Printer.ForeColor = QBColor(0)             '黑色
    
    '若包含注释，但是不是整行注释
    If InStr(sBuffer, " '") Or InStr(sBuffer, "Rem ") And Not RetTypeLine.IsComment Then
        J = InStr(LineaTexto, " '")
        If J = 0 Then J = InStr(LineaTexto, "Rem")
        
        sBuffer = Mid(LineaTexto, 1, J - 1)
        
        '仅打印代码（不打印注释）
        Printer.FontItalic = False
        Printer.FontBold = RetTypeLine.IsEndProc Or RetTypeLine.IsEndType Or RetTypeLine.IsEnumType Or _
                            RetTypeLine.IsFunction Or RetTypeLine.IsSub
        PrintText sBuffer, True
        sBuffer = Mid(LineaTexto, J)
        
        '打印注释
        Printer.FontBold = True
        Printer.FontItalic = True
        Printer.ForeColor = QBColor(8)             '灰色
        PrintText sBuffer, False, True
    Else
        '打印整行
        Printer.FontBold = RetTypeLine.IsComment Or RetTypeLine.IsEndProc Or RetTypeLine.IsEndType Or _
                        RetTypeLine.IsEnumType Or RetTypeLine.IsFunction Or RetTypeLine.IsSub
        Printer.FontItalic = RetTypeLine.IsComment
        If RetTypeLine.IsComment Then Printer.ForeColor = QBColor(8)                        'COMMENTS IN GRAY COLOR
        PrintText LineaTexto, False
    End If
End Sub

'*--- 文字线
Private Sub PrintText(ByVal Texto As String, NoBreakLine As Boolean, Optional ContinueLine As Boolean)
    Dim ArrayLines() As String, i%
    
    If Texto = "" Then
        Printer.Print
    Else
        ArrayLines = Split(Texto, vbCr)
        
        If ContinueLine Then
            ContinueLine = False
        Else
            Printer.CurrentX = m_PrinterLeft
        End If
        
        For i = 0 To UBound(ArrayLines) - 1
            Printer.Print ArrayLines(i)
            Printer.CurrentX = m_PrinterLeft
        Next
        If NoBreakLine Then
            Printer.Print ArrayLines(i);
        Else
            Printer.Print ArrayLines(i)
        End If
    End If
End Sub

'*--- 打印线
Private Sub PrintLine()
    Dim X As Single, Y As Single, FSize%
    
    With Printer
        FSize = .FontSize
        .FontSize = FSize \ 2
        .FontSize = FSize
        Printer.Line (m_PrinterLeft, .CurrentY)-(m_PrinterWidth + m_PrinterLeft, .CurrentY)
        .FontSize = FSize \ 2
        Printer.Print
        .FontSize = FSize
    End With
End Sub