利用Excel图表和VBA做一个仿水晶易表

楼主 amulee	如以下网址中所示：下方有一个价格图表（折线图），随着鼠标的移动，鼠标所指日期显示高亮，且显示当日价格标签和数据。在水晶图表工具中提供了这样的图表设置。利用Excel的图表和VBA，同样可以实现该效果。 1、在原始数据区域添加一个辅助列，记录下该系列数值最大值，公式为： =MAX($B$2:$B$32)+200 如图： 2、添加一个折线图，选中辅助列哪个数据系列，右键选择“更改系列图表类型”，将其改为柱形图 3、选中柱形图，右键选择“设置数据系列格式”，改成无间距，设置边框为实线 4、更改坐标轴最大值等，随后将坐标轴等其他无用的内容删除。 5、按Alt+F11进入VBE，添加一个类模块，将其改名为“MyChart”，在类模块中添加以下代码： 'API用于像素和磅的转换 Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nindex As Long) As Long Public WithEvents Cht As Chart Private PtCount As Long '数据点个数 Private Point2Pix As Double '磅转换成像素 Private CurPt& Private PrePt& Private Sub Cht_Activate() Dim Pt As Point '设置绘图区的尺寸填满图表 Cht.PlotArea.Top = 0 Cht.PlotArea.Left = 0 Cht.PlotArea.Height = Cht.ChartArea.Height Cht.PlotArea.Width = Cht.ChartArea.Width '设置数据点 Cht.SeriesCollection(1).MarkerStyle = xlMarkerStyleNone Cht.SeriesCollection(1).MarkerSize = 10 Cht.SeriesCollection(1).HasDataLabels = False For Each Pt In Cht.SeriesCollection(2).Points Pt.Interior.Color = RGB(217, 217, 217) Next '记录数据点个数 PtCount = Cht.SeriesCollection(1).Points.Count '求磅转换成像素的比例 Point2Pix = GetDeviceCaps(GetDC(0), 90) / Application.InchesToPoints(1) End Sub Private Sub Cht_MouseMove(ByVal Button As Long, ByVal Shift As Long, ByVal x As Long, ByVal y As Long) Dim Pt As Point Dim ChtHeight%, ChtWidth% Dim CurPoint& '求出图标像素尺寸 ChtWidth = Cht.PlotArea.Width * Point2Pix If x > 0 And x < ChtWidth Then PrePt = CurPt '求当前选中哪个数据点 CurPt = Int(x / (ChtWidth / PtCount)) + 1 If CurPt <> PrePt Then '如果当前数据点和前一个不同,则改变填充色 If PrePt > 0 And PrePt <= PtCount Then Cht.SeriesCollection(2).Points(PrePt).Interior.Color = RGB(217, 217, 217) Cht.SeriesCollection(1).Points(PrePt).MarkerStyle = xlMarkerStyleNone Cht.SeriesCollection(1).Points(PrePt).HasDataLabel = False End If '改变 Cht.SeriesCollection(2).Points(CurPt).Interior.Color = RGB(215, 228, 189) Cht.SeriesCollection(1).Points(CurPt).MarkerStyle = xlMarkerStyleDiamond Cht.SeriesCollection(1).Points(CurPt).HasDataLabel = True Sheet1.Label1.Caption = Range("A1").Offset(CurPt, 0) End If End If End Sub 6、图表所在工作簿添加以下代码： Dim MyCht As MyChart Private Sub Worksheet_Activate() Set MyCht = New MyChart Set MyCht.Cht = Sheet1.ChartObjects(1).Chart End Sub 7、回到工作表，选中其他工作表再选中该工作表，点击图表后就能实现效果。图表随鼠标移动显示数据.rar
2楼水星钓鱼	学习下
3楼 Gavin_曾	vvv
4楼 qsc	ghjfhjgkhlk
5楼 hl_irnt	真高
6楼 expro	下来的鼠标移动怎么没反应呢？