|
|
楼主 |
发表于 2005-12-29 10:08
|
显示全部楼层
VBA版
TdIPGyNz.zip
(317.68 KB, 下载次数: 3006)
'图表工作表里的代码，按下鼠标左键显示坐标线；按下右键弹出快捷菜单。参见VBA帮助GetChartElement函数。当图表为工作表形式时，可以随意使用图表事件；当图表为内嵌图表时，需要编写类模块来激活其事件程序，而且只有当图表被选择时才有效。所以笔者将本图表设置为一图表工作表。
'另外，图表事件获得的X,Y值与绘图区和图形的长度度量单位不一样，所以程序里使用了两个转化系数。不知该系数在不同电脑上是否相同，如不同，则用户需要自己调试。
Option Explicit
'Shape's position is in Pixels
'Const xUnit As Single = 28.83333
'Const yUnit As Single = -22.5556
'y = 0.75x - 3.5999
'Const LefttoX As Single = 0.74168
Const LefttoX As Single = 0.75
Const sIntercept As Single = 3.5999
Const xAxisMin As Single = 0
Const xAxisMax As Single = 24
Const yAxisMin As Single = 0
Const yAxisMax As Single = 18
Private Sub Chart_MouseDown(ByVal Button As Long, _
ByVal Shift As Long, _
ByVal x As Long, _
ByVal y As Long)
Dim ElementId As Long
Dim arg1 As Long, arg2 As Long
Dim sStTop As Single, _
sStLeft As Single, _
sWidth As Single, _
sHeight As Single
If Not Sheets("List").Range("EventEnabled").Value Then Exit Sub
Application.ScreenUpdating = False
With ActiveChart.PlotArea
sStTop = .Top
sStLeft = .Left
sWidth = .Width
sHeight = .Height
End With
ActiveChart.GetChartElement x, y, ElementId, arg1, arg2
Select Case Button
Case xlPrimaryButton 'Left Click
If ElementId = xlPlotArea _
Or ElementId = xlDataLabel _
Or ElementId = xlSeries _
Or ElementId = xlAxis Then
With ActiveChart
.Shapes("LineHorz").Top = y * LefttoX - sIntercept
.Shapes("LineHorz").Left = sStLeft
.Shapes("LineHorz").Width = ActiveChart.PlotArea.Width
.Shapes("LineVert").Left = x * LefttoX - sIntercept
.Shapes("LineVert").Top = sStTop
.Shapes("LineVert").Height = ActiveChart.PlotArea.Height
.Shapes("LineHorz").Visible = msoTrue
.Shapes("LineVert").Visible = msoTrue
End With
ElseIf ElementId = xlShape And (arg1 = 6 Or arg1 = 7) Then
With ActiveChart
.Shapes("LineHorz").Top = y * LefttoX - sIntercept
.Shapes("LineHorz").Left = sStLeft
.Shapes("LineHorz").Width = ActiveChart.PlotArea.Width
.Shapes("LineVert").Left = x * LefttoX - sIntercept
.Shapes("LineVert").Top = sStTop
.Shapes("LineVert").Height = ActiveChart.PlotArea.Height
.Shapes("LineHorz").Visible = msoTrue
.Shapes("LineVert").Visible = msoTrue
End With
Else
ActiveChart.Shapes("LineHorz").Visible = msoFalse
ActiveChart.Shapes("LineVert").Visible = msoFalse
End If
Application.ScreenUpdating = True
Case xlSecondaryButton 'Right Click
Application.ScreenUpdating = True
If ElementId = xlPlotArea _
Or ElementId = xlDataLabel _
Or ElementId = xlSeries _
Or ElementId = xlAxis Then
With ActiveChart
If .Shapes("LineHorz").Visible = msoFalse Then
With ActiveChart
.Shapes("LineHorz").Top = y * LefttoX - sIntercept
.Shapes("LineHorz").Left = sStLeft
.Shapes("LineHorz").Width = ActiveChart.PlotArea.Width
.Shapes("LineVert").Left = x * LefttoX - sIntercept
.Shapes("LineVert").Top = sStTop
.Shapes("LineVert").Height = ActiveChart.PlotArea.Height
.Shapes("LineHorz").Visible = msoTrue
.Shapes("LineVert").Visible = msoTrue
End With
End If
End With
Select Case ElementId
Case xlDataLabel 'point at on a data point, to disable "add new point" and enable "delete data"
isPoint = True
iRow = arg2
Case xlSeries 'point at on a data point, to disable "add new point" and enable "delete data"
isPoint = True
iRow = arg2
Case Else
isPoint = False
sXValue = (ActiveChart.Shapes("LineVert").Left - sStLeft) / sWidth * 24
sYValue = 18 - (ActiveChart.Shapes("LineHorz").Top - sStTop) / sHeight * 18
End Select
showPopupMenu
ElseIf ElementId = xlShape And (arg1 = 6 Or arg1 = 7) Then
With ActiveChart
If .Shapes("LineHorz").Visible = msoFalse Then
With ActiveChart
.Shapes("LineHorz").Top = y * LefttoX - sIntercept
.Shapes("LineHorz").Left = sStLeft
.Shapes("LineHorz").Width = ActiveChart.PlotArea.Width
.Shapes("LineVert").Left = x * LefttoX - sIntercept
.Shapes("LineVert").Top = sStTop
.Shapes("LineVert").Height = ActiveChart.PlotArea.Height
.Shapes("LineHorz").Visible = msoTrue
.Shapes("LineVert").Visible = msoTrue
End With
End If
End With
isPoint = False
sXValue = (ActiveChart.Shapes("LineVert").Left - sStLeft) / sWidth * 24
sYValue = 18 - (ActiveChart.Shapes("LineHorz").Top - sStTop) / sHeight * 18
showPopupMenu
End If
End Select
End Sub
'点击城市名称列表框以选择特定城市
Sub SelectCity()
Dim iPoint As Integer
Application.ScreenUpdating = False
iPoint = Sheets("List").Range("CityNo")
With ActiveChart.SeriesCollection(2).DataLabels.Border
.LineStyle = xlNone
End With
With ActiveChart.SeriesCollection(2).Points(iPoint).DataLabel.Border
.ColorIndex = 3
.Weight = xlHairline
If Sheets("List").Range("ShowCityName").Value Then
.LineStyle = xlContinuous
Else
.LineStyle = xlNone
End If
End With
Application.ScreenUpdating = True
End Sub
'移动城市名称位置，因为不同省份的城市名称长短不同，很多情况下会重叠在一起，本代码让你移动数据标志
Sub DataLabelMove(ByVal strDirection As String)
Const sMove As Single = 2
With ActiveChart.SeriesCollection(2).Points(Sheets("List").Range("CityNo").Value).DataLabel
Select Case strDirection
Case "Up"
.Top = .Top - sMove
Case "Down"
.Top = .Top + sMove
Case "Left"
.Left = .Left - sMove
Case "Right"
.Left = .Left + sMove
Case Else
End Select
End With
End Sub
Sub moveUp()
Call DataLabelMove("Up")
End Sub
Sub moveDown()
Call DataLabelMove("Down")
End Sub
Sub moveLeft()
Call DataLabelMove("Left")
End Sub
Sub moveRight()
Call DataLabelMove("Right")
End Sub
'菜单代码
Const myPopUpMenu As String = "Chart Menu"
Public iRow As Integer
'Public iColumn As Integer
Public sXValue As Single
Public sYValue As Single
Public isPoint As Boolean
Sub CreatePopUpMenu(ByVal EnableDisable As Boolean)
Dim cmBar As CommandBar
DeletePopUpMenu
Set cmBar = Application.CommandBars.Add(Name:=myPopUpMenu, _
Position:=msoBarPopup, _
MenuBar:=False, _
temporary:=True)
With cmBar
With .Controls.Add(Type:=msoControlButton)
.Caption = "增加新城市"
.OnAction = "AddCity"
.Enabled = Not EnableDisable
End With
With .Controls.Add(Type:=msoControlButton)
.Caption = "删除所选城市"
.OnAction = "DeleteCity"
.Enabled = EnableDisable
End With
With .Controls.Add(Type:=msoControlButton)
.Caption = "更改所选城市数据"
.OnAction = "SetSelectedData"
.Enabled = EnableDisable
End With
With .Controls.Add(Type:=msoControlButton)
.Caption = "恢复缺省设置"
.OnAction = "ResumeDefault"
End With
With .Controls.Add(Type:=msoControlButton)
.Caption = "导出地图"
.OnAction = "ExportMap"
End With
End With
End Sub
Sub DeletePopUpMenu()
On Error Resume Next
Application.CommandBars(myPopUpMenu).Delete
On Error GoTo 0
End Sub
Sub showPopupMenu()
DeletePopUpMenu
Call CreatePopUpMenu(isPoint)
Application.CommandBars(myPopUpMenu).ShowPopup
End Sub
'___________________________________________________________________________________
'___________________________________________________________________________________
Sub AddCity()
' MsgBox "x= " & sXValue & " y= " & sYValue
Dim iColumn As Integer, iEndRow As Integer
Dim strCityName As String
Dim strData As String
' On Error Resume Next
With ActiveChart
.ProtectData = False
.ProtectFormatting = False
.ProtectSelection = False
End With
iColumn = (Sheets("List").Range("ChartTitle").Value - 1) * 6 + 3
With Sheets("Data")
strCityName = InputBox("请输入增加的城市名称。", "增加城市")
.Cells(.Cells(1, iColumn + 1).Value + 2, iColumn) = IIf(strCityName = "", "未知城市", strCityName)
.Cells(.Cells(1, iColumn + 1).Value + 1, iColumn + 1) = sXValue
.Cells(.Cells(1, iColumn + 1).Value + 1, iColumn + 2) = sYValue
iEndRow = .Cells(65536, 199).End(xlUp).Row
If .Cells(1, iColumn + 1).Value > iEndRow - 2 Then
.Cells(iEndRow, 199).AutoFill Destination:=.Range(.Cells(iEndRow, 199), .Cells(iEndRow + 1, 199)), _
Type:=xlFillDefault
ActiveChart.SeriesCollection(2).Points(iEndRow - 1).DataLabel.Text = "=Data!R" & iEndRow + 1 & "C199"
End If
strData = InputBox("请输入该城市对应的数据。", "增加城市")
.Cells(.Cells(1, iColumn + 1).Value + 1, iColumn + 3) = IIf(strData = "", 0, CSng(strData))
End With
With ActiveChart
.ProtectData = True
.ProtectFormatting = True
.ProtectSelection = True
End With
End Sub
Sub DeleteCity()
Dim iColumn As Integer, iCurRow As Integer
' On Error Resume Next
With ActiveChart
.ProtectData = False
.ProtectFormatting = False
.ProtectSelection = False
End With
iColumn = (Sheets("List").Range("ChartTitle").Value - 1) * 6 + 3
iCurRow = iRow + 1 'Sheets("List").Range("CityNo").Value + 1
With Sheets("Data")
.Range(.Cells(iCurRow, iColumn), .Cells(iCurRow, iColumn + 3)).Delete Shift:=xlUp
' .Cells(iCurRow, 199).Delete Shift:=xlUp
End With
With ActiveChart
.ProtectData = True
.ProtectFormatting = True
.ProtectSelection = True
End With
End Sub
Sub SetSelectedData()
frmSelectedData.Show
End Sub
Sub ResumeDefault()
Dim i As Integer
Dim shtList As Worksheet, _
shtData As Worksheet
Application.ScreenUpdating = False
Set shtList = Sheets("List")
Set shtData = Sheets("Data")
For i = 1 To 33
With shtList
.Range(.Cells(1, (i - 1) * 3 + 10), .Cells(1, (i - 1) * 3 + 12)).EntireColumn.Copy
End With
With shtData
.Range(.Cells(1, (i - 1) * 6 + 3), .Cells(1, (i - 1) * 6 + 5)).EntireColumn.PasteSpecial
End With
Next i
Application.ScreenUpdating = True
End Sub
Sub ExportMap()
With ActiveChart
.Export "C:\" & .ChartTitle.Text & ".gif", "gif", True
MsgBox "该地图已经被保存到C盘，文件名为：" & .ChartTitle.Text & ".gif"
End With
End Sub
'窗体中的代码 - 更改所选城市的名称和数据
Private Sub cmdApply_Click()
Dim shtData As Worksheet, _
shtList As Worksheet
Set shtData = Sheets("Data")
Set shtList = Sheets("List")
With Me
If .txtNewName.Text <> "" Then
shtData.Cells(iRow + 1, _
(shtList.Range("ChartTitle").Value - 1) * 6 + 3) = .txtNewName.Text
End If
If .txtNewData.Text <> "" Then
shtData.Cells(iRow + 1, _
shtList.Range("ChartTitle").Value * 6) = Val(.txtNewData.Text)
End If
End With
Unload Me
End Sub
Private Sub cmdCancel_Click()
Unload Me
End Sub
Private Sub txtNewData_Change()
Me.cmdApply.Enabled = True
End Sub
Private Sub txtNewName_Change()
Me.cmdApply.Enabled = True
End Sub
Private Sub UserForm_Initialize()
Dim shtData As Worksheet, _
shtList As Worksheet
Set shtData = Sheets("Data")
Set shtList = Sheets("List")
With Me
.cmdApply.Enabled = False
' .lbOldName = shtData.Cells(shtList.Range("CityNo").Value + 1, _
' (shtList.Range("ChartTitle").Value - 1) * 6 + 3).Value
' .lbOldData = shtData.Cells(shtList.Range("CityNo").Value + 1, _
' shtList.Range("ChartTitle").Value * 6).Value
.lbOldName = shtData.Cells(iRow + 1, _
(shtList.Range("ChartTitle").Value - 1) * 6 + 3).Value
.lbOldData = shtData.Cells(iRow + 1, _
shtList.Range("ChartTitle").Value * 6).Value
End With
End Sub
'工作簿打开代码。工作表图表可以设置其数据，格式以及选择保护属性；内嵌图表则不允许。但是每次当你打开该文件时，Excel会自动解开这些保护，所以，这里每次打开该文件时再设置这些保护。
Private Sub Workbook_Open()
On Error Resume Next
ChinaMap.Activate
With ActiveChart
.ProtectData = True
.ProtectFormatting = True
.ProtectSelection = True
End With
End Sub
一个发现，在Excel 2003中文版中，设置数据标志时可以使用名称；现在我使用Excel 2003则不能使用名称，而必须选择某个数据标志，直接等于某个单元格。这可能是有些网友在使用前面版本时显示错误的原因吧。请各位测试。 |
|
楼主: hxhgxy
[复制链接]
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2005-12-22 12:38
