Excel Forum

Excel Forum (http://www.excel.web.tr/index.php)
-   Grafik Soruları (http://www.excel.web.tr/forumdisplay.php?f=169)
-   -   Grafik üzerine açıklama ekleme (http://www.excel.web.tr/showthread.php?t=63934)

nerodale@yahoo.com 12-02-2009 08:44

Grafik üzerine açıklama ekleme
 
1 Eklenti(ler)
Arkadaşlar merhaba,

Ben ekteki gibi bir grafik oluşturdum. Ve grafikte bir serinin üzerine gelindiğinde grafiğin üst kısmında oluşturduğum metin kutusunun içine başka bir alanda oluşturduğum metinlerin gelmesini istiyorum. Örneğin, eylül ayının 2008 verimlilik değerinin üstüne gelip 1 sn beklersem mouse ile grafiğin üstündeki metin kutusunda "Yeni açılan mağaza etkisi" yada "Kadro değişimi" gibi başka bir alanda oluşturduğum metinler gözüksün.. Normalde hücrelere comment eklemenin grafik üzerindeki değerlere uygulanması gibi bişey.

Bu şekilde bir kod oluşturulabilir mi? Yardımlarınız için şimdiden teşekkür ederim.

nerodale@yahoo.com 13-02-2009 11:56

Arkadaşlar makro yerine alternatif bi çözüm falan önerebilecek kimse yok mu??

Ferhat Pazarçevirdi 13-02-2009 16:37

1 Eklenti(ler)
Ekteki örnek dosyayı inceleyiniz.

Mouse imleci, açıklama barındıran bir aya ve yıla gelirse, üst taraftaki text kutusuna, daha önceden girdiğiniz not yazdırılır.

Bu olayın gerçekleşmesi için, grafiğin önceden aktif hale getirilmesi (seçilmesi) gereklidir.

Sayfa üzerine gömülmüş grafik nesneleri normal olarak Mouse_Move olayını desteklemez. Bunun için; bir class module kullanılarak, dosya açılışında, istenen grafik nesnesinin eskizi çıkarılmış ve olay bağlantısı yapılmıştır.

Class Module İsmi : Grafik_Olaylari

Kod:


Public WithEvents ChartObject As Chart
Dim lEski_a As Long
Dim lEski_b As Long
Private Sub ChartObject_MouseMove(ByVal Button As Long, ByVal Shift As Long, ByVal x As Long, ByVal y As Long)
   
    Dim IDNum As Long
    Dim VeriNoktasi As Point
    Dim rng As Range
    Dim i As Long
    Dim a As Long
    Dim b As Long
   
    ChartObject.GetChartElement x, y, IDNum, a, b
   
    If lEski_a = a And lEski_b = b Then Exit Sub
   
    If IDNum = xlSeries Then
       
        Set VeriNoktasi = ChartObject.SeriesCollection(a).Points(b)
       
        If Range("A65536").End(xlUp).Row >= 22 Then
           
            For i = 22 To Range("A65536").End(xlUp).Row
               
                If CStr(Range("A" & i)) = VeriNoktasi.Parent.Name _
                    And _
                        CStr(Range("B" & i)) = WorksheetFunction.Index(ChartObject.SeriesCollection(a).XValues, b) Then
                   
                    ChartObject.Shapes("Text Box 1").TextFrame.Characters.Text = Range("C" & i)
                   
                    Exit Sub
                End If
           
            Next i
        Else
           
            ChartObject.Shapes("Text Box 1").TextFrame.Characters.Text = ""
       
        End If
   
    Else
       
        ChartObject.Shapes("Text Box 1").TextFrame.Characters.Text = ""
   
    End If
   
    lEski_a = a
    lEsli_b = b
   
    Set VeriNoktasi = Nothing
End Sub

Private Sub Class_Terminate()
    Set ChartObject = Nothing
End Sub

Daha sonra; standart bir module sayfası ekleyerek aşağıdaki kodlar dahil edilir.

Kod:


Dim GrafikNesneSinifi As New Grafik_Olaylari
Sub Auto_Open()
    Set GrafikNesneSinifi.ChartObject = Worksheets(1).ChartObjects(1).Chart
End Sub


nerodale@yahoo.com 13-02-2009 17:30

Çok teşekkür ederim. Tam istediğim gibi bir uygulama olmuş. Kodları inceleyip düzenlemeye çalışacağım. Tekrar teşekkürler..

Levent Menteşoğlu 13-02-2009 17:37

Ferhat bey tebrik ederim çok güzel bir örnek, bu çözümü arşivime aldım. Çözümünüzü inceleyince benimde aklıma chartspace nesnesinin kullanılması geldi. Bu nesnenin direk mouse_move olayından faydalanılabilir. Bu nesnede de sorun, verileri direk excel hücrelerinden alamıyor olmasıdır. Bu konu üzerinde de ben bir çalışma yapayım. Sonuç elde edebilirsem, güzel bir arşiv elde etmiş oluruz.

Ferhat Pazarçevirdi 13-02-2009 17:50

Haklısınız Levent bey... Normal Excel sheet ve grafiklerine karşı, OWC'lerde çok daha fazla event var. Kodlama daha rahat olabilir. Bitirdiğinizde yayınlayabilirseniz, grafiklere yeni ve farklı bir bakış açısı yaratacağına eminim ...

Ben daha önce ChartSpace nesnesini sayfa üzerinde kullanmadım hiç ...

NOT : Aklıma geldi ... Microsoft'un bir tane daha Chart nesnesi vardı ... Belki o da denenebilir. Adı aklıma gelmedi kusura bakmayın. Ms Chart gibi birşeydi sanırım ..

Levent Menteşoğlu 14-02-2009 02:32

1 Eklenti(ler)
Chartspace nesnesi ile uzun uğraşılardan sonra hazırladığım dosyayı ekte sunuyorum. Dosya açıldığında aşağıdaki gibi bir uyarı mesajı alırsanız bir altta vereceğim kodu sadece bir kez çalıştırınız.

This Application is about yo initialize ActiveX controls that might be unsafe.If you trust the source of this file, select OK and the controls will be initialized using your current workspace settings.

Kod:

Sub regolustur()
Dim deg As Object
anahtar = "HKCU\Software\Microsoft\VBA\Security\LoadControlsInForms"
Set deg = CreateObject("WScript.Shell")
deg.RegWrite anahtar, 1, "REG_DWORD"
End Sub


Dosyada kullanılan kodlar aşağıdaki gibidir.
Sayfaya bir chartspace nesnesi ekledikten sonra,

Nesneye verileri, sayfadaki tablodan yükleyen prosedür için normal bir module:

Kod:

Public deg As New Spreadsheet

Sub auto_open()
deg.Range("b3:d15").Value = Sayfa1.Range("b3:d15").Value
With Sayfa1.ChartSpace1
.DataSource = deg
With .Charts(0)
.Type = chChartTypeLineMarkers
With .SeriesCollection(0)
.SetData chDimCategories, 0, "B4:B15"
.SetData chDimValues, 0, "C4:C15"
End With
With .SeriesCollection(1)
.SetData chDimCategories, 0, "B4:B15"
.SetData chDimValues, 0, "D4:D15"
End With
End With
End With
End Sub


Nesnenin mouse_move olayının çalışması ve veriler değiştiğinde güncelleme yapmak içinde sayfanın kod sayfasına:

Kod:

Private Sub ChartSpace1_MouseMove(ByVal Button As Long, ByVal Shift As Long, ByVal x As Long, ByVal y As Long)
Sayfa1.Shapes("metin").TextFrame.Characters.Text = ""
If TypeName(Sayfa1.ChartSpace1.RangeFromPoint(x, y)) <> "ChPoint" Then Exit Sub
yil = Sayfa1.ChartSpace1.RangeFromPoint(x, y).GetValue(chDimSeriesNames)
ay = Sayfa1.ChartSpace1.RangeFromPoint(x, y).GetValue(chDimCategories)
For a = 22 To [a65536].End(3).Row
If Cells(a, "a") = CDbl(yil) And Cells(a, "b") = ay Then
Sayfa1.Shapes("metin").TextFrame.Characters.Text = Cells(a, "c")
End If
Next
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [c4:d15]) Is Nothing Then Exit Sub
auto_open
End Sub


ersoyalan 14-02-2009 12:19

Ferhat hocam ve Levent hocam araya giriyorum fakat oldukça güzel çalışmalar yapmışsınız.Ellerinize sağlık aradığım bir konuydu bu vesileyle bende işimi görmüş oldum.

Teşekkür eder.

Syg,
iyi çalışmalar.
E.ALAN

1Al2Ver 24-01-2011 01:32

Hata mesajı
 
Merhaba,

Benim PC'den kaynaklanan bir eksiklikten dolayı hata almaktayım, nasıl bir düzenleme yapmalıyım ?

Teşekkür ederim.

http://img402.imageshack.us/img402/4295/hataq.png

rhombeus 24-01-2011 08:08

Gerçekten süper bir çalışma, teşekkürler...


Saat 19:24

Powered by vBulletin Version 3.7.2
Copyright ©2000 - 2017, Jelsoft Enterprises Ltd.