返回列表 上一主題 發帖

[發問] 類似移動指引線的效果

stillfish00

帖子
1018 
主題
15 
精華
0 
積分
1058 
點名
0  
作業系統
win7 32bit 
軟體版本
Office 2016 64-bit 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2012-5-9 
最後登錄
2022-9-28 
1# 跳轉到 »
發表於 2015-12-15 12:14 | 顯示全部帖子
回復 2# 栗栗子
新增物件類別模組，命名 EventClassModule
  1. Private WithEvents myChartClass As Chart
  2. Private myVLine As Object
  3. Private myTarget As Range

  5. Public Sub InitializeChart(objChart As Object, rngTarget As Range)
  6.     Set myChartClass = objChart
  7.     Set myTarget = rngTarget
  8.    
  9.     On Error Resume Next
  10.     Set myVLine = myChartClass.Shapes("vline")
  11.     On Error GoTo 0
  12.    
  13.     If myVLine Is Nothing Then
  14.         With myChartClass.PlotArea
  15.             Set myVLine = myChartClass.Shapes.AddLine(.InsideLeft, .InsideTop, .InsideLeft, .InsideTop + .InsideHeight)
  16.             myVLine.Name = "vline"
  17.         End With
  18.     End If
  19. End Sub

  21. Private Sub myChartClass_MouseMove(ByVal Button As Long, ByVal Shift As Long, ByVal x As Long, ByVal y As Long)
  22.     Dim pt_x As Double, interval As Double, indx As Long
  23.     Dim arValues
  24.    
  25.     pt_x = 75 * x / ActiveWindow.Zoom
  26.     interval = myChartClass.PlotArea.InsideWidth / UBound(myChartClass.SeriesCollection(1).XValues)
  27.     indx = Application.RoundUp((pt_x - myChartClass.PlotArea.InsideLeft) / interval, 0)
  28.     indx = Application.Min(Application.Max(1, indx), UBound(myChartClass.SeriesCollection(1).XValues))
  29.         
  30.     With myChartClass.SeriesCollection
  31.         If .Count = 0 Then Exit Sub
  32.         For i = 1 To .Count
  33.             With .Item(i)
  34.                 .ApplyDataLabels Type:=xlDataLabelsShowNone
  35.                 .Points(indx).ApplyDataLabels Type:=xlDataLabelsShowValue
  36.                 .Points(indx).DataLabel.Format.Fill.ForeColor.RGB = RGB(255, 255, 0)
  37.                 arValues = .Values
  38.                 If i <= myTarget.Cells.Count Then myTarget.Cells(i + 1).Value = arValues(indx)
  39.             End With
  40.         Next
  41.         arValues = .Item(1).XValues
  42.         myTarget.Cells(1).Value = arValues(indx)
  43.     End With
  44.    
  45.     With myChartClass
  46.         If .Axes(xlCategory).AxisBetweenCategories Then
  47.             myVLine.Left = .PlotArea.InsideLeft + (indx - 0.5) * interval
  48.         Else
  49.             myVLine.Left = .PlotArea.InsideLeft + (indx - 1) * interval
  50.         End If
  51.     End With
  52. End Sub
複製代碼
一般模組：
  1. Dim myChart As EventClassModule

  3. Sub TriggerChartVLine()
  4.     With Sheets(1)
  5.         Set myChart = New EventClassModule
  6.         myChart.InitializeChart .ChartObjects(1).Chart, .Range("U15:U18")
  7.     End With
  8. End Sub

  10. Sub Auto_Open()
  11.     TriggerChartVLine
  12. End Sub
複製代碼
Index.zip (93.23 KB)
表達不清、題意不明確、沒附檔案格式、沒有討論問題的態度~~~~~~以上愛莫能助。

TOP

stillfish00

帖子
1018 
主題
15 
精華
0 
積分
1058 
點名
0  
作業系統
win7 32bit 
軟體版本
Office 2016 64-bit 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2012-5-9 
最後登錄
2022-9-28 
2#
發表於 2015-12-23 17:30 | 顯示全部帖子
回復 9# 栗栗子
1. 能附檔案看看比較好，或是試試改成這樣
  1. Private Sub myChartClass_MouseMove(ByVal Button As Long, ByVal Shift As Long, ByVal x As Long, ByVal y As Long)
  2.     Dim pt_x As Double, interval As Double, indx As Long
  3.     Dim arValues, targetX
  4.     Dim isAxisBetween As Boolean, dataCount As Long, diffX, xOffset
  5.    
  6.     pt_x = 75 * x / ActiveWindow.Zoom
  7.    
  8.     With myChartClass
  9.         If .SeriesCollection.Count = 0 Then Exit Sub
  10.         isAxisBetween = .Axes(xlCategory).AxisBetweenCategories '座標軸位置 刻度間:True 刻度上:False
  11.         arValues = .SeriesCollection(1).XValues '日期資料
  12.         dataCount = UBound(arValues)    '資料數目
  13.         With .Axes(xlCategory)
  14.             diffX = .MaximumScale - .MinimumScale
  15.             xOffset = IIf(isAxisBetween, 0.5 * myChartClass.PlotArea.InsideWidth / (diffX + 1), 0)
  16.             If pt_x < myChartClass.PlotArea.InsideLeft + xOffset Then
  17.                 indx = 1
  18.             Else
  19.                 targetX = .MinimumScale + diffX * (pt_x - myChartClass.PlotArea.InsideLeft - xOffset) / (myChartClass.PlotArea.InsideWidth - 2 * xOffset)
  20.                 indx = Application.Match(targetX, arValues, 1)
  21.                 If indx < UBound(arValues) Then
  22.                     If Abs(targetX - arValues(indx + 1)) < Abs(targetX - arValues(indx)) Then indx = indx + 1   '修正最近資料點
  23.                 End If
  24.             End If
  25.             
  26.         End With
  27.         myVLine.Left = .PlotArea.InsideLeft + xOffset + (.PlotArea.InsideWidth - 2 * xOffset) * (arValues(indx) - arValues(1)) / CDbl(diffX)
  28.         myTarget.Cells(1).Value = arValues(indx)
  29.         For i = 1 To .SeriesCollection.Count
  30.             With .SeriesCollection(i)
  31.                 .ApplyDataLabels Type:=xlDataLabelsShowNone
  32.                 .Points(indx).ApplyDataLabels Type:=xlDataLabelsShowValue
  33.                 .Points(indx).DataLabel.Format.Fill.ForeColor.RGB = RGB(255, 255, 0)
  34.                 arValues = .Values
  35.                 If i < myTarget.Cells.Count Then myTarget.Cells(i + 1).Value = arValues(indx)
  36.             End With
  37.         Next
  38.     End With
  39. End Sub
複製代碼
2. MouseMove 是 Chart(圖表) 內建的事件，當滑鼠指標在圖表上的位置改變時會自動觸發此事件。
    事件的參數會自己傳入，你只要知道傳入的東西到底是代表什麼。
    各參數說明可以自己F1查 MouseMove得知。
    Button  : 事件發生時，滑鼠按鍵狀態
    Shift : 事件發生時 SHIFT、CTRL 和 ALT 鍵的狀態
    x : 滑鼠指標在圖表物件工作區座標中的 X 座標。
    y : 滑鼠指標在圖表物件工作區座標中的 Y 座標。
3. 是因為座標軸格式中，座標軸位置分為刻度上和刻度與刻度間相距兩種，會影響資料點位置。
表達不清、題意不明確、沒附檔案格式、沒有討論問題的態度~~~~~~以上愛莫能助。

TOP

stillfish00

帖子
1018 
主題
15 
精華
0 
積分
1058 
點名
0  
作業系統
win7 32bit 
軟體版本
Office 2016 64-bit 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2012-5-9 
最後登錄
2022-9-28 
3#
發表於 2015-12-24 15:07 | 顯示全部帖子
本帖最後由 stillfish00 於 2015-12-24 15:11 編輯

回復 11# 栗栗子
1.  indx = Application.Match(targetX, arValue, 1)
     這句 arValue 改成 arValues , 筆誤。

3. 我也是上網查的，你在查 Chart 的 InsideLeft 或 InsideWidth 這些屬性時都會告訴你它是以"點"為單位，一個點定義是1/72英吋 (也有人定義為1/72.27英吋)。

而傳入參數的  x , y 單位是 pixel(像素)；根據windows內顯示器 DPI(dot per inch) 設定可決定每英吋多少像素，一般預設為 normal size 100% (=96 DPI)，表示每英吋 96 像素。

所以要把 x 像素轉成點要乘以 72/96=0.75
還要考慮 zoom , 所以變成  0.75*x/(ActiveWindow.zoom/100) = 75*x/ActiveWindow.zoom
表達不清、題意不明確、沒附檔案格式、沒有討論問題的態度~~~~~~以上愛莫能助。

TOP

stillfish00

帖子
1018 
主題
15 
精華
0 
積分
1058 
點名
0  
作業系統
win7 32bit 
軟體版本
Office 2016 64-bit 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2012-5-9 
最後登錄
2022-9-28 
4#
發表於 2015-12-25 09:59 | 顯示全部帖子
回復 11# 栗栗子
修改 myVLine.Left 從該資料點的 left 屬性取得，如下
你說的無法精準的對上座標，那是你資料太密集，圖表本身日期座標軸就會這樣(每個月天數是不同的，它卻同間隔)
  1. Private Sub myChartClass_MouseMove(ByVal Button As Long, ByVal Shift As Long, ByVal x As Long, ByVal y As Long)
  2.     Dim pt_x As Double, interval As Double, indx As Long
  3.     Dim arValues, targetX, diffX
  4.     Dim isAxisBetween As Boolean, xOffset
  5.    
  6.     pt_x = 75 * x / ActiveWindow.Zoom
  7.    
  8.     With myChartClass
  9.         If .SeriesCollection.Count = 0 Then Exit Sub
  10.         isAxisBetween = .Axes(xlCategory).AxisBetweenCategories '座標軸位置 刻度間:True 刻度上:False
  11.         arValues = .SeriesCollection(1).XValues '日期資料
  12.         diffX = .Axes(xlCategory).MaximumScale - .Axes(xlCategory).MinimumScale
  13.         xOffset = IIf(isAxisBetween, 0.5 * .PlotArea.InsideWidth / (diffX + 1), 0)
  14.         
  15.         If pt_x < .PlotArea.InsideLeft + xOffset Then
  16.             indx = 1
  17.         Else
  18.             targetX = .Axes(xlCategory).MinimumScale + diffX * (pt_x - .PlotArea.InsideLeft - xOffset) / (.PlotArea.InsideWidth - 2 * xOffset)
  19.             indx = Application.Match(targetX, arValues, 1)
  20.             If indx < UBound(arValues) Then If Abs(targetX - arValues(indx + 1)) < Abs(targetX - arValues(indx)) Then indx = indx + 1  '修正最近資料點
  21.         End If
  22.             
  23.         myVLine.Left = .SeriesCollection(1).Points(indx).Left
  24.         myTarget.Cells(1).Value = arValues(indx)
  25.         For i = 1 To .SeriesCollection.Count
  26.             With .SeriesCollection(i)
  27.                 .ApplyDataLabels Type:=xlDataLabelsShowNone
  28.                 .Points(indx).ApplyDataLabels Type:=xlDataLabelsShowValue
  29.                 .Points(indx).DataLabel.Format.Fill.ForeColor.RGB = RGB(255, 255, 0)
  30.                 arValues = .Values
  31.                 If i < myTarget.Cells.Count Then myTarget.Cells(i + 1).Value = arValues(indx)
  32.             End With
  33.         Next
  34.     End With
  35. End Sub
複製代碼
表達不清、題意不明確、沒附檔案格式、沒有討論問題的態度~~~~~~以上愛莫能助。

TOP

        靜思自在 : 人的心地是一畦田，土地沒有播下好種子，也長不出好的果實。 -
返回列表 上一主題