您的位置:新葡亰496net > 新葡亰496net > 新葡亰496netExcel中的图表事件,工作薄及工作表

新葡亰496netExcel中的图表事件,工作薄及工作表

发布时间:2019-08-10 23:05编辑:新葡亰496net浏览(92)

    问题:在平时工作中会遇到,知道其中一个数据,比如姓名,在表格中输入姓名后,想要自动带出网页中该姓名对应的相关数据,比如该姓名的电话,地址等信息,如何做到呢?

    作为世界最优秀的矢量图形设计软件CorelDRAW X3(最新版)居然没有查询图形周长、面积的功能,然而作为矢量图形设计软件,查询图形几何属性是必不可少的,还好有VBA,给了我们扩展 CorelDRAW X3功能的无限空间,以下就是查询矢量图形几何信息的VBA过程。如果你有Corel Designer 12,   可以在里面找到此功能,将其中的窗体,模块,类模块,导出,再到 CorelDRAW X3 VBA中,把它们导过来,运行“宏”就可以在CorelDRAW X3中运行了,如果没有请看下面宏代码编写过程。

    'File下载文件相关函数申明
    Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
    Public Declare Function DeleteUrlCacheEntry Lib "wininet" Alias "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long

         Excel中的许多对象都可以响应事件,这其中包括了Excel程序自身的事件,也包括了我们在Excel中开发VBA应用程序时在对象上所附加的事件处理程序,如按钮的响应事件、单元格被选中的事件、工作表被激活的事件等。大多数的事件处理程序我们都耳熟能详,本文在此重点介绍一下Excel中的图表事件。

    回答:

    1、启动CorelDRAW X3,新建“图形1”,按“Alt F11”打开Visual Basic编辑器,添加如下图所示用户窗体,名称为“frmGeometric”:新葡亰496net 12、为窗体编写VBA代码,窗体代码全部如下:

    列出所有工作薄的 VBA

    Sub 批量下载()
    自动下载导入 (0)
    End Sub

    在Excel中如何快速地创建图表

    Excel抓取并查询网络数据可以使用“获取和转换” “查找引用函数”的功能组合来实现。

    Option Explicit

    由 Mr Colo写的 VBA 需要在VBA内选取 Microfost Visual Basic Applications Extensbility

    Sub 下载导入()
    关闭功能
    自动下载导入 (1)
    开启功能
    End Sub

        虽然Excel可以接受任何类型和格式的数据,但是为了方便创建图表,我们通常都会创建一个相对连续的数据区域,并给定一些有意义的值,好的数据组织将有利于生成更加完美的图表。这里有一个例子,分别对A、B、C、D、E五个栏目按Alpha和Beta两种类别进行统计。

    例:下图是百度百科“奥运会”网页中的一个表格,我们以此为例实现抓取该表格至Excel中,并且能够通过输入第几届来查询对应的举办城市。

    Private CurUnit As Long
    Private Lang As New clsLang
    Private bPerimeter As Boolean
    Private bValidSelection As Boolean
    Private bValidArea As Boolean
    Private vDepth As Double

    请在 Tools - 宏 - 安全性 - 选取 信任存取 Visual Basic 项目

    Sub 自动下载导入(Optional dr)
    If IsMissing(dr) Then dr = 1 '为加了Optional的可选择性省略参数设定值
    '感谢您查看本表源码,本源码和设计模式为本人原创,开源供交流学习, 有疑问可以联系我gzlinwancheng@jd.com 13570972484
    '
    '2016年11月25日 用通过查看会话关闭后失效的Cookie找到库存查询秘钥sso.jd.com设计出查ERP库存表格
    '2016年11月26日 用ERP账号密码Post成功,设计出新的查库存与查订单站点表格给质控客服使用
    '2016年11月28日 成功用Post后的Cookie打开JA表格
    '2016年11月29日 成功用Post后的Cookie下载JA表格,分享
    '2016年12月10日 休息日加班,增加批量导入等制作自动表的代码
    '2016年12月11日 以日报举例,增加时间记录,合并下载和导入两部分代码
    '2016年12月12日 完成WSG库房管家、SRM供应商预约系统Post导入,并调整Post/Get参数到表中设置
    '2016年12月18日 下载地址参数用绝对引用$,以免复制粘贴到不同行时变化,增加说明
    '2016年12月20日 编写Post下载地址获取说明,更改保存路径公式Cell函数增加参数以免选定其他表时地址变化
    '2017年01月22日 增加File下载、手动导入、导入到已有指定列、导入并填充左右相邻公式(无需填充的不要相邻)、
    ' CSV导入使用数据导入并只在第一次自动调整裂开,第二行大于15位的列自动设置文本避免数据丢失
    ' 取消兼容按钮放其他表,界面表名可修改可多账号
    ' 时间提示改进,找不到对应列不导入以防公式表被破坏
    ' 快过年了仍把昨天休息和今晚加班用来写代码,京东价值观与程序员的自我修养哈哈哈
    '2017年02月01日 手动导入增加多文件支持
    '2017年02月08日 csv文件导入时清除原列内容,删除查询定义连接
    '2017年02月28日 实现WMS数据自动抓取
    'by 京东商城广州亚洲一号小件库 仓储质控部 园区质控岗 林万程

    新葡亰496net 2   在Excel中生成图表非常简单,选中上述单元格区域,选择Insert选项卡中Charts部分的图表类型,Excel会自动按照你所选的图表类型为你生成图表,如下图。

    新葡亰496net 3

    Private vLength As Double
    Private vArea As Double

    ' Module
    ' List All VBA module
    Dim x As Long
    Dim aList()

    ssh = ActiveSheet.Name '为了兼容按钮放到其他表中
    

    新葡亰496net 4

    Step1:使用“获取和转换”功能将网络数据抓取至Excel中

    依次点击“数据选项卡”、“新建查询”、“从其他源”、“从Web”。

    新葡亰496net 5

    弹出如下窗口,手动将百度百科“奥运会”的网址复制粘入URL栏,并点击确定。

    新葡亰496net 6

    Excel与网页连接需要一定时间,稍等片刻后会弹出如下窗口,左边列表中的每个Table都代表该网页中的一个表格,挨个点击预览后发现,Table3是我们所需的数据。

    新葡亰496net 7

    点开下方的“加载”旁边的下拉箭头,选择“加载到”。

    新葡亰496net 8

    在弹出的窗口中,在“选择想要在工作薄中查看此数据的方式”下选择“表”,并点击加载。

    新葡亰496net 9

    如图,网页表格中的数据已被抓取至Excel中。

    新葡亰496net 10

    依次点击“表格工具”、“设计”,将“表名称”改为奥运会。

    新葡亰496net 11

    Private WithEvents cPrecision As clsIntSpin

    Sub GetVbProj()
    Dim oVBC As VBIDE.VBComponent
    Dim Wb As Workbook
    x = 2
    For Each Wb In Workbooks
    For Each oVBC In Workbooks(Wb.Name).VBProject.VBComponents
    If Workbooks(Wb.Name).VBProject.Protection = vbext_pp_none Then
    Call GetCodeRoutines(Wb.Name, oVBC.Name)
    End If
    Next
    Next
    With Sheets.Add
    .[A1].Resize(, 3).Value = Array("Workbook", "Module", "Procedure")
    .[A2].Resize(UBound(aList, 2), UBound(aList, 1)).Value = _
    Application.Transpose(aList)
    .Columns("A:C").Columns.AutoFit
    End With
    End Sub

    ' Sheets("界面").Select '为了兼容按钮放到其他表中

         选择Design选项卡,在Chart Layouts部分选择不同的布局,可以丰富图表的内容,如添加图表的名称、设置图例的显示位置等。通过Excel提供的图表功能,我们可以给图表添加许多元素,按照 Excel自带的说明文档上的介绍,一个相对较完整的图表应该包含7个单元。

    Step2:使用“查找与引用”函数实现数据查询

    建立查询区域,包含“届数”和“主办城市”,在届数中随意选取一届输入,下图输入“第08届”,在主办城市下输入vlookup函数,可以得到第08届奥运会的主办城市是巴黎,当更改届数时,对应的主办城市也随之变动。

    公式:=VLOOKUP([届数],奥运会[#全部],4,0)

    新葡亰496net 12

    注意点:若网页中的数据变动较频繁,则可以设置链接网页的数据定时刷新:

    ①将鼠标定位于导入的数据区域中,切换到选项卡,点击下拉箭头→

    新葡亰496net 13

    ②在弹出的对话框中,设置,比如设置为10分钟进行刷新。这样,每隔10分钟数据就会刷新一次,时刻保证获取的数据位最新的。

    新葡亰496net 14


    style="font-weight: bold;">「精进Excel」系头条签约作者,关注我,如果任意点开三篇文章,没有你想要的知识,算我耍流氓!

    回答:

    大家好,我是@Excel实例视频网站长@欢迎私信或者邀请我回答Excel相关问题!


    有人在群里问手机号怎么批量查归属地,第一感觉是百度一下,结果还真没找到好用的,既然如此,我就自己写一个吧!首先找了几个webapi,找到个挺好用的,就用vba写了个自定义函数,测试下感觉还是挺好用,速度也挺快

    新葡亰496net 15

    style="font-weight: bold;">源文件下载链接请私信回复63005即可

    使用方法:

    1.在本表中直接在A1列输入手机号即可

    2.要在其他表中,alt f11打开vbe编辑器,复制模块中代码,在你的新表中建立模块,粘贴代码即可

    3.函数参数说明

    GetPhoneInfo(号码,参数)

    号码—即单个手机号

    参数(1,2,3,4):1-城市,2-省,3-运营商, 4-全部

    代码如下

    Dim ObjXML As Object

    Function GetPhoneInfo(number, Optional para As Byte = 1)

    '获取手机号对应的基本信息 默认为城市

    'para:1-城市,2-省,3-运营商,4,全部

    Dim s As String

    s = GetBody("" & number)

    Select Case para

    Case 1

    GetPhoneInfo = HtmlFilter(s, "City"":""", """")

    Case 2

    GetPhoneInfo = HtmlFilter(s, "Province"":""", """")

    Case 3

    GetPhoneInfo = HtmlFilter(s, "TO"":""", """")

    Case 4

    GetPhoneInfo = HtmlFilter(s, "City"":""", """") & "," & HtmlFilter(s, "Province"":""", """") & "," & HtmlFilter(s, "TO"":""", """")

    End Select

    GetPhoneInfo = Replace(GetPhoneInfo, " ", "")

    End Function

    Private Sub Test()

    Dim i&, j&, k&, arr, brr

    url = ""

    Debug.Print GetBody(url)

    End Sub

    '''如果出现乱码,UTF-8可改为GB2312

    Public Function GetBody(ByVal url$, Optional ByVal Coding$ = "utf-8")

    On Error Resume Next

    Set ObjXML = CreateObject("Microsoft.XMLHTTP")

    With ObjXML

    .Open "Get", url, False, "", ""

    '.setRequestHeader "If-Modified-Since", "0"

    '.setRequestHeader "User-Agent", _

    ".Mozilla/5.0 (Windows NT 6.1; WOW64; rv:47.0) Gecko/20100101 Firefox/47.0"

    .Send

    GetBody = .ResponseBody

    End With

    GetBody = BytesToBstr(GetBody, Coding)

    Set ObjXML = Nothing

    End Function

    Public Function BytesToBstr(strBody, CodeBase)

    Dim ObjStream

    Set ObjStream = CreateObject("Adodb.Stream")

    With ObjStream

    .Type = 1: .Mode = 3: .Open:

    .Write strBody: .Position = 0: .Type = 2: .Charset = CodeBase

    BytesToBstr = .ReadText: .Close

    End With

    Set ObjStream = Nothing

    End Function

    Public Function HtmlFilter(ByVal htmlText$, ByVal Label1$, ByVal label2$)

    '返回html字符串lable1和最近的lable2标签中的数据

    Dim pStart As Long, pStop As Long

    pStart = InStr(htmlText, Label1) Len(Label1)

    If pStart <> 0 Then

    pStop = InStr(pStart, htmlText, label2)

    HtmlFilter = Mid(htmlText, pStart, pStop - pStart)

    End If

    End Function

    回答:

    专业的人做专业事情。

    Private Sub OnUnitChange(ByVal Unit As Long)
        Dim strLength As String
        Dim strArea As String
        Dim strVolume As String
       
        vDepth = Application.ConvertUnits(vDepth, GetAppUnits(CurUnit), GetAppUnits(Unit))
        CurUnit = Unit
        UpdateDepth
       
        strLength = GetCurUnitString()
        lblUnitLength.Caption = strLength
        lblUnitArea.Caption = strLength & GetSquare(False)
        lblUnitDepth.Caption = strLength
        lblUnitVolume.Caption = strLength & GetCube(False)
       
        UpdateValues
    End Sub

    Private Sub GetCodeRoutines(wbk As String, VBComp As String)
    Dim VBCodeMod As CodeModule
    Dim StartLine As Long

    ri = 5
    
     

    1. 图表显示区域。

    2. 数据透视图区域。

    3. 数据透视图中用于显示数据图表的数据点。

    4. 数据透视图中的坐标值。

    5. 图例区域。

    6. 图表的标题。

    7. 用于作为tooltip的数据标签,对数据的解释。

    如果只是偶尔有这个任务,还是在网上出点钱,找人做了。

    花费的钱真的不多。几百元足够了。

    Private Sub UpdateDepth()
        Updating = Updating 1
        txtDepth.Text = CStr(vDepth)
        Updating = Updating - 1
    End Sub

    On Error Resume Next
    Set VBCodeMod = Workbooks(wbk).VBProject.VBComponents(VBComp).CodeModule
    With VBCodeMod
    StartLine = .CountOfDeclarationLines 1
    Do Until StartLine >= .CountOfLines
    ReDim Preserve aList(1 To 3, 1 To x - 1)
    aList(1, x - 1) = wbk
    aList(2, x - 1) = VBComp
    aList(3, x - 1) = .ProcOfLine(StartLine, vbext_pk_Proc)
    x = x 1
    StartLine = StartLine .ProcCountLines(.ProcOfLine(StartLine, _
    vbext_pk_Proc), vbext_pk_Proc)
    If Err Then Exit Sub
    Loop
    End With
    Set VBCodeMod = Nothing
    End Sub

    ' 联网提示 ("http://ssa.jd.com/sso/login")

        按照上述方法创建的图表默认是嵌套在Excel工作表中的,我们也可以创建一个独立的图表在Excel中指定的地方显示。在Design选项卡中找到Location部分,选择Move Chart,弹出的对话框如下图所示,选择New sheet,并定义一个有意义的名称,点击OK,此时Excel会在一个新的sheet中创建图表。这里有一个快速创建图表的方法,选中要创建图表的单元格区域,直接按F11,Excel会按照默认的选项在新的sheet中生成图表。在新 sheet中生成的图表可以在VBA中作为对象来进行访问,同时也可以编写事件处理程序,稍后会介绍。

    如果是平时任务多,且有一定的基础,学习一下未必不可。

    老猫是通过VBA操作的,写一个代码,抓取数据,也很方便。

    老猫正在开发的一款足彩软件程序救市从网上抓取大量数据。然后分析和预测足彩。

    Private Function GetCurUnitString() As String
        Dim strLength As String
        Select Case CurUnit
            Case 0
                strLength = Lang.GetString(eUnitInch)
            Case 1
                strLength = Lang.GetString(eUnitMM)
            Case 2
                strLength = Lang.GetString(eUnitCM)
            Case 3
                strLength = Lang.GetString(eUnitM)
        End Select
        GetCurUnitString = strLength
    End Function

    不可以选择或编辑单元格

    Set http = CreateObject("Msxml2.ServerXMLHTTP")
        '登录
        http.Open "post", "http://ssa.jd.com/sso/login", False
        http.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        Data = "username=" & [B2] & "&password=" & [B3] & "" '【ERP账号密码所在位置】
        http.send (Data)
    
        If InStr(http.responsetext, "登录超时") > 0 Then
            tip = Time & " 登录超时,ERP账号密码错误或未填写。"
            Debug.Print tip
            MsgBox tip
            End
        End If
    
    '下载
    For ri = 5 To [H1048576].End(xlUp).Row
    If Range("B" & ri) <> "" Then '用下载表名判断,不导入的可以不填表名,这样不用去掉网址
        t1 = Time
        '报表下载保存地址
        ph = Range("A" & ri)
        If ph = "" Then ph = ThisWorkbook.path
        fn = ph & "" & Range("B" & ri) & "." & Range("F" & ri)
        If Range("G" & ri) = "File" Then
            lngRetVal = URLDownloadToFile(0, Range("H" & ri), fn, 0, 0)
            If lngRetVal = 0 Then DeleteUrlCacheEntry Range("H" & ri)
        ElseIf Range("G" & ri) = "WMS" Then
            sq = [H1]
            sqt = Range("H" & ri)
            Workbooks.Add
            With ActiveSheet
            With ActiveSheet.ListObjects.Add(SourceType:=0, Source:= _
                "ODBC;DRIVER={MySQL ODBC 5.3 Unicode Driver};" & sq, _
                Destination:=.Range("A1")).QueryTable
                .CommandText = sqt
                .RowNumbers = False
                .FillAdjacentFormulas = False
                .PreserveFormatting = True
                .RefreshOnFileOpen = False
                .BackgroundQuery = True
                .RefreshStyle = xlOverwriteCells '插入模式=覆盖(还有插入行和插入列选择)f
                .SavePassword = True '保存密码
                .SaveData = True
                .AdjustColumnWidth = Ture
                .RefreshPeriod = 0 '刷新频率单位秒,0不自动刷新
                .PreserveColumnInfo = True
                .ListObject.DisplayName = "万程的缩写是WC"
                .Refresh BackgroundQuery:=False
                .Delete '删除查询定义
            End With
            End With
            ActiveWorkbook.SaveAs FileName:=fn, FileFormat:=xlCSV, CreateBackup:=False
            ActiveWindow.Close
        Else
            http.Open Range("G" & ri), Range("H" & ri), False
            http.send ("")
            DoEvents '防止程序假死
    
            Debug.Print attfn(http)
    

    新葡亰496net 16

    这是抓取的比赛列表:

    新葡亰496net 17

    Private Function GetSquare(ByVal bUnicode As Boolean) As String
        Dim s As String
        s = ChrW$(178)
        If Not bUnicode And Asc(s) = 63 Then
            s = "2"
        End If
        GetSquare = s
    End Function

    Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim Myrange As Range, KeepOut As Range
    Dim ws As Worksheet

    ' If InStr(http.responsetext, "not support") > 0 Then
    ' tip = Time & " " & Range("B" & ri) & " 方法错误,请在网页中登录后运行,或更换有权限账号。"
    ' Debug.Print tip
    '' MsgBox tip
    ' Else

    新葡亰496net 18 

    这是VBA程序代码

    新葡亰496net 19

    Private Function GetCube(ByVal bUnicode As Boolean) As String
        Dim s As String
        s = ChrW$(179)
        If Not bUnicode And Asc(s) = 63 Then
            s = "3"
        End If
        GetCube = s
    End Function

    'Full sheet
    'Set KeepOut = ActiveSheet.Cells
    'Several Columns
    'Set KeepOut = ActiveSheet.Range("B:D")
    'Test Range
    Set KeepOut = ActiveSheet.Range("A2:C5")

            Set sGet = CreateObject("ADODB.Stream") '下载文件
                sGet.Mode = 3
                sGet.Type = 1
                sGet.Open
                sGet.Write (http.responseBody)
                sGet.SaveToFile SaveTo & fn, 2
    

    为什么要使用图表事件

    这是抓取的赔率数据

    新葡亰496net 20

    总之,如果想学是不难的。

    回答:

    以EXCEL2003为例来给你说明。

    一、首先打开EXCEL2003,在菜单栏找到“数据”然后在下拉菜单点击“导入外部数据-新建WEB查询”
    新葡亰496net 21
    二、然后在打开的对话框中的地址栏中,将你要导入的网址输入进去,按下转到按钮。
    新葡亰496net 22
    三、在弹开的对话框中原则需要导入的区域,按下导入按钮,这个时候,数据就被导入到EXCEL里面啦!
    新葡亰496net 23最后,你的电脑得链接网络,要不没有数据,这样导入的好处是,可以和网站上保持一致,无需进行手动更新,很方便。

    Private Sub cArea_Click()
        UpdateControls
    End Sub

    Set Myrange = Intersect(Target, KeepOut)
    'Leave if the intersecttion ws untouched
    If Myrange Is Nothing Then Exit Sub

    ' Set sGet = Nothing '清除文件流

        使用图表事件可以更加方便用户使用我们编写的VBA应用程序。例如,我们可以给图表添加一个select事件,当用户点击图表数据透视图中的数据点时,为用户做这样一些事情:

    Private Sub cboUnits_Change()
        OnUnitChange cboUnits.ListIndex
    End Sub

    'Stop select firing a second time
    Application.EnableEvents = False
    If KeepOut.Rows.Count = 65536 And KeepOut.Columns.Count = 256 Then
    'Entire sheet is the KeepOut range. Eek!
    'Bounce user to a dummy sheet
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets("KickMeTo")
    On Error GoTo 0
    If ws Is Nothing Then
    Set ws = ThisWorkbook.Sheets.Add
    ws.Name = "KickMeTo"
    End If
    MsgBox "Houston we have a problem" & vbNewLine & _
    "You cannot select any cell in " & vbNewLine & "'" & KeepOut.Parent.Name & "'" & vbNewLine & _
    "So you have been directed to a different sheet"
    ws.Activate
    ElseIf KeepOut.Rows.Count = 65536 Then
    'If all rows are contained in the "KeepOut" range then:
    'Now we need to find a cell that is in a column to the right or left of this range
    If KeepOut.Cells(1).Column > 1 Then
    'If there is a valid column to the left of the range then select the cell in this column
    Cells(KeepOut.Cells(1).Row, KeepOut.Cells(1).Column - 1).Select
    Else
    'Else select the cell in first column to the right of the range
    Cells(KeepOut.Cells(1).Row, KeepOut.Cells(1).Column 1).Select
    End If
    MsgBox "You cannot select " & KeepOut.Address(False, False) & vbNewLine & _
    "You have been directed to the first free column in the protected range", vbCritical
    ElseIf KeepOut.Rows.Count KeepOut.Cells(1).Row - 1 = 65536 Then
    'Select first cell in Column A before "KeepOut" Range
    Cells(KeepOut.Cells(1).Row - 1, 1).Select
    MsgBox "You cannot select " & KeepOut.Address(False, False) & vbNewLine & _
    "You have been directed to the first free cell in Column A above the protected range", vbCritical
    Else
    'Select first cell in Column A beyond "KeepOut" Range
    MsgBox "You cannot select " & KeepOut.Address(False, False) & vbNewLine & _
    "You have been directed to the first free cell in Column A below the protected range", vbCritical
    Cells(KeepOut.Rows.Count KeepOut.Cells(1).Row, 1).Select
    End If
    Application.EnableEvents = True
    End Sub

    ' End If

    • 显示一个提示信息
    • 提取图表中的信息并放置到工作表中。
    • 激活另外一个图表或工作表。
    • 识别一个数据点进行数据分析。

    Private Sub cLength_Click()
        UpdateControls
    End Sub

    MicroSoft 沒有文件顯示 編碼 的大小限制
    64K 太大,很難跟進

            Application.ScreenUpdating = True '启用屏幕更新
            Range("E" & ri).Select '显示进度
            Application.ScreenUpdating = False '禁用屏幕更新
            If tip = Empty Then
                Range("E" & ri) = Time - t1
            Else
                Range("E" & ri) = tip
            End If
        End If
    
        '导入
        If dr = 1 Then
        If Range("C" & ri) <> "" Then '用导入表名判断,不导入的可以不填表名,这样不用去掉网址
        If Dir(fn, 16) <> Empty Then '路径不存在不运行,这里不加的话kill fn会报错
            s = Range("C" & ri)
            tip = 导入表(fn, s)
            Kill fn '删除文件
    
            Sheets(ssh).Select '打开导入过程选定表会变化,所以重新选定
            Application.ScreenUpdating = True '启用屏幕更新
            Range("E" & ri).Select '显示进度
            Application.ScreenUpdating = False '禁用屏幕更新
            If tip = Empty Then
                Range("E" & ri) = Time - t1
            Else
                Range("E" & ri) = tip
            End If
        End If
        End If
        End If
    End If
    Next
    

        在接下来的内容中,我会向大家介绍Excel中图表对象的一些常用事件的使用方法,并会给出相应的示例。

    Private Sub cmClose_Click()
        Unload Me
    End Sub

    以下編碼檢示 Module 的大小

    ' Sheets(ssh).Select '为了兼容按钮放到其他表中
    End Sub

     

    Private Sub cmCopy_Click()
        Dim sData As String
        Dim oData As New DataObject

    Sub get_Mod_Size()
    Dim myProject As Object
    Dim ComName As String
    Dim tempPath As String
    Dim fs As Object, a As Object
    Dim result As String

    Function decodeURI(szInput)
    Set js = CreateObject("MSScriptControl.ScriptControl")
    js.Language = "JScript"
    decodeURI = js.Eval("decodeURI('" & szInput & "')")
    End Function

    如何添加图表事件

        sData = GetDataString(False)
        If sData <> "" Then
            oData.SetText sData
            oData.PutInClipboard
        End If
    End Sub

    ' **************************************************************************************
    ' Use this to determine the size of a module
    ' Set ModName (component name) and tempPath (where to store the temp fule), then run
    ' **************************************************************************************

    Function attfn(http)
    attfn = Replace(decodeURI(http.getResponseHeader("Content-Disposition")), "attachment;filename=", "")
    End Function

        与其它的VBA控件类似,要想为图表对象添加事件,必须首先进入到Excel的Visual Basic 编辑器。在上图中,右键点击Chart4选项卡(在Excel窗体的下端),选择“View Code”,即可打开 Visual Basic编辑器。或者在“开发工具”选项卡中直接点击Visual Basic按钮。如果是从当前图表所在的标签进入的Visual Basic编辑器,则Visual Basic编辑器窗口中默认打开的是当前图表的Code窗体,在Code窗体的顶部有两个下拉列表,在左边的下拉列表中选择Chart,右边的下拉列表中即显示了Chart对象支持的所有事件名称,默认是Active事件,即Chart被激活时所触发的事件。

    Private Sub cmCreateText_Click()
        Const TextSize As Double = 24 ' 24 pt text
        Dim lr As Layer
        Dim sData As String
        Dim sr As ShapeRange
        Dim x As Double, y As Double, w As Double, h As Double
        sData = GetDataString(True)
        Updating = Updating 1
        If Not ActiveShape Is Nothing And sData <> "" Then
            Set sr = ActiveSelectionRange
            ActiveShape.GetBoundingBox x, y, w, h
            x = x w / 2
            y = y - ActiveDocument.ToUnits(TextSize, cdrPoint)
            Set lr = ActiveShape.Layer
            If lr.Editable Then Set lr = ActiveLayer
            lr.CreateArtisticText x, y, sData, cdrEnglishUS, , "Times New Roman", 24, cdrTrue, cdrTrue, , cdrLeftAlignment
            sr.CreateSelection
        End If
        Updating = Updating - 1
    End Sub

    ' Set these to run
    ComName = "Module1"
    tempPath = "c:Test.bas"

    Function 表存在(s)
    For Each i In Sheets
    If i.Name = s & "" Then 表存在 = 1 '连接空白是避免表格名为数值时格式不同
    ' Debug.Print i.Name = s
    Next
    End Function

    新葡亰496net 24

    Private Sub cmRefresh_Click()
        RefreshForm
    End Sub

    ' ***** No action needed after this point *****

    Function 建表(s)
    For Each i In Sheets
    If i.Name = s Then Exit Function
    Next
    Sheets.Add(, ThisWorkbook.Sheets(Sheets.Count)).Name = s
    ' Sheets.Add.Name = s'创建在前面
    ' Sheets.Add 方法 (Excel):https://msdn.microsoft.com/zh-cn/library/office/ff839847
    End Function

        Chart对象支持以下这些事件:

    Private Sub cmReset_Click()
        vDepth = 0
        UpdateDepth
        UpdateValues
    End Sub

    ' Export the component (module, form, etc) - this is only temporary
    Set myProject = Application.VBE.ActiveVBProject.VBComponents
    myProject(ComName).Export (tempPath)

    Sub 更新WMS秘钥()
    If 进程命令("SmartQueryTwo.exe") <> "" Then
    [H1] = Split(进程命令("SmartQueryTwo.exe"), ",")(5)
    End If
    End Sub

    • Active:当Chart对象被激活时触发。
    • BeforeDoubleClick:鼠标双击前触发。
    • BeforeRightClick:鼠标右键单击前触发。
    • Calculate:使用公式运算时触发。
    • Deactivate:当Chart对象释放激活状态时触发。
    • DragOver:当Chart对象被拖动时触发。
    • DragPlot:当Chart对象中的数据透视图被拖动时触发。
    • MouseDown:鼠标按下时触发。
    • MouseMove:鼠标移动时触发。
    • MouseUp:鼠标按下,然后松开按键时触发。
    • Resize:调整Chart的大小时触发。
    • Select:Chart中的对象被选择时触发。
    • SeriesChange:改变Chart中的图标系列时触发。

    Private Sub cPrecision_Change()
        UpdateValues
    End Sub

    ' Get the size of the file created
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set a = fs.getfile(tempPath)
    result = ComName & " uses " & (a.Size / 1000) & " KB."

    Function 测网(url)
    On Error Resume Next
    cmdping = "ping " & url & " -n 1"
    Set oExec = CreateObject("Wscript.shell").exec(cmdping)
    Do Until oExec.stdout.AtEndOfStream
    strline = strline & oExec.stdout.readline() & Chr(13)
    Loop
    测网 = 0
    If InStr(strline, "回复") Then 测网 = 1
    Set oExec = Nothing
    End Function

        下面我着重介绍几个常用事件的使用方法。

    Private Sub cVolume_Click()
        UpdateControls
    End Sub

    ' Return the file size
    MsgBox result, vbExclamation

    Function 联网提示(url)
    If 测网(url) = 0 Then
    tip = Time & " 请确认是否连接上公司内网。"
    Debug.Print tip
    MsgBox tip
    End
    End If
    End Function

     

     

    ' Delete the exported file
    fs.Deletefile tempPath

    常用图表事件的使用

    Private Sub txtDepth_Change()
        Dim s As String
       
        If Updating Then Exit Sub
       
        s = Trim$(txtDepth.Text)
        If s <> "" Then
            vDepth = Val(Replace(s, ",", "."))
        Else
            vDepth = 0
        End If
        UpdateValues
    End Sub

    End Sub

    1. Activate事件

    Private Sub UserForm_Initialize()
        Updating = 0
        vDepth = 0
       
        Set cPrecision = New clsIntSpin
        cPrecision.Init txtPrecision, spnPrecision, 3, lblPrecision, 0, 5, 1
       
        Me.Caption = Lang.GetString(eFormCaption)
       
        grpLength.Caption = Lang.GetString(eCapPerimeter)
        cLength.Caption = Lang.GetString(eCapPerimeter) & ":"
        bPerimeter = True
       
        grpArea.Caption = Lang.GetString(eCapArea)
        cArea.Caption = Lang.GetString(eCapArea) & ":"
       
        grpVolume.Caption = Lang.GetString(eCapVolume)
        lblDepth.Caption = Lang.GetString(eCapDepth) & ":"
        cmReset.Caption = Lang.GetString(eBtnReset)
        cVolume.Caption = Lang.GetString(eCapVolume) & ":"
       
        cmCreateText.Caption = Lang.GetString(eBtnCreateText)
        cmCopy.Caption = Lang.GetString(eBtnCopy)
        cmClose.Caption = Lang.GetString(eBtnClose)
        cmRefresh.Caption = Lang.GetString(eBtnRefresh)
        lblUnits.Caption = Lang.GetString(eCapUnits) & ":"
        lblPrecision.Caption = Lang.GetString(eCapPrecision) & ":"
      
        cboUnits.Clear
        cboUnits.AddItem Lang.GetString(eStrInch)
        cboUnits.AddItem Lang.GetString(eStrMM)
        cboUnits.AddItem Lang.GetString(eStrCM)
        cboUnits.AddItem Lang.GetString(eStrM)
        cboUnits.ListIndex = IIf(Lang.IsMetric(), 1, 0)
       
        RefreshForm
        MacroRunning = True
    End Sub

    测试 WorkSheet 是否存在

        Activate事件在Chart对象被激活时触发。如果为Chart对象的Activate事件编写了如下代码,则在前面所举的示例中,当我们选择Chart4选项卡时,该事件会被触发。

    Sub RefreshForm()
        Dim nSelCount As Long
       
        bValidSelection = False
        bValidArea = False
       
        Updating = Updating 1
       
        On Error GoTo ErrHandler
       
        If Not ActiveDocument Is Nothing Then
            nSelCount = ActiveDocument.Selection.Shapes.Count
            Select Case nSelCount
                Case 0
                    ShowStatusMessage Lang.GetString(eStrNoSelection)
                   
                Case 1
                    ProcessSelection ActiveShape
                   
                Case Else
                    ShowStatusMessage Lang.GetString(eStrGroupSelected)
            End Select
        Else
            ShowStatusMessage Lang.GetString(eStrNoSelection)
        End If
       
    ExitSub:
        UpdateControls
        Updating = Updating - 1
        Exit Sub
       
    ErrHandler:
        ShowStatusMessage Lang.GetString(eStrError) & ": " & Err.Description
        Resume ExitSub
    End Sub

    Sub IsSheetExist()
    Dim wSheet As Worksheet
    On Error Resume Next
    Set wSheet = Sheets("Sheet6")
    If wSheet Is Nothing Then
    MsgBox "Worksheet does not exist"
    Set wSheet = Nothing
    On Error GoTo 0
    Else
    MsgBox "Sheet does exist"
    Set wSheet = Nothing
    On Error GoTo 0
    End If
    End Sub

    Private Sub Chart_Activate()
        MsgBox "Welcome to my Chart!"
    End Sub

    Private Sub EnableTextControl(ByVal Txt As TextBox, ByVal bState As Boolean)
        Txt.Enabled = bState
        Txt.BackColor = IIf(bState, vbWindowBackground, vbButtonFace)
    End Sub

    新葡亰496net 25

    新葡亰496net 26

    Private Sub UpdateControls()
        Dim bEnabled As Boolean
       
        cLength.Enabled = bValidSelection
        EnableTextControl txtLength, bValidSelection
        lblUnitLength.Enabled = bValidSelection

    让工作表始终置顶

    1. Deactivate事件

        cArea.Enabled = bValidArea
        EnableTextControl txtArea, bValidArea
        lblUnitArea.Enabled = bValidArea
       
        lblDepth.Enabled = bValidArea
        EnableTextControl txtDepth, bValidArea
        lblUnitDepth.Enabled = bValidArea
        cmReset.Enabled = bValidArea
        cVolume.Enabled = bValidArea
        EnableTextControl txtVolume, bValidArea
        lblUnitVolume.Enabled = bValidArea
       
        bEnabled = bValidSelection
        If bEnabled Then
            bEnabled = cLength.Value <> 0
            If bValidArea And Not bEnabled Then
                bEnabled = cArea.Value <> 0 Or cVolume.Value <> 0
            End If
        End If
        cmCreateText.Enabled = bEnabled
        cmCopy.Enabled = bEnabled
    End Sub

    ----------------- Module

        Deactivate事件在Chart对象被释放激活状态时触发。为Chart对象的Deactivate事件编写如下代码,然后释放Chart4选项卡被激活的状态(如选择其它的Sheet选项卡),事件即被触发。

    Private Sub ProcessSelection(ByVal s As Shape)
        If s.Type = cdrGroupShape Then
            ShowStatusMessage Lang.GetString(eStrGroupSelected)
        ElseIf s.IsSimpleShape And s.Type <> cdrTextShape Then
            ProcessCurve s.DisplayCurve
        Else
            ShowStatusMessage Lang.GetString(eStrInvalidObject)
        End If
    End Sub

    Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, y, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Private Const HWND_TOPMOST = -1
    Private Const HWND_NOTOPMOST = -2
    Private Const SWP_NOMOVE = &H2
    Private Const SWP_NOSIZE = &H1
    Private Const TOPMOST_FLAGS = SWP_NOMOVE Or SWP_NOSIZE

    Private Sub Chart_Deactivate()
        msg = "Thanks for viewing the chart."
        MsgBox msg, , ActiveWorkbook.Name
    End Sub

    Private Function CheckSubpaths(ByVal crv As Curve) As Boolean
        Dim bRet As Boolean
        Dim n As Long
        bRet = True
        If crv.SubPaths.Count <> 1 Then
            For n = 2 To crv.SubPaths.Count
                If crv.SubPaths(n).Nodes.Count > 1 Then
                    bRet = False
                    Exit For
                End If
            Next n
        End If
        CheckSubpaths = bRet
    End Function

    Public Sub MakeNormal(hwnd As Long)
    SetWindowPos hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, TOPMOST_FLAGS
    End Sub
    Public Sub MakeTopMost(hwnd As Long)
    SetWindowPos hwnd, HWND_TOPMOST, 0, 0, 0, 0, TOPMOST_FLAGS
    End Sub

    新葡亰496net 27

    Private Sub ProcessCurve(ByVal crv As Curve)
        Dim v As Double
        Dim bClearStatus As Boolean
        Dim bClosed As Boolean
       
        bClosed = crv.SubPaths(1).Closed
        bClearStatus = True
        bValidArea = bClosed And CheckSubpaths(crv)
        If bValidArea Then
            grpLength.Caption = Lang.GetString(eCapPerimeter)
            cLength.Caption = Lang.GetString(eCapPerimeter) & ":"
            bPerimeter = True
        Else
            grpLength.Caption = Lang.GetString(eCapLength)
            cLength.Caption = Lang.GetString(eCapLength) & ":"
            bPerimeter = False
        End If
       
        bValidSelection = True
        vLength = crv.Length
       
        If bValidArea Then
            vArea = calcShapeArea(crv.SubPaths(1))
        Else
            vArea = 0
            If bClosed Then
                ShowStatusMessage Lang.GetString(eStrMultipathCurve)
            Else
                ShowStatusMessage Lang.GetString(eStrCurveOpen)
            End If
            bClearStatus = False
        End If
       
        If bClearStatus Then ClearStatusMessage
        UpdateValues
    End Sub

    Sub test()
    Call MakeTopMost(Application.hwnd)
    Call MakeNormal(Application.hwnd)
    End Sub

    1. Select事件

    Private Sub UpdateValues()
        Dim v As Double
        txtLength.Text = FormatValue(GetLength(vLength))
       
        If bValidArea Then
            v = GetArea(vArea)
            txtArea.Text = FormatValue(v)
            txtVolume.Text = FormatValue(v * vDepth)
        Else
            txtArea.Text = ""
            txtVolume.Text = ""
        End If
    End Sub

    有效性下拉框的高度 显示更多更直观

        使用Select事件可以知道Chart对象的哪一部分被选择了。该事件有三个参数,ElementID 被用来告知Chart对象的哪一部分被选择了,后两个参数Arg1和Arg2则会根据ElementID的不同值传递一些额外的信息,如当Chart对象中的series被选中,则Arg1被用来告知哪一个series被选中了,而Arg2被用来告知被选中的 series中被选中的具体位置。当整个series被选中时,Arg1的值为-1,如果Chart的其它对象被选中,Arg1和Arg2的值为0,此时没有任何附加的信息。下表列出了该事件中三个参数可能的所有值。

    Private Function FormatValue(ByVal v As Double) As String
        Dim sFormat As String
        sFormat = "0"
        If cPrecision.GetValue() > 0 Then
            sFormat = "0." & String$(cPrecision.GetValue(), "0")
        End If
        FormatValue = Format$(v, sFormat)
    End Function

    Option Explicit

    ElementID

    Arg1

    Arg2

    xlChartArea

    None

    None

    xlChartTitle

    None

    None

    xlPlotArea

    None

    None

    xlLegend

    None

    None

    xlFloor

    None

    None

    xlWalls

    None

    None

    xlCorners

    None

    None

    xlDataTable

    None

    None

    xlSeries

    SeriesIndex

    PointIndex

    xlDataLabel

    SeriesIndex

    PointIndex

    xlTrendline

    SeriesIndex

    TrendLineIndex

    xlErrorBars

    SeriesIndex

    None

    xlXErrorBars

    SeriesIndex

    None

    xlYErrorBars

    SeriesIndex

    None

    xlLegendEntry

    SeriesIndex

    None

    xlLegendKey

    SeriesIndex

    None

    xlAxis

    AxisIndex

    AxisType

    xlMajorGridlines

    AxisIndex

    AxisType

    xlMinorGridlines

    AxisIndex

    AxisType

    xlAxisTitle

    AxisIndex

    AxisType

    xlDisplayUnitLabel

    AxisIndex

    AxisType

    xlUpBars

    GroupIndex

    None

    xlDownBars

    GroupIndex

    None

    xlSeriesLines

    GroupIndex

    None

    xlHiLoLines

    GroupIndex

    None

    xlDropLines

    GroupIndex

    None

    xlRadarAxisLabels

    GroupIndex

    None

    xlShape

    ShapeIndex

    None

    xlPivotChartDropZone

    DropZoneType

    None

    xlPivotChartFieldButton

    DropZoneType

    PivotFieldIndex

    xlNothing

    None

    None

    Private Function GetAppUnits(ByVal vUnit As Long) As cdrUnit
        Dim tUnit As cdrUnit
        Select Case CurUnit
            Case 1
                tUnit = cdrMillimeter
            Case 2
                tUnit = cdrCentimeter
            Case 3
                tUnit = cdrMeter
            Case Else
                tUnit = cdrInch
        End Select
        GetAppUnits = tUnit
    End Function

    Dim oDpd As Object
    Dim sFml1
    Dim prvTarget As Range

    Private Sub Chart_Select(ByVal ElementID As Long, ByVal Arg1 As Long, ByVal Arg2 As Long)
        MsgBox "Element: " & ElementID & vbCrLf & "  Arg 1: " & Arg1 _
            & vbCrLf & "  Arg 2: " & Arg2
    End Sub

    Private Function GetLength(ByVal v As Double) As Double
        If ActiveDocument Is Nothing Then
            GetLength = 0
        Else
            GetLength = ActiveDocument.FromUnits(v, GetAppUnits(CurUnit)) * ActiveDocument.WorldScale
        End If
    End Function

    Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    Const dFixedPos As Double = "0.8"
    Const dFixWidth As Double = "16" 'Change here to change WIDTH of the DropDown
    Dim vld As Validation
    Dim lDpdLine As Long

          选择Chart对象中的不同部分,弹出的对话框中会给出相应的信息。注意,当你选择 series时,第一次选中的是整个series对象,此时Arg2的值为-1,再次点击series,选中的是具体的series,此时 Arg2的值为series被选中的point值。下面是经过修改后的事件代码,显示了当Chart对象被选中时的完整信息, Excel定义了很多常量来表示ElementID参数的值。

    Private Function GetArea(ByVal v As Double) As Double
        GetArea = GetLength(GetLength(v))
    End Function

    If Not prvTarget Is Nothing Then
    If Not oDpd Is Nothing Then
    If oDpd.Value = 0 Then
    prvTarget.Value = vbNullString
    Else
    prvTarget.Value = Range(Mid(sFml1, 2)).Item(oDpd.Value)
    End If
    Set prvTarget = Nothing
    End If
    End If

    Private Sub Chart_Select(ByVal ElementID As Long, ByVal Arg1 As Long, ByVal Arg2 As Long)
        Dim sElement As String
        Dim sArg As String
     
        Select Case ElementID
            Case xlChartArea
                sElement = "Chart Area"
            Case xlChartTitle
                sElement = "Chart Title"
            Case xlPlotArea
                sElement = "Plot Area"
            Case xlLegend
                sElement = "Legend"
            Case xlFloor
                sElement = "Floor"
            Case xlWalls
                sElement = "Walls"
            Case xlCorners
                sElement = "Corners"
            Case xlDataTable
                sElement = "Data Table"
            Case xlSeries
                sElement = "Series " & Arg1
                If Arg2 > 0 Then sArg = "Point " & Arg2
            Case xlDataLabel
                sElement = "Data Label"
                sArg = "Series " & Arg1
                If Arg2 > 0 Then sArg = sArg & ", Point " & Arg2
            Case xlTrendline
                sElement = "Trendline"
                sArg = "Series " & Arg1 & ", Trendline " & Arg2
            Case xlErrorBars
                sElement = "Error Bars"
                sArg = "Series " & Arg1
            Case xlXErrorBars
                sElement = "X Error Bars"
                sArg = "Series " & Arg1
            Case xlYErrorBars
                sElement = "Y Error Bars"
                sArg = "Series " & Arg1
            Case xlLegendEntry
                sElement = "Legend Entry"
                sArg = "Series " & Arg1
            Case xlLegendKey
                sElement = "Legend Key"
                sArg = "Series " & Arg1
            Case xlAxis
                sElement = IIf(Arg1 = 1, "Primary ", "Secondary ")
                sElement = sElement & IIf(Arg2 = 1, "Category ", "Value ")
                sElement = sElement & "Axis"
            Case xlMajorGridlines
                sElement = IIf(Arg1 = 1, "Primary ", "Secondary ")
                sElement = sElement & IIf(Arg2 = 1, "Category ", "Value ")
                sElement = sElement & "Major Gridlines"
            Case xlMinorGridlines
                sElement = IIf(Arg1 = 1, "Primary ", "Secondary ")
                sElement = sElement & IIf(Arg2 = 1, "Category ", "Value ")
                sElement = sElement & "Minor Gridlines"
            Case xlAxisTitle
                sElement = IIf(Arg1 = 1, "Primary ", "Secondary ")
                sElement = sElement & IIf(Arg2 = 1, "Category ", "Value ")
                sElement = sElement & "Axis Title"
            Case xlDisplayUnitLabel
                sElement = IIf(Arg1 = 1, "Primary ", "Secondary ")
                sElement = sElement & IIf(Arg2 = 1, "Category ", "Value ")
                sElement = sElement & "Axis Display Unit Label"
            Case xlUpBars
                sElement = "Up Bars"
                sArg = "Group Index " & Arg1
            Case xlDownBars
                sElement = "Down Bars"
                sArg = "Group Index " & Arg1
            Case xlSeriesLines
                sElement = "Series Lines"
                sArg = "Group Index " & Arg1
            Case xlHiLoLines
                sElement = "High-Low Lines"
                sArg = "Group Index " & Arg1
            Case xlDropLines
                sElement = "Drop Lines"
                sArg = "Group Index " & Arg1
            Case xlRadarAxisLabels
                sElement = "Radar Axis Labels"
                sArg = "Group Index " & Arg1
            Case xlShape
                sElement = "Shape"
                sArg = "Shape Number " & Arg1
            Case xlNothing
                sElement = "Nothing"
        End Select
     
        MsgBox sElement & IIf (Len(sArg) > 0, vbCrLf & sArg, "")
    End Sub

    Private Function calcShapeArea(ByVal sp As SubPath) As Double
        Dim cx As New Collection
        Dim cy As New Collection
        Dim seg As Segment
        Dim n As Long
        Dim x As Double, y As Double
        Dim Area As Double
        Dim nPts As Long
       
        sp.StartNode.GetPosition x, y
       
        cx.Add x
        cy.Add y
       
        For Each seg In sp.Segments
            If seg.Type = cdrCurveSegment Then
                For n = 1 To 49
                    seg.GetPointPositionAt x, y, n / 50
                    cx.Add x
                    cy.Add y
                Next n
            End If
            seg.EndNode.GetPosition x, y
            cx.Add x
            cy.Add y
        Next seg
       
        Area = 0
        For n = 1 To cx.Count - 1
            Area = Area cx(n) * cy(n 1) - cy(n) * cx(n 1)
        Next
       
        calcShapeArea = Abs(Area / 2)
    End Function

    On Error Resume Next
    oDpd.Delete
    sFml1 = vbNullString
    Set oDpd = Nothing
    On Error GoTo 0

          另外再给出一个Select事件的应用,读者可以自己验证一下。

    Private Sub ShowStatusMessage(ByVal msg As String)
        lblStatusBar.Caption = msg
    End Sub

    If Target.Count > 1 Then
    Set oDpd = Nothing
    Exit Sub
    End If

    Private Sub Chart_Select(ByVal ElementID As Long, ByVal Arg1 As Long, _
                      ; ;        ByVal Arg2 As Long)
        If ElementID = 3 And Arg2 > 0 Then
            With ActiveChart.SeriesCollection(Arg1).Points(Arg2)
                .ApplyDataLabels Type:=xlShowValue
            End With
         End If
    End Sub

    Private Sub ClearStatusMessage()
        lblStatusBar.Caption = ""
    End Sub

    Set vld = Target.Validation
    On Error GoTo Terminate
    sFml1 = vld.Formula1
    On Error GoTo 0

    1. MouseUp和MouseDown事件

    Private Sub UserForm_Terminate()
        MacroRunning = False
    End Sub

    Set prvTarget = Target

        Select事件在使用的时候有一个缺点,那就是当你重复选择同一个对象时,只有第一次的 Select事件会被触发,而MouseUp事件则是当鼠标按键按下之后在弹起的过程中被响应,它与MouseDown事件的唯一区别就在于事件触发的时间不同,MouseDwon事件是在鼠标按键按下时马上就触发。在有的时候使用MouseUp(或 MouseDown)事件比Select事件更奏效。

    Private Function GetDataString(ByVal bUnicode As Boolean)
        Dim s As String
        s = ""
        If bValidSelection Then
    新葡亰496netExcel中的图表事件,工作薄及工作表。        If cLength.Value Then
                If bPerimeter Then
                    s = Lang.GetString(eCapPerimeter)
                Else
                    s = Lang.GetString(eCapLength)
                End If
                s = s & " = " & txtLength.Text & " " & GetCurUnitString()
            End If
           
            If bValidArea Then
                If cArea.Value Then
                    If s <> "" Then s = s & vbCrLf
                    s = s & Lang.GetString(eCapArea) & " = " & txtArea.Text & " " & GetCurUnitString() & GetSquare(bUnicode)
                End If
               
                If cVolume.Value Then
                    If s <> "" Then s = s & vbCrLf
                    s = s & Lang.GetString(eCapVolume) & " = " & txtVolume.Text & " " & GetCurUnitString() & GetCube(bUnicode)
                End If
            End If
        End If
        GetDataString = s
    End Function

    lDpdLine = Range(Mid(sFml1, 2)).Rows.Count

        先来看看MouseUp事件的参数(MouseDown事件的参数与之相同)。Button参数被用来告知鼠标的哪个按键导致了事件的触发,xlNoButton-无按键,xlPrimaryButton-主按键,xlSecondaryButton-次按键, xlMiddleButton-中间的按键;Shift参数被用来告知当事件被触发时使用了哪些键盘组合键,它有4个基础值,0-没有使用组合键,1-Shift键,2-Ctrl键,4-Alt键,1、2、4三个值任意相加的结果即表示了多种不同的组合键,如 Shift的值为5则表示Shift Alt的组合键;最后两个参数x和y用于表示当事件触发时鼠标所处的坐标值。

    3、添加模块,名称为“Information”,代码如下:

    With Target
    Set oDpd = ActiveSheet.DropDowns.Add( _
    .Left - dFixedPos, _
    .Top - dFixedPos, _
    .Width dFixWidth dFixedPos * 2, _
    .Height dFixedPos * 2)
    End With
    With oDpd
    .ListFillRange = sFml1
    .DropDownLines = lDpdLine
    .Display3DShading = True
    End With
    Terminate:
    End Sub

        一个示例程序用于显示用户点击Chart对象中的series的具体信息。

    Option Explicit

    新葡亰496net 28点击浏览该文件

    Private Sub Chart_MouseUp(ByVal Button As Long, ByVal Shift As Long, ByVal x As Long, ByVal y As Long)
        Dim ElementID As Long, Arg1 As Long, Arg2 As Long
        Dim myX As Variant, myY As Double
     
        With ActiveChart
            ' Pass x & y, return ElementID and Args
            .GetChartElement x, y, ElementID, Arg1, Arg2
     
            ' Did we click over a point or data label?
            If ElementID = xlSeries Or ElementID = xlDataLabel Then
                If Arg2 > 0 Then
                    ' Extract x value from array of x values
                    myX = WorksheetFunction.Index _
                      ; ;   (.SeriesCollection(Arg1).XValues, Arg2)
                    ' Extract y value from array of y values
                    myY = WorksheetFunction.Index _
                      ; ;   (.SeriesCollection(Arg1).Values, Arg2)
     
                    ' Display message box with point information
                    MsgBox "Series " & Arg1 & vbCrLf _
                      ; ;   & """" & .SeriesCollection(Arg1).Name & """" & vbCrLf _
                      ; ;   & "Point " & Arg2 & vbCrLf _
                      ; ;   & "X = " & myX & vbCrLf _
                      ; ;   & "Y = " & myY
                End If
            End If
        End With
    End Sub

    Public MacroRunning As Boolean
    Public Updating As Long

    新葡亰496net 29

        修改此程序可以实现很多在Excel图表中与用户的交互功能,如弹出提示框要求用户反复尝试某种操作,或结合MouseMove事件给出图表的自定义提示信息等。

    Public Sub Dialog()
        EventsEnabled = True
        frmGeoMetric.Show vbModeless
    End Sub

    請問如何不改變activecell之下將某一儲存格顯示於左上角?

        另外还有一种很有用的应用,我们可以通过MouseUp事件来实现图表的详细内容查看功能。即Excel中存在多张主-次关系的图表,当点击主图表中的某项内容时,自动转到相应的次表,在次表中点击Return 区域又回到主表,让用户体验通过选择主表中的不同区域可以查看图表中详细内容的功能。下面是一个示例程序。

    4、添加三个类模块:

    1.

    Private Sub Chart_MouseUp(ByVal Button As Long, ByVal Shift As Long, _
            ByVal x As Long, ByVal y As Long)
     
        Dim ElementID As Long, Arg1 As Long, Arg2 As Long
        Dim myX As Variant
     
        With ActiveChart
            ' Pass x & y, return ElementID and Args
            .GetChartElement x, y, ElementID, Arg1, Arg2
     
            ' Did we click over a point or data label?
            If ElementID = xlSeries Or ElementID = xlDataLabel Then
                If Arg2 > 0 Then
                    ' Extract x value from array of x values
                    myX = WorksheetFunction.Index _
                      ; ;   (.SeriesCollection(Arg1).XValues, Arg2)
     
                    ' Don't crash if chart doesn't exist
                    On Error Resume Next
                    ' Activate the appropriate chart
                    ThisWorkbook.Charts("Chart " & myX).Select
                    On Error GoTo 0
                End If
            End If
        End With
    End Sub

      (1)名称为clsIntSpin,代码如下:

    ActiveWindow.SmallScroll Up:=65536 ActiveWindow.SmallScroll ToLeft:=256 用上面的方法先回到 A1 再用下面的方法到定點 ActiveWindow.SmallScroll Down:=儲存格列號 - 1 ActiveWindow.SmallScroll ToRight:=儲存格欄號 - 1

        其中myX变量保存了当前主表中被选中的series的值,然后通过ThisWorkbook.Charts ("Chart " & myX).Select方法在整个Excel工作簿中查找名称与之相对应的Chart对象,并选中它。你完全可以自己编写名称匹配的算法,然后自动选中要查看的图表,或者采用ThisWorkbook,Sheets().Select方法选中要查看的工作表等等。

    Option Explicit

    2.

        其它图表事件读者可以自己去尝试,它们在实际应用中使用得不是很多,而且相对来说使用都比较简单,这里我就不再一一给出例子了。下面重点说一下在Excel中如何使用内嵌的图表事件。

    Public Event Change()

    ActiveCell.Select ActiveWindow.ScrollRow = ActiveCell.Row ActiveWindow.ScrollColumn = ActiveCell.Column

     

    '================= Private Data =================
    Private WithEvents cTxt As TextBox
    Private WithEvents cSpin As SpinButton
    Private Updating As Long
    Private Value As Long
    Private lLabel As Label
    Private Digits As Long

    3.

    Excel中的内嵌图表事件

    '================= Interface ================
    Public Sub Init(Txt As TextBox, Spin As SpinButton, ByVal v As Long, Optional CtlLabel As Label, Optional ByVal nMin As Long = 0, Optional ByVal nMax As Long = 2147483647, Optional ByVal nStep As Long = 1, Optional ByVal NumDigits As Long)
        If v < nMin Then v = nMin
        If v > nMax Then v = nMax
        Value = v
        Set cTxt = Txt
        Set cSpin = Spin
        Set lLabel = CtlLabel
        BeginUpdate
        If NumDigits > 0 Then
            Digits = NumDigits
        Else
            Digits = 1
        End If
       
        cTxt.Value = FormatValue(Value)
        With cSpin
            .Min = nMin
            .Max = nMax
            .SmallChange = nStep
            .Value = Value
        End With
       
        EndUpdate
    End Sub

    Application.Goto ActiveCell, True

        其实不单单指图表对象的内嵌事件,与单纯的VB语言一样,Excel中的VBA也是支持事件内嵌应用的,它支持所有VBA对象的内嵌事件编程。

    Public Function OnTextExit() As Boolean
        Dim n As Long
        OnTextExit = False
        If Updating = 0 Then
            n = GetTextValue()
            BeginUpdate
            If cSpin.Value <> n Then
                cSpin.Value = n
                Value = n
                OnTextExit = True
                RaiseEvent Change
            Else
                cTxt.Value = FormatValue(n)
            End If
            EndUpdate
        End If
    End Function

    新葡亰496net 30

        什么是事件的内嵌?举个简单的例子来说明这一点。在VBA应用中,我们为工程里所有需要的对象一一编写事件处理程序,例如按钮的单击事件、下拉列表的选择事件,以及图表控件的激活、选择、鼠标单击事件等,但是在很多情况下,这些对象的事件处理程序完成的都是同一件工作,特别是在图表控件的MouseUp事件中,当事件触发时我们只想给用户一个包含详细内容的提示信息,这样的话如果给工程里所有的图表对象都添加一样的事件处理程序就显得有些过于繁琐了,而且更新和维护代码不方便。有没有一个简单的办法来实现这一功能呢?内嵌事件可以实现这一点。

    Public Sub SetValue(ByVal nVal As Long)
        BeginUpdate
        With cSpin
            If nVal < .Min Then nVal = .Min
            If nVal > .Max Then nVal = .Max
            .Value = nVal
        End With
        Value = nVal
        cTxt.Value = FormatValue(nVal)
        EndUpdate
    End Sub

    Save Sheet as WorkBook

        Excel的VB编辑器中列出了已有的对象目录,包括Chart对象、Sheet对象、ThisWorkbook等,如果含有Moudle,则会包含Moudle对象,这些对象在VBE(Visual Basic Editor)的工程资源管理器窗体中被列出来,该窗体在VBE的右侧,如果没有显示,可以通过“视图-工程资源管理器”菜单来显示它。在对象的属性窗口中可以修改对象的名称,属性窗体默认在工程资源管理器窗体的下方,可以通过“视图-属性窗口 ”菜单来显示它。双击对象名称可以打开代码窗体并给该对象编写相应的代码。这些操作与VB 6的IDE编辑器类似,如果读者对VB很熟悉的话,这一部分对你来说应该不会陌生。除此之外,我们还可以通过“插入 ”菜单在工程中加入用户窗体、模块和类模块。使用类模块来定义全局对象,从而实现内嵌事件。

    Public Function GetValue() As Long
        GetValue = Value
    End Function

    Sub SaveShtsAsBook()
    Dim Sheet As Worksheet, SheetName$, MyFilePath$, N&
    MyFilePath$ = ActiveWorkbook.Path & "" & _
    Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
    With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
    ' End With
    On Error Resume Next '<< a folder exists
    MkDir MyFilePath '<< create a folder
    For N = 1 To Sheets.Count
    Sheets(N).Activate
    SheetName = ActiveSheet.Name
    Cells.Copy
    Workbooks.Add (xlWBATWorksheet)
    With ActiveWorkbook
    With .ActiveSheet
    .Paste
    .Name = SheetName
    [A1].Select
    End With
    'save book in this folder
    .SaveAs Filename:=MyFilePath _
    & "" & SheetName & ".xls"
    .Close SaveChanges:=True
    End With
    .CutCopyMode = False
    Next
    End With
    Sheet1.Activate
    End Sub

    新葡亰496net 31

    Public Sub Enable(ByVal bState As Boolean)
        If Not lLabel Is Nothing Then lLabel.Enabled = bState
        cTxt.Locked = Not bState
        cTxt.TabStop = bState
        cTxt.BackColor = IIf(bState, vbWindowBackground, vbButtonFace)
        cTxt.ForeColor = IIf(bState, vbWindowText, vbButtonShadow)
        cSpin.Enabled = bState
    End Sub

        先介绍一下Option Explicit语句。

    Public Sub SetMaxRange(ByVal nVal)
        BeginUpdate
        If Value > nVal Then
            Value = nVal
            cSpin.Value = nVal
            cTxt.Value = FormatValue(nVal)
        End If
        cSpin.Max = nVal
        EndUpdate
    End Sub

    Sub BreakExternalLinks()

        VBA是一种脚本语言,与其它许多的脚本语言类似(如常见的javascript语言),它是一种解释性的语言,在执行前不需要进行编译,而且变量或对象在使用前不必严格进行类型定义,这是一种弱类型的语言。然而一种好的编程习惯是要求变量或对象在使用前是经过类型确认的,这样在今后的代码维护中也会方便一些,其他人在阅读你的代码时也会显得思路清晰。VBA默认不要求严格定义变量或对象,但是我们可以通过Option Explicit语句来改变这一点,在模块或类模块代码的第一行写上这行语句,则以后的代码必须遵循变量或对象先定义后使用的规则。可以通过在VBE中选择“工具-选项”,勾选“要求变量声明”来让Excel自动为你加上这行代码。

    Public Sub SetMinRange(ByVal nVal)
        BeginUpdate
        If Value < nVal Then
            Value = nVal
            cSpin.Value = nVal
            cTxt.Value = FormatValue(nVal)
        End If
        cSpin.Min = nVal
        EndUpdate
    End Sub

    Dim WS As Worksheet
    Dim Rng1 As Range
    Dim Cell As Range

    '================ Helper Functions ==============
    Private Sub BeginUpdate()
        Updating = Updating 1
    End Sub

    For Each WS In ActiveWorkbook.Worksheets
    With WS
    On Error Resume Next
    Set Rng1 = Cells.SpecialCells(xlCellTypeFormulas, 23)

    新葡亰496net 32

    Private Sub EndUpdate()
        Updating = Updating - 1
    End Sub

    ' 23 - All formulae
    ' 16 - All formulae with errors
    ' 2 - All formulae with text
    ' 4 - All formulae with logic
    ' 6 - All formulae with text or logic

         我们要求的内嵌事件程序都在Option Explicit语句之后编写代码,这样可以避免对象过多时混淆定义,减少编程时不必要的错误。

    Private Function GetTextValue() As Long
        Dim v As Double
        v = 0
        If Trim$(cTxt.Text) <> "" Then v = Val(cTxt.Text)
        If v < CDbl(cSpin.Min) Then v = cSpin.Min
        If v > CDbl(cSpin.Max) Then v = cSpin.Max
        GetTextValue = CLng(v)
    End Function

    On Error GoTo 0
    If Not Rng1 Is Nothing Then
    For Each Cell In Rng1
    If Left(Cell.Formula, 2) = "='" Then
    Cell.Value = Cell.Value
    End If
    Next
    End If
    Set Rng1 = Nothing
    End With
    Next

         接下来开始编写内嵌事件处理程序。

    Private Function FormatValue(ByVal v As Long) As String
        Dim s As String
        Dim bNegative As Boolean
       
        bNegative = v < 0
        s = Trim$(str$(Abs(v)))
        If Len(s) < Digits Then
            s = Right$(String$(Digits, "0") & s, Digits)
        End If
       
        If bNegative Then s = "-" & s
        FormatValue = s
    End Function

    End Sub

    1. 在工程中添加新的类模块,取名为CEventChart,编写如下代码。

    Private Sub Class_Initialize()
        Value = 0
    End Sub

    新葡亰496net 33

    Option Explicit
     
    ' Declare object of type "Chart" with events
    Public WithEvents EvtChart As Chart
     
    Private Sub EvtChart_Select (ByVal ElementID As Long, _
            ByVal Arg1 As Long, ByVal Arg2 As Long)
     
        MsgBox "Element: " & ElementID & vbCrLf & "  Arg 1: " & Arg1 _
            & vbCrLf & "  Arg 2: " & Arg2
     
    End Sub

    Private Sub cSpin_Change()
        If Updating = 0 Then
            BeginUpdate
            cTxt.Value = FormatValue(cSpin.Value)
            Value = cSpin.Value
            RaiseEvent Change
            EndUpdate
        End If
    End Sub

    使用期限設定

    1. 在模块1中添加下面的代码,或者新建一个模块加入下面的代码。

    Private Sub cTxt_Change()
        Dim n As Long
        If Updating = 0 Then
            n = GetTextValue()
            If cSpin.Value <> n Then
                BeginUpdate
                cSpin.Value = n
                Value = n
                EndUpdate
                RaiseEvent Change
            End If
        End If
    End Sub

    ' chijanzen
    (原始) 2003/10/1
    ' 今天介紹如何讓Excel檔案有使用期限,範例中使用Windows Script"在註冊表上的讀.寫.刪除的用法
    ' 本範例使用期限設定 0 天,所以檔案只能開啟一次就自動銷毀
    ' Script 能使用的根鍵值有五個根鍵名稱
    HKEY_CURRENT_USER '縮寫 HKCU
    HKEY_LOCAL_MACHINE '縮寫 HKLM
    HKEY_CLASSES_ROOT '縮寫 HKCR
    HKEY_USERS '縮寫 HKEY_USERS
    HKEY_CURRENT_CONFIG '縮寫 HKEY_CURRENT_CONFIG

    Option Explicit

     

    Sub CheckFileDate()
    Dim Counter As Long, LastOpen As String, Msg As String
    If RegRead = "" Then
    Term = 0 '範例用 0 天
    TermDate = DateSerial(Year(Now), Month(Now), Day(Now)) Term
    MsgBox "本檔案只能使用到" & TermDate & "日" & Chr(13) & "超過期限將自動銷毀"
    RegWrite (Term)
    Else
    If CDate(RegRead) <= Now Then
    RegDelete
    KillMe
    End If
    End If
    End Sub
    Sub KillMe()
    Application.DisplayAlerts = False
    ActiveWorkbook.ChangeFileAccess xlReadOnly
    Kill ActiveWorkbook.FullName
    ThisWorkbook.Close False
    End Sub

    Dim clsEventChart As New CEventChart
    Dim clsEventCharts()  As New CEventChart

      (2)名称为clsLang,代码如下:

    Sub RegWrite(Term)
    'RegWrite:建立新鍵、將另一個值名稱加入現有鍵 (並將值指派給它),或變更現有值名稱的值。
    Dim WshShell, bKey
    fname = ThisWorkbook.Name
    TermDate = DateSerial(Year(Now), Month(Now), Day(Now)) Term
    Regkey = "HKCUchijanzenBudgetDate" & fname
    Set WshShell = CreateObject("WScript.Shell")
    WshShell.RegWrite Regkey, TermDate, "REG_SZ"
    End Sub

    Sub Set_All_Charts()
        ' Enable events for active sheet if sheet is a&n bsp;chart sheet
        If TypeName(ActiveSheet) = "Chart" Then
            Set clsEventChart.EvtChart = ActiveSheet
        End If

    Option Explicit

    Function RegRead()
    'RegRead: 從註冊傳回鍵的值或值名稱
    On Error Resume Next
    Dim WshShell, bKey
    fname = ThisWorkbook.Name
    Regkey = "HKCUchijanzenBudgetDate" & fname
    Set WshShell = CreateObject("WScript.Shell")
    RegRead = WshShell.RegRead(Regkey)
    End Function

        ' Enable events for all charts embedded on a she et
        ' Works for embedded charts on a worksheet or ch art sheet
        If ActiveSheet.ChartObjects.Count > 0 Then
            ReDim clsEventCharts(1 To ActiveSheet.ChartObjects.Count)
            Dim chtObj As ChartObject
            Dim chtnum As Integer

    Private colDict As New Collection
    Private bMetric As Boolean

    Sub RegDelete()
    'RegDelete :從註冊刪除某鍵或它的一個值(請小心使用)
    Dim WshShell, bKey
    Regkey = "HKCUchijanzenBudgetDate"
    Set WshShell = CreateObject("WScript.Shell")
    WshShell.RegDelete Regkey '刪除檔名
    End Sub

            chtnum = 1
            For Each chtObj In ActiveSheet.ChartObjects
                ' Debug.Print chtObj.Name, chtObj.Parent.Name
                Set clsEventCharts (chtnum).EvtChart = chtObj.Chart
                chtnum = chtnum  1
            Next ' chtObj
        End If
    End Sub

    Private Sub Class_Initialize()
     
         AddString eFormCaption, "Geometric Information"
        AddString eBtnClose, "关闭"
        AddString eBtnCopy, "复制"
        AddString eBtnCreateText, "创建文本"
        AddString eBtnRefresh, "刷新"
        AddString eBtnReset, "清零"
        AddString eCapArea, "面积"
        AddString eCapLength, "长度"
        AddString eCapPerimeter, "周长"
        AddString eCapVolume, "体积"
        AddString eCapDepth, "高度"
        AddString eCapUnits, "单位"
        AddString eCapPrecision, "精度"
        AddString eUnitInch, "in"
        AddString eUnitMM, "mm"
        AddString eUnitCM, "cm"
        AddString eUnitM, "m"
        AddString eStrInch, "英寸 (in)"
       
        AddString eStrMM, "毫米 (mm)"
        AddString eStrCM, "厘米 (cm)"
        AddString eStrM, "米 (m)"
        AddString eStrError, "Error"
        AddString eStrNoSelection, "未选择任何图形"
        AddString eStrGroupSelected, "不支持群组图形,请选择单个图形"
        AddString eStrInvalidObject, "无效选择"
        AddString eStrCurveOpen, "非闭合图形无法计算面积和体积"
        AddString eStrMultipathCurve, "组合图形无法计算面积和体积"
    End Sub

    新葡亰496net 34

    Sub Reset_All_Charts()
        ' Disable events for all charts previously enabled to gether
        Dim chtnum As Integer
        On Error Resume Next
        Set clsEventChart.EvtChart = Nothing
        For chtnum = 1 To UBound (clsEventCharts)
            Set clsEventCharts(chtnum).EvtChart = Nothing
        Next ' chtnum
    End Sub

    Private Sub AddString(ByVal eId As ELangStringID, ByVal s As String)
        Dim tPair As New clsLangPair
        tPair.eId = eId
        tPair.sDef = s
        colDict.Add tPair
    End Sub

    防止 Excel 關閉

    1. 在thisWorkbook中加入下面事件以触发内嵌事件。

    Public Function GetString(ByVal eId As ELangStringID) As String
        Dim tPair As clsLangPair
        Dim s As String
        s = "Str #" & eId
        For Each tPair In colDict
            If tPair.eId = eId Then
                s = tPair.sDef
                Exit For
            End If
        Next tPair
        GetString = s
    End Function

    原碼出自 Tek-Tips Forum

    Option Explicit
     
    Private Sub Workbook_SheetActivate (ByVal Sh As Object)
        Set_All_Charts
    End Sub
     
    Private Sub Workbook_SheetDeactivate (ByVal Sh As Object)
        Reset_All_Charts
    End Sub

    Public Function IsMetric() As Boolean
        IsMetric = bMetric
    End Function

    ' Module

        这样,该Excel中的所有Chart对象都会自动关联上Select事件,并且当事件触发时显示相应的提示信息。

     

    Option Explicit

        为Chart对象添加内嵌事件时存在四种不同的情况:

      (3)名称为clsLangPair,代码如下:

    'Set Types
    Public Type LUID
    LowPart As Long
    HighPart As Long
    End Type

    • 为同一Worksheet中的所有Chart对象添加内嵌事件,在Worksheet对象所在的code中添加下面两个事件: Option Explicit
       
      Private Sub Worksheet_Activate()
          Set_All_Charts
      End Sub
       
      Private Sub Worksheet_Deactivate()
          Reset_All_Charts
      End Sub

    • 为同一Chart标签中的所有Chart对象添加内嵌事件,在Chart标签所在的对象的code中添加下面两个事件: Option Explicit
       
      Private Sub Chart_Activate()
          Set_All_Charts
      End Sub
       
      Private Sub Chart_Deactivate()
          Reset_All_Charts
      End Sub

    • 为同一工作簿中的所有Chart对象添加内嵌事件,在当前工作簿的thisWorkbook对象的code中添加下面两个事件。 Option Explicit
       
      Private Sub Workbook_SheetActivate (ByVal Sh As Object)
          Set_All_Charts
      End Sub
       
      Private Sub Workbook_SheetDeactivate (ByVal Sh As Object)
          Reset_All_Charts
      End Sub

    • 为当前内存中所有的Workbook中的所有Chart对象添加内嵌事件。这个稍微有些麻烦,可按照下面的步骤添加代码:

    Option Explicit

    Public Type LUID_AND_ATTRIBUTES
    pLuid As LUID
    Attributes As Long
    End Type

         i. 新建类模块CAppEvent,添加下面的代码

    Public Enum ELangStringID
        eFormCaption
        eBtnClose
        eBtnCopy
        eBtnCreateText
        eBtnRefresh
        eBtnReset
        eCapArea
        eCapLength
        eCapPerimeter
        eCapVolume
        eCapDepth
        eCapUnits
        eCapPrecision
        eUnitInch
        eUnitMM
        eUnitCM
        eUnitM
        eStrInch
        eStrMM
        eStrCM
        eStrM
        eStrError
        eStrNoSelection
        eStrGroupSelected
        eStrInvalidObject
        eStrCurveOpen
        eStrMultipathCurve
    End Enum

    Public Type TOKEN_PRIVILEGES
    PrivilegeCount As Long
    Privileges(1) As LUID_AND_ATTRIBUTES
    End Type

    Option Explicit
     
    Public WithEvents EventApp As Excel.Application
     
    Private Sub EventApp_SheetActivate (ByVal Sh As Object)
        Set_All_Charts
    End Sub
     
    Private Sub EventApp_SheetDeactivate (ByVal Sh As Object)
        Reset_All_Charts
    End Sub
     
    Private Sub EventApp_WorkbookActivate (ByVal Wb As Workbook)
        Set_All_Charts
    End Sub
     
    Private Sub EventApp_WorkbookDeactivate (ByVal Wb As Workbook)
        Reset_All_Charts
    End Sub

    Public eId As ELangStringID
    Public sDef As String

    ' Declare API functions.
    Public Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long
    Public Declare Function GetCurrentProcess Lib "kernel32" () As Long
    Public Declare Function OpenProcessToken Lib "advapi32" (ByVal ProcessHandle As Long, _
    ByVal DesiredAccess As Long, TokenHandle As Long) As Long
    Public Declare Function LookupPrivilegeValue Lib "advapi32" Alias "LookupPrivilegeValueA" _
    (ByVal lpSystemName As String, ByVal lpName As String, lpLuid As LUID) As Long
    Public Declare Function AdjustTokenPrivileges Lib "advapi32" (ByVal TokenHandle As Long, _
    ByVal DisableAllPrivileges As Long, NewState As TOKEN_PRIVILEGES, ByVal BufferLength _
    As Long, PreviousState As TOKEN_PRIVILEGES, ReturnLength As Long) As Long

         ii. 在模块1中添加下面的代码

        现在一切编写完毕,按F5键运行吧,选中图形,点击程序中“刷新”,“面积”,“体积”等数据立即显示出来,程序运行效果如下图:

    ' Set Set ShutDown Privilege Constants
    Public Const TOKEN_ADJUST_PRIVILEGES = &H20
    Public Const TOKEN_QUERY = &H8
    Public Const SE_PRIVILEGE_ENABLED = &H2

    Dim clsAppEvent As New CAppEvent

     新葡亰496net 35

    Public Sub SetShutDownPrivilege()
    Dim Phndl As Long, Thndl As Long
    Dim MyLUID As LUID
    Dim MyPriv As TOKEN_PRIVILEGES, MyNewPriv As TOKEN_PRIVILEGES

    Sub InitializeAppEvents ()
      Set clsAppEvent.EventApp = Application
      Set_All_Charts
    End Sub
     
    Sub TerminateAppEvents ()
      Set clsAppEvent.EventApp = Nothing
      Reset_All_Charts
    End Sub

    Phndl = GetCurrentProcess()
    OpenProcessToken Phndl, TOKEN_ADJUST_PRIVILEGES Or TOKEN_QUERY, Thndl
    LookupPrivilegeValue "", "SeShutdownPrivilege", MyLUID
    MyPriv.PrivilegeCount = 1
    MyPriv.Privileges(0).Attributes = SE_PRIVILEGE_ENABLED
    MyPriv.Privileges(0).pLuid = MyLUID
    ' Now to set shutdown privilege for my app
    AdjustTokenPrivileges Thndl, False, MyPriv, 4 (12 * MyPriv.PrivilegeCount), MyNewPriv, 4 (12 * MyNewPriv.PrivilegeCount)

         iii. 在thisWorkbook中添加下面代码

    End Sub

    Private Sub Workbook_Open()
        InitializeAppEvents
    End Sub
     
    Private Sub Workbook_BeforeClose (Cancel As Boolean)
        TerminateAppEvents
    End Sub

    ' ThisWorkbook

         如果程序中使用了add-in(Excel外接程序),还需要添加下面两个事件:

    Option Explicit

    Private Sub Workbook_AddinInstall()
        InitializeAppEvents
    End Sub
     
    Private Sub Workbook_AddinUninstall()
        TerminateAppEvents
    End Sub

    Private Sub Workbook_BeforeClose(Cancel As Boolean)
    On Error Resume Next
    Dim Msg, Style, Title, Response
    Dim MyFlag As Long, Ret As String
    'Set ShutDown Constants
    Const EWX_LOGOFF = 0
    Const EWX_SHUTDOWN = 1
    Const EWX_REBOOT = 2
    Const EWX_FORCE = 4

        当新的工作簿被打开或外接程序被加载时,CAppEvent类被实例化并将相应的事件附加到所有的Chart对象中;当工作簿被关闭或外接程序别卸载时,应用程序被终止,图表事件便不再被触发。

    ' Define message.
    Msg = "Do you want to continue ?" _
    & vbCr & vbCr & "You are about to exit the excel program." _
    & vbCr & vbCr & "You will need to Reboot Computer" _
    & vbCr & "to restore the program!"
    Style = vbYesNoCancel vbCritical vbDefaultButton3 ' Define buttons.
    Title = "Exiting Program" ' Define title.
    ' Display message.
    Response = MsgBox(Msg, Style, Title)
    'Test the variable Response
    Select Case Response
    Case vbYes
    'Save the file, Force Windows Closed
    Me.Save
    ' Call Exit_Windows
    Ret = InputBox("Enter Password", "Password Required")
    If Ret = "testing" Then ' 更改你的密碼
    Ret = InputBox("Exit Excel or Logoff User" _
    & vbCr & " Enter: E or L", "What Action")
    Else
    MsgBox "Invalid Password", vbCritical, "Wrong Password"
    Cancel = False
    Exit Sub
    End If
    If Ret = "E" Or Ret = "e" Then
    Application.Quit
    Else
    If Ret = "L" Or Ret = "l" Then
    SetShutDownPrivilege 'Set the shutdown privilege - else reboot will fail
    ' Always execute a force shutdown if a shutdown is required
    MyFlag = EWX_LOGOFF 'LogOff
    ' Grab the shutdown privilege - else reboot will fail
    SetShutDownPrivilege
    'Do the required action
    Call ExitWindowsEx(MyFlag, 0)
    End If
    End If
    Case vbNo
    Worksheets(1).Activate
    Cancel = True
    Case vbCancel
    Cancel = True
    Case Else
    'Do Nothing
    End Select

        实际应用中存在很多意想不到的情况导致我们所设置的内嵌事件处理程序不能成功地将相应的事件附加到Chart对象上,甚至还会引发Excel的异常,这很常见!此时你应该考虑InitializeAppEvents过程执行的时机,从而将该过程的执行代码移到其它的地方,这要视具体情况来定。

    End Sub

        Excel的图表事件在实际应用中还是非常有用的,它可以扩展用户对Excel图表的使用,从而使操作更加简便。另一方面,我们可以借助于Excel图表对象的事件,通过编写少量的代码来使我们的应用程序完成更加强大的功能。例如在图表中依据鼠标所点的两个点来生成一个曲线,将该曲线作为图表中series的一部分;或者通过鼠标的滚轮来放大或缩小图表的现实区域等。读者如果感兴趣,可以试着自己定义不同的图表事件处理程序来实现更加丰富的功能。

    Private Sub Workbook_Open()
    On Error Resume Next
    'Activate the 1st worksheet using the workbooks worksheet index
    Worksheets(1).Activate
    'Or If you want to use the actual worksheet name
    'Worksheets("Sheet1").Activate
    End Sub

    指定电脑上运行

    '用 F8 逐句执行篮色编码,取值后更改红色部份

    ' ThisWorkBook

    Private Declare Function w32_GetComputerName Lib "kernel32" _
    Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long

    Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" _
    (ByVal lpBuffer As String, nSize As Long) As Long
    Public LoginTime

    Private Sub Workbook_Open()
    Dim TempUName ' User Name
    Dim TempPCName ' PC Name
    TempPCName = GetComputerName
    TempUName = UserName
    If TempPCName <> "PCName01" And TempPCName <> "PCName02" And TempUName <> "BeeBee" _
    And TempPCName <> "EMILY" Then
    MsgBox "Sorry, This File is for BeeBee ONLY."
    Application.Quit
    End If
    End Sub

    Function GetComputerName()
    Dim sComputerName As String
    Dim lComputerNameLen As Long
    Dim lResult As Long
    lComputerNameLen = 256
    sComputerName = Space(lComputerNameLen)
    lResult = w32_GetComputerName(sComputerName, lComputerNameLen)
    If lResult <> 0 Then
    GetComputerName = Left(sComputerName, lComputerNameLen)
    Else
    GetComputerName = "Unknown"
    End If
    End Function

    Function UserName() As String
    Dim Buffer As String * 100
    Dim BuffLen As Long
    BuffLen = 100
    GetUserName Buffer, BuffLen
    UserName = Left(Buffer, BuffLen - 1)
    End Function

    可以监控删除行及列吗

    ' Module

    Option Explicit

    '// Worksheet RowColumn Deleted Event
    '// This is NOT a real event but just hack the command button.
    '// You can know when the rows or the columns was deleted by user's opelation.

    Sub EventHack() ' 执行监控程序
    AssignMacro "JudgeRng"
    End Sub
    Sub EventReset() ' 取消监控程序
    AssignMacro ""
    End Sub

    Private Sub AssignMacro(ByVal strProc As String)
    Dim lngId As Long
    Dim CtrlCbc As CommandBarControl
    Dim CtrlCbcRet As CommandBarControls
    Dim arrIdNum As Variant

    '// 293=Delete menu of the right click on row
    '// 294=Delete menu of the right click on column
    '// 293=Delete menu of the Edit of main menu
    arrIdNum = Array(293, 294, 478)

    For lngId = LBound(arrIdNum) To UBound(arrIdNum)
    Set CtrlCbcRet = CommandBars.FindControls(ID:=arrIdNum(lngId))
    For Each CtrlCbc In CtrlCbcRet
    CtrlCbc.OnAction = strProc
    Next
    Set CtrlCbcRet = Nothing
    Next
    End Sub

    Private Sub JudgeRng()
    If Not TypeOf Selection Is Range Then Exit Sub
    With Selection
    If .Address = .EntireRow.Address Then
    Call DelExecute("Row:" & .Row, xlUp)
    ElseIf .Address = .EntireColumn.Address Then
    Call DelExecute("Column:" & .Column, xlToLeft)
    Else
    Application.Dialogs(xlDialogEditDelete).Show
    End If
    End With
    End Sub

    Private Sub DelExecute(ByVal str, ByVal lngDerec As Long)
    MsgBox "deleted:" & str
    Selection.Delete lngDerec
    End Sub

    新葡亰496net 36

    测试 WorkBook 是否已开启

    Sub IsWorkBookOpen() Dim wBook As Workbook On Error Resume Next Set wBook = Workbooks("Book180.xls") If wBook Is Nothing Then MsgBox "Workbook is not open" Set wBook = Nothing On Error GoTo 0 Else MsgBox "Yes it is open" Set wBook = Nothing On Error GoTo 0 End If End Sub

    新葡亰496net 37

    请问如何不改变activecell之下将某一储存格显示于左上角
    ActiveCell.Select ActiveWindow.ScrollRow = ActiveCell.Row ActiveWindow.ScrollColumn = ActiveCell.Column

    Application.Goto ActiveCell, True

    新葡亰496net 38

    如何在 VBA 内执行 Add-in 函数

    AddIns("VBA 分析工具箱").Installed = True Range("B1") = Application.Evaluate("=Weeknum(now()-7, 2)") AddIns("VBA 分析工具箱").Installed = True Workdays = Application.Evaluate("=NetWorkdays(DATE(2004,1,1) ,DATE(2004,12,31))")

    Application.Run("ATPVBAEN.xla!Weeknum", Now(), 2)

    新葡亰496net 39

    如何禁止更改工作表名称

    简单例子

    Private Sub Worksheet_SelectionChange(ByVal Target As Range) If ActiveSheet.Name <> "Sheet1" Then ActiveSheet.Name = "Sheet1" End If End Sub

    详细例子 请参考【禁止更改工作表名称 Chijanzen】

    检测EXCEL建立时间

    Sub CreateDate() On Error Resume Next rw = 1 Worksheets(1).Activate For Each p In ActiveWorkbook.BuiltinDocumentProperties Cells(rw, 1).Value = p.Name Cells(rw, 2).Value = ActiveWorkbook.BuiltinDocumentProperties(p.Name) rw = rw 1 Next MsgBox ActiveWorkbook.BuiltinDocumentProperties("Creation date") End Sub

    Rename CodeName

    新葡亰496net 40点击浏览该文件

    新葡亰496net 41

    指定电脑上运行 19/F

    可以监控删除行及列吗 20/F

    列出所有工作薄的 VBA 21/F

    vba 程式碼(代碼)是否限定容量不得超過 64K 限制嗎 23/F

    找格式化的顏色 ( Font 及 Interior) 请参考 找格式化的顏色 ( Font 及 Interior)

    有没有办法在EXCEL的工作表里插入一张会动的gif 动画

    请参考 (向大家推荐一个可以在SHEET中使用的gif动画插件)

    请参考 (不用控件也来显示GIF动画)

    如何一打开工作簿,关闭所有工作表,剩 sheet1 为活动工作表

    请参考
    点击浏览该文件 , 用快速键 CRTL s 可转换下一页,现在只有三页(可以增加)

    如何另存文件时不保存文件的宏

    请参考 (在背景作業中另存新檔 chijanzen)

    找寻自定范围名称左上、左下、右上及右下地址

    请参考 新葡亰496net 42点击浏览该文件

    请教如何在单元格里获得页码和总页数

    请参考 (请教如何在单元格里获得页码和总页数)

    加長 驗證 的長度及寬度

    请参考 加長 驗證 的長度及寬度

    如何改变列表框下拉的字体格式

    Excel 本身自帶的驗證下拉列表是沒有這功能,可用 Combox 方式,請參考附件

    新葡亰496net 43点击浏览该文件

    请问全屏显示后,如何不显示“关闭全屏显示”工具栏

    Sub hidebar() ' chijanzen Application.CommandBars(1).Enabled = False Application.DisplayFullScreen = True Application.CommandBars("Full Screen").Visible = False With ActiveWindow .DisplayHorizontalScrollBar = False .DisplayVerticalScrollBar = False End With End Sub Sub unhidebar() Application.CommandBars(1).Enabled = True Application.DisplayFullScreen = False With ActiveWindow .DisplayHorizontalScrollBar = True .DisplayVerticalScrollBar = True End With End Sub

    怎样隐藏windows下面的任务栏 请参考【隐藏任务栏】

    可以在不影响活页薄情况下显示时间吗

    请参考【在工具列新增1个常驻的电子时钟 Chijanzen】

    请参考 Ivan F Moala 新葡亰496net 44点击浏览该文件

    怎样判断空工作表?并自动删除

    If IsEmpty(ActiveSheet.UsedRange) And ActiveSheet.Shapes.Count = 0 Then ActiveSheet.Delete

    本文由新葡亰496net发布于新葡亰496net,转载请注明出处:新葡亰496netExcel中的图表事件,工作薄及工作表

    关键词:

上一篇:您必要知道那些干货,PPT小白炼成记

下一篇:没有了