ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器,一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理,一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 83138|回复: 165

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

  [复制链接]

TA的精华主题

TA的得分主题

发表于 2009-8-12 17:56 | 显示全部楼层 |阅读模式
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
本帖已被收录到知识树中,索引项:VBE环境开发
一直以来,有许多人打探,问老朽怎么能在论坛发布多彩的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

评分

1

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2009-8-12 17:59 | 显示全部楼层
      '撰写:老朽
      '网址: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

评分

1

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2009-8-12 18:00 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
'转换代码到 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

TA的精华主题

TA的得分主题

 楼主| 发表于 2009-8-12 18:03 | 显示全部楼层
      '撰写:老朽
      '网址: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

TA的精华主题

TA的得分主题

 楼主| 发表于 2009-8-12 18:03 | 显示全部楼层
      '撰写:老朽
      '网址: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

TA的精华主题

TA的得分主题

 楼主| 发表于 2009-8-12 18:05 | 显示全部楼层
      '撰写:老朽
      '网址: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

TA的精华主题

TA的得分主题

 楼主| 发表于 2009-8-12 18:07 | 显示全部楼层
插入一个模块,取名为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

TA的精华主题

TA的得分主题

 楼主| 发表于 2009-8-12 18:08 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
这是工作簿事件代码
      '撰写:老朽
      '网址: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

TA的精华主题

TA的得分主题

 楼主| 发表于 2009-8-12 18:10 | 显示全部楼层
看了这么多代码,大家一定会想要附件,以下是老朽的附件
请享用 我的VBA着色器.rar (29.43 KB, 下载次数: 2833)

TA的精华主题

TA的得分主题

 楼主| 发表于 2009-8-12 18:19 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册

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


您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-12-25 14:04 , Processed in 0.056378 second(s), 9 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表