[源码全公开]让你在论坛发布彩色VBA代码

zldccmx

一直以来，有许多人打探，问老朽怎么能在论坛发布多彩的VBA代码。
老朽一直......舍不得......
今天，老朽将自己改造之后的加载宏奉献给大家 ，与“家人”共享。

先看看不同的代码：

      '撰写:老朽
      '网址:http://Club.ExcelHome.net
      '日期:2009-8-12 下午 05:54:15
Option Explicit
Public Const AppName = "VBA导出至HTML"
Private Const RED As Long = 1
Private Const BLUE As Long = 2
Private Const GREEN As Long = 3
Dim IExp As Object
Public NA_M, Http

'使用标签HTML来转换VBE源码的颜色
      '撰写:老朽
      '网址:http://Club.ExcelHome.net
      '日期:2009-8-12 下午 05:54:15
Private Function HTMLColor(ByVal Color As Long , ByVal Text As String ) As String
    Dim Msg As String
    Msg = Chr(60) & "SPAN style=""color:"
    Msg = Msg & Choose(Color, "#FF0000", "8000FF", "#007F00") & """>"
    Msg = Msg & Text
    Msg = Msg & " "
    HTMLColor = Msg
End Function

      '撰写:老朽
      '网址:http://Club.ExcelHome.net
      '日期:2009-8-12 下午 05:54:15
Private Function IsWordComplete(ByVal Txt, ByVal Compare As String ) As Boolean
    Txt = Application.Substitute(Txt, " ", "")
    Txt = Application.Substitute(Txt, "<", "")
    Txt = Application.Substitute(Txt, ">", "")
    Txt = Application.Substitute(Txt, Chr$(10), "")
    Txt = Application.Substitute(Txt, Chr$(13), "")
    If (Txt Like "*If*" Or Txt Like "*Else" Or Txt Like "*End*" _
        Or Txt Like "*Const*") And Left$(Txt, 1) = "#" Then
        Txt = Right$(Txt, Len(Txt) - 1)
    End If
    If Txt = Compare Then
        IsWordComplete = True
    ElseIf Left$(Txt, Len(Compare)) = Compare Then
        IsWordComplete = Asc(Mid$(Txt, Len(Compare) + 1, 1)) = 32 Or _
                         Asc(Mid$(Txt, Len(Compare) + 1, 1)) = 40 Or _
                         Asc(Mid$(Txt, Len(Compare) + 1, 1)) = 41 Or _
                         Asc(Mid$(Txt, Len(Compare) + 1, 1)) = 44 Or _
                         Asc(Mid$(Txt, Len(Compare) + 1, 1)) = 61
    ElseIf Right$(Txt, Len(Compare)) = Compare Then
        IsWordComplete = Asc(Mid$(Txt, 1, 1)) = 32 Or _
                         Asc(Mid$(Txt, 1, 1)) = 40 Or _
                         Asc(Mid$(Txt, 1, 1)) = 41 Or _
                         Asc(Mid$(Txt, 1, 1)) = 44 Or _
                         Asc(Mid$(Txt, 1, 1)) = 61
    End If
End Function

zldccmx

      '撰写:老朽
      '网址:http://Club.ExcelHome.net
      '日期:2009-8-12 下午 05:56:18
Private Function LineHasComment(ByVal Txt, ByVal Pos As Long ) As Boolean
'是否含注解
    Dim i As Long , NewLinePos As Long , CommentPos As Long
    For i = Pos To 1 Step -1
        If Asc(Mid$(Txt, i, 1)) = Asc(Right$(vbNewLine, 1)) Then
            If NewLinePos = 0 Then NewLinePos = i
        ElseIf Asc(Mid$(Txt, i, 1)) = Asc("'") Then
            If CommentPos = 0 Then CommentPos = i
        End If
    Next i
    LineHasComment = (CommentPos > NewLinePos)
End Function

zldccmx

'转换代码到 HTML
      '撰写:老朽
      '网址:http://Club.ExcelHome.net
      '日期:2009-8-12 下午 06:00:09
Private Sub ConvertCode(ByRef Txt, ByVal Procedure As Boolean )
    Dim Rng As Range , Ar As Variant , i As Long , lStart As Long
    Dim lEnd As Long , Tmp As String , J As Long
    Dim Tmp2 As String , CountCont As Long
    With Sheet1
        Set Rng = .Range("A2").Offset(, Abs(Procedure))
        Set Rng = .Range(Rng, .Range("A65536").Offset(, Abs(Procedure)).End(xlUp))
        Ar = Rng.Value
        Set Rng = Nothing
    End With
    i = 1
    Txt = Application.Substitute(Txt, " _" & vbNewLine, Chr(35) & Chr(35) & Chr(64) & Chr(64) & Chr(37) & Chr(37))
    'Chr(35) & Chr(35) & Chr(64) & Chr(64) & Chr(37) & Chr(37)= "#" & "#" & "@" & "@" & "%" & "%"
    'Chr$(39):注解关键字 '
    'Rem 也是关键字
    '判断是否为注解并将注解标注为绿色
    If InStr(1, Txt, Chr$(39), 1) > 0 Or InStr(1, Txt, "Rem ", 1) > 0 Then
        While i > 0
            If InStr(1, Txt, "Rem ", 1) > 0 Then
                lStart = InStr(i, Txt, "Rem ", 0)
            Else
                lStart = InStr(i, Txt, Chr$(39), 0)
            End If
            If lStart > 0 Then
                If Not IsString(Txt, lStart) Then
                    If InStr(lStart, Txt, vbNewLine, 0) = 0 Then
                        lEnd = Len(Txt)
                    Else
                        lEnd = InStr(lStart, Txt, vbNewLine, 0) - 1
                    End If
                    Tmp = Mid$(Txt, lStart, lEnd - lStart + 1)
                    Txt = Application.Replace(Txt, lStart, Len(Tmp), HTMLColor(GREEN, Tmp))
                    i = InStr(lStart + Len(HTMLColor(GREEN, Tmp)) - Len(Tmp) + 1, Txt, vbNewLine, 0)
                Else
                    i = lStart + 1
                End If
            Else
                i = 0
            End If
        Wend
    End If
    For i = LBound (Ar) To UBound (Ar)   '关键字为蓝色
        On Error GoTo err_h
        If InStr(1, Txt, Ar(i, 1), 1) > 0 Then
            Tmp = CStr (Ar(i, 1))
            lStart = 1
            For J = 1 To (Len(Txt) - Len(Application.Substitute(Txt, Tmp, ""))) / Len(Tmp)
                If lStart > 0 Then lStart = InStr(lStart, Txt, Tmp, 0)
                If lStart > 0 Then
                    If Not LineHasComment(Txt, lStart) And _
                       IsWordComplete(Mid$(Txt, lStart - 1 + Abs(lStart = 1), _
                                      Len(Tmp) + 2 - Abs(lStart = 1)), Tmp) And _
                       Not IsString(Txt, lStart) Then
                        Txt = Application.Substitute(Txt, Tmp, HTMLColor(RED, Tmp), J)
                    End If
                    lStart = InStr(lStart + Len(HTMLColor(RED, Tmp)) - Len(Tmp) + 1, Txt, Tmp, 0)
                End If
            Next J
        End If
    Next i
    Txt = Application.Substitute(Txt, Chr(35) & Chr(35) & Chr(64) & Chr(64) & Chr(37) & Chr(37), " _" & vbNewLine)
    'Chr(35) & Chr(35) & Chr(64) & Chr(64) & Chr(37) & Chr(37)= "#" & "#" & "@" & "@" & "%" & "%"
    Txt = Application.Substitute(Txt, "  ", "  ")
    Txt = Application.Substitute(Txt, vbNewLine, "<" & "br" & ">")
    Exit Sub
err_h:
End Sub

zldccmx

      '撰写:老朽
      '网址:http://Club.ExcelHome.net
      '日期:2009-8-12 下午 06:01:45
Private Sub Convertor(ByRef Txt, Hb As Boolean )
    Dim Lf As Long , Tp As Long , Wd As Long , Ht As Long , i As Long , Falg As Boolean , Flag As Boolean
    Dim Tmp As String , K&, StartLine&, J&, Hr&, Pr, Mt&
    Dim CodeMod As CodeModule, Pane As CodePane
    Dim HrLine()
    On Error GoTo 0
    If Application.VBE.MainWindow.Visible = False Then
        MsgBox "执行本代码必须先开启VBE窗口", vbCritical, AppName
        Exit Sub
    End If
    Set Pane = Application.VBE.ActiveCodePane
    If Err.Number <> 0 Then
        MsgBox "您未勾选信任存取 Visual Basic 专案", vbCritical, AppName
        Exit Sub
    End If
    Set CodeMod = Pane.CodeModule
    '取得每个程序的所在列(日后HTML要插入水平线的列数)
    With CodeMod
        K = 0
        StartLine = .CountOfDeclarationLines + 1    '略过声明区
        Do Until StartLine >= .CountOfLines
            StartLine = StartLine + _
                        .ProcCountLines(.ProcOfLine(StartLine, vbext_pk_Proc), _
                                        vbext_pk_Proc)
            ReDim Preserve HrLine(K)
            HrLine(K) = StartLine
            K = K + 1
        Loop
    End With
    Lf = 1
    Ht = CodeMod.CountOfLines  '全部代码的列数
    '文档名 & 模块名称
    Txt = ""
    ' Verdana 字体
    Txt = Txt & ""
    IExp.document.writeln Txt
    For i = 1 To Ht
        Tmp = CodeMod.Lines(i, 1)
        If Trim(Tmp) <> "" Then
            If Not (Flag Or Left(Trim(Tmp), 1) = "'" Or Len(Trim(Tmp)) = 0) Then
                If Right(Trim(Tmp), 2) = " _" Then Flag = True Else Flag = False
                Select Case Split(Trim(Tmp), " ")(0)
                Case "Sub", "Function"
                    J = 0
                Case "Private", "Public"
                    Select Case Split(Trim(Tmp), " ")(1)
                    Case "Sub", "Function"
                        J = 0
                    End Select
                End Select
                J = J + 1
                If Hb Then Tmp = "                 If J = 1 Then Tmp = "             Else
                If Right(Trim(Tmp), 2) = " _" Then Flag = True Else Flag = False
            End If
            If i <= CodeMod.CountOfDeclarationLines Then
                '处里声明区的程式码
                ConvertCode Tmp, True
                Hr = CodeMod.CountOfDeclarationLines
            Else
                '            处理过程区代码
                ConvertCode Tmp, True
                Pr = CodeMod.ProcOfLine(i, vbext_pk_Proc)
            End If
            If i - 1 = Hr And Hr <> 0 Then
                '插入水平线 <" & "hr" & ">"
                IExp.document.writeln "<" & "hr" & ">"
            End If
            On Error Resume Next
            Mt = Application.WorksheetFunction.Match(i, HrLine(), 0)
            On Error GoTo 0
            If Mt > 0 Then
                IExp.document.writeln "<" & "hr" & ">"
                Mt = 0
            End If
            Txt = Tmp & "<" & "br" & ">"
            IExp.document.writeln Txt
        End If
    Next i
    IExp.document.writeln ""
End Sub

zldccmx

      '撰写:老朽
      '网址:http://Club.ExcelHome.net
      '日期:2009-8-12 下午 06:01:45
Private Function Init() As Boolean
    Dim VBEHwnd As Long
    On Error Resume Next
    VBEHwnd = Application.VBE.MainWindow.Hwnd
    If Err.Number <> 0 Then
        MsgBox "您未勾选信任存取 Visual Basic 应用", vbCritical, AppName
        Init = False
        Exit Function
    End If
    Init = True
End Function
      '撰写:老朽
      '网址:http://Club.ExcelHome.net
      '日期:2009-8-12 下午 06:01:45
Sub CreateHTML()
    Dim Txt, Hb As Boolean
    If MsgBox("是否需要添加行标?", vbYesNo + vbQuestion, "系统提示：") = vbYes Then Hb = True Else Hb = False
        NA_M = "老朽"
        Http = "http://Club.ExcelHome.net"
    On Error GoTo err_h
    If Not Init() Then GoTo err_h
    Set IExp = CreateObject("InternetExplorer.Application")
    Do Until Not IExp.Busy
        DoEvents
    Loop
    IExp.Navigate ("about:blank")
    IExp.Visible = True
    Call Convertor(Txt, Hb)
    MsgBox "创建成功", 64, AppName
err_h:
End Sub

zldccmx

      '撰写:老朽
      '网址:http://Club.ExcelHome.net
      '日期:2009-8-12 下午 06:04:50
Option Explicit
Dim MnuEvt As VBEevt
Dim CmdItem As CommandBarControl
Dim EvtHandlers As New Collection
      '撰写:老朽
      '网址:http://Club.ExcelHome.net
      '日期:2009-8-12 下午 06:04:50
Sub 生成VBE自定义菜单栏()
    On Error Resume Next
    Application.CommandBars(1).Controls("工具(&T)").Controls("宏(&M)").Controls("Visual Basic 编辑器(&V)").Execute
    ' 按 ALT+F11 进入VBE界面。
    移除VBE自定义菜单栏
    Application.VBE.CommandBars("菜单条").Reset
    Set CmdItem = Application.VBE.CommandBars("菜单条").Controls.Add(Type:=msoControlPopup, Before:=12, Temporary:=True)
    With CmdItem
        .Caption = "代码转HTM"
        .OnAction = "CreateHTML"
        .BeginGroup = True
        Set MnuEvt = New VBEevt
        Set MnuEvt.EvtHandler = Application.VBE.Events.CommandBarEvents(CmdItem)
        EvtHandlers.Add MnuEvt
    End With
'    Set CmdItem = Application.VBE.CommandBars("菜单条").Controls.Add(Type:=msoControlPopup, Before:=13, Temporary:=True)
'    With CmdItem
'        .Caption = "代码转Word"
'        .OnAction = "CreateWord"
'        .BeginGroup = True
'        Set MnuEvt = New VBEevt
'        Set MnuEvt.EvtHandler = Application.VBE.Events.CommandBarEvents(CmdItem)
'        EvtHandlers.Add MnuEvt
'    End With
'
'    Set CmdItem = Application.VBE.CommandBars("菜单条").Controls.Add(Type:=msoControlPopup, Before:=14, Temporary:=True)
'    With CmdItem
'        .Caption = "转成EWH(Excel\Word\Html)"
'        .OnAction = "CreateEWH"
'        .BeginGroup = True
'        Set MnuEvt = New VBEevt
'        Set MnuEvt.EvtHandler = Application.VBE.Events.CommandBarEvents(CmdItem)
'        EvtHandlers.Add MnuEvt
'    End With
'        Set CmdItem = Application.VBE.CommandBars("菜单条").Controls.Add(Type:=msoControlPopup, Before:=15, Temporary:=True)
'    With CmdItem
'        .Caption = "解除VBA密码"
'        .OnAction = "Un_vba"
'        .BeginGroup = True
'        Set MnuEvt = New VBEevt
'        Set MnuEvt.EvtHandler = Application.VBE.Events.CommandBarEvents(CmdItem)
'        EvtHandlers.Add MnuEvt
'    End With
    Application.SendKeys "%{F11}"
End Sub
      '撰写:老朽
      '网址:http://Club.ExcelHome.net
      '日期:2009-8-12 下午 06:04:50
Sub 移除VBE自定义菜单栏()
    Dim i
    On Error Resume Next
    For i = 1 To 4 '这里的4 是因为之前老朽添加了4个菜单栏，保留4是想让你自己摸索，如果你添加有N个那就是N了
        Application.VBE.CommandBars("菜单条").Controls(12).Delete
        While EvtHandlers.Count > 0
            EvtHandlers.Remove 1
        Wend
    Next
End Sub

zldccmx

插入一个模块，取名为VBEEVT

      '撰写:老朽
      '网址:http://Club.ExcelHome.net
      '日期:2009-8-12 下午 06:04:26
Public WithEvents EvtHandler As VBIDE.CommandBarEvents

      '撰写:老朽
      '网址:http://Club.ExcelHome.net
      '日期:2009-8-12 下午 06:04:26
Private Sub EvtHandler_Click(ByVal CommandBarControl As Object , handled As Boolean , CancelDefault As Boolean )
    On Error Resume Next
    Application.Run CommandBarControl.OnAction
    handled = True
    CancelDefault = True
End Sub

zldccmx

这是工作簿事件代码
      '撰写:老朽
      '网址:http://Club.ExcelHome.net
      '日期:2009-8-12 下午 06:07:09
Option Explicit

      '撰写:老朽
      '网址:http://Club.ExcelHome.net
      '日期:2009-8-12 下午 06:07:09
Private Sub Workbook_BeforeClose(Cancel As Boolean )
    Call 移除VBE自定义菜单栏
End Sub

      '撰写:老朽
      '网址:http://Club.ExcelHome.net
      '日期:2009-8-12 下午 06:07:09
Private Sub Workbook_Open()
    Call 生成VBE自定义菜单栏
End Sub

zldccmx

看了这么多代码，大家一定会想要附件，以下是老朽的附件
请享用 我的VBA着色器.rar (29.43 KB, 下载次数: 2831)

2009-8-12 18:10 上传

点击文件名下载附件

zldccmx

1. 
   
2. '使用标签HTML来转换VBE源码的颜色
   
3. Private Function HTMLColor(ByVal Color As Long, ByVal Text As String) As String
   
4.     Dim Msg As String
   
5.     Msg = Chr(60) & "SPAN style=""color:"
   
6.     Msg = Msg & Choose(Color, "#FF0000", "0000FF", "#007F00") & """>" '依次对应了RED"#FF0000",  BULE"0000FF",  GREEN"#007F00"三色，你只要将这其中的颜色变成自己喜欢的颜色，只需要这样。如果你希望正文颜色为青色，那就将本行中的"0000FF" 替换成 "00FFFF"，共两处
   
7.     Msg = Msg & Text
   
8.     Msg = Msg & "</SPAN> <SPAN style=""color:" & Choose(BLUE, "#FF0000", "0000FF", "#007F00") & """>"
   
9.     HTMLColor = Msg
   
10. End Function
    

复制代码

      '撰写:老朽
      '网址:http://Club.ExcelHome.net
      '日期:2009-8-12 下午 06:16:14
Option Explicit
Public Const AppName = "VBA导出至HTML"
Private Const RED As Long = 1
Private Const BLUE As Long = 2
Private Const GREEN As Long = 3
Dim IExp As Object
Public NA_M, Http

'使用标签HTML来转换VBE源码的颜色
      '撰写:老朽
      '网址:http://Club.ExcelHome.net
      '日期:2009-8-12 下午 06:16:14
Private Function HTMLColor(ByVal Color As Long , ByVal Text As String ) As String
    Dim Msg As String
    Msg = Chr(60) & "SPAN style=""color:"
    Msg = Msg & Choose(Color, "#FF0000", "00FFFF", "#007F00") & """>"
    Msg = Msg & Text
    Msg =Msg & "</SPAN> <SPAN style=""color:" & Choose(BLUE, "#FF0000", "00ffFF", "#007F00") & """>"
    HTMLColor = Msg
End Function