论坛 › Office办公软件使用交流 › [源码全公开]让你在论坛发布彩色VBA代码

lnxxnchzyl 发表于 2009-9-15 12:23:15

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

一直以来，有许多人打探，问老朽怎么能在论坛发布多彩的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

lnxxnchzyl 发表于 2009-9-15 12:23:28

'撰写:老朽
      '网址: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

lnxxnchzyl 发表于 2009-9-15 12:23:45

'转换代码到 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

lnxxnchzyl 发表于 2009-9-15 12:24:02

'撰写:老朽
      '网址: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

lnxxnchzyl 发表于 2009-9-15 12:24:23

   '撰写:老朽
      '网址: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

lnxxnchzyl 发表于 2009-9-15 12:24:58

    '撰写:老朽
      '网址: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



当你提问时，要像向1年级的小学生来阐述问题那样尽量详细！如果能让1年级的小学生能明白你的问题，那么你的问题就能更好更快更高更强地得到回复！
UID161933 帖子5881 精华3 经验6312威望3阅读权限95 性别男 在线时间590 小时 查看详细资料

引用 使用道具 报告 回复 TOP


zldccmxhttp://club.excelhome.net/images/common/male_offline.gif 老朽
http://u.excelhome.net/data/avatar/000/16/19/33_avatar_middle.jpg
Excel Home侠圣级
http://club.excelhome.net/images/GreenPark/star_level3.gifhttp://club.excelhome.net/images/GreenPark/star_level2.gifhttp://club.excelhome.net/images/GreenPark/star_level1.gif
积分9257 财富16329 ￥ 技术53来自江西九江 注册时间2006-7-14 总积分排名 37 http://club.excelhome.net/images/common/medal2.gif
[*]发短消息[*]加为好友7楼 大 中 小 发表于 2009-8-12 18:07只看该作者
★2009第4期优秀会员名单揭晓★         ★EH优秀会员奖励计划★


插入一个模块，取名为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


当你提问时，要像向1年级的小学生来阐述问题那样尽量详细！如果能让1年级的小学生能明白你的问题，那么你的问题就能更好更快更高更强地得到回复！
UID161933 帖子5881 精华3 经验6312威望3阅读权限95 性别男 在线时间590 小时 查看详细资料

引用 使用道具 报告 回复 TOP



zldccmxhttp://club.excelhome.net/images/common/male_offline.gif 老朽
http://u.excelhome.net/data/avatar/000/16/19/33_avatar_middle.jpg
Excel Home侠圣级
http://club.excelhome.net/images/GreenPark/star_level3.gifhttp://club.excelhome.net/images/GreenPark/star_level2.gifhttp://club.excelhome.net/images/GreenPark/star_level1.gif
积分9257 财富16329 ￥ 技术53来自江西九江 注册时间2006-7-14 总积分排名 37 http://club.excelhome.net/images/common/medal2.gif
[*]发短消息[*]加为好友8楼 大 中 小 发表于 2009-8-12 18:08只看该作者
★财务、会计、人力资源、行政、生管、销售、市场、学校管理：Excel 行业应用系列视频课程精彩放送中★
http://club.excelhome.net/aa/books/bookad04.jpg

这是工作簿事件代码
      '撰写:老朽
      '网址: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


当你提问时，要像向1年级的小学生来阐述问题那样尽量详细！如果能让1年级的小学生能明白你的问题，那么你的问题就能更好更快更高更强地得到回复！
UID161933 帖子5881 精华3 经验6312威望3阅读权限95 性别男 在线时间590 小时 查看详细资料

引用 使用道具 报告 回复 TOP



zldccmxhttp://club.excelhome.net/images/common/male_offline.gif 老朽
http://u.excelhome.net/data/avatar/000/16/19/33_avatar_middle.jpg
Excel Home侠圣级
http://club.excelhome.net/images/GreenPark/star_level3.gifhttp://club.excelhome.net/images/GreenPark/star_level2.gifhttp://club.excelhome.net/images/GreenPark/star_level1.gif
积分9257 财富16329 ￥ 技术53来自江西九江 注册时间2006-7-14 总积分排名 37 http://club.excelhome.net/images/common/medal2.gif
[*]发短消息[*]加为好友9楼 大 中 小 发表于 2009-8-12 18:10只看该作者
★Excel服务器2008软件和教程下载★
http://club.excelhome.net/aa/books/bookad03.jpg

看了这么多代码，大家一定会想要附件，以下是老朽的附件
请享用 http://club.excelhome.net/images/attachicons/rar.gif 我的VBA着色器.rar (29.43 KB) http://club.excelhome.net/images/attachicons/rar.gif 我的VBA着色器.rar (29.43 KB)
下载次数: 315
2009-8-12 18:10




当你提问时，要像向1年级的小学生来阐述问题那样尽量详细！如果能让1年级的小学生能明白你的问题，那么你的问题就能更好更快更高更强地得到回复！
UID161933 帖子5881 精华3 经验6312威望3阅读权限95 性别男 在线时间590 小时 查看详细资料

引用 使用道具 报告 回复 TOP



zldccmxhttp://club.excelhome.net/images/common/male_offline.gif 老朽
http://u.excelhome.net/data/avatar/000/16/19/33_avatar_middle.jpg
Excel Home侠圣级
http://club.excelhome.net/images/GreenPark/star_level3.gifhttp://club.excelhome.net/images/GreenPark/star_level2.gifhttp://club.excelhome.net/images/GreenPark/star_level1.gif
积分9257 财富16329 ￥ 技术53来自江西九江 注册时间2006-7-14 总积分排名 37 http://club.excelhome.net/images/common/medal2.gif
[*]发短消息[*]加为好友10楼 大 中 小 发表于 2009-8-12 18:19只看该作者
★免费学习Excel VBA实战技巧视频教程★         ★下载《学习Excel VBA与XML、ASP协同应用》电子书★


复制内容到剪贴板 代码:'使用标签HTML来转换VBE源码的颜色
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", "0000FF", "#007F00") & """>" '依次对应了RED"#FF0000",BULE"0000FF",GREEN"#007F00"三色，你只要将这其中的颜色变成自己喜欢的颜色，只需要这样。如果你希望正文颜色为青色，那就将本行中的"0000FF" 替换成 "00FFFF"，共两处
    Msg = Msg & Text
    Msg = Msg & "</SPAN> <SPAN style=""color:" & Choose(BLUE, "#FF0000", "0000FF", "#007F00") & """>"
    HTMLColor = Msg
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

查看完整版本: [源码全公开]让你在论坛发布彩色VBA代码