Resmin kaydırma çubuğunu takip etmesi

[Muhammet Okumuş]

Arkadaşlar Merhaba!
Kamera özelliğindeki resmin kaydırma çubuğu ile hareket etmesi mümkün mü? Kısacası kaydırma çubuğu nerede olursa olsun olsun, kamera özelliğinde ki resmin daima görünür olması sağlanabilir mi?

 

[Murat OSMA]

Bölmeleri Donduru kullanabilirsiniz..
Ya da bir hücreyi seçerek resmi seçtiğiniz hücrenin olduğu yerde gösterebilirsiniz...

 

[Muhammet Okumuş]

Pencereleri dondur işime yaramıyor. Görüntü, kaydırma çubuğu ile birlikte hareket etmeli.

 

[Murat OSMA]

O konuda şu an bir bilgim yok...

 

[Murat OSMA]

Fareyi takip eden yazı mantığıyla olabilir..

Module içerisine;

Global dur As Boolean
Global sht As Worksheet
Global FareXY As PointApi
Global xfare, yfare As Integer
Public x As Integer


Type PointApi
x As Long
y As Long
End Type

Type RECT
         Left As Long
         Top As Long
         Right As Long
         Bottom As Long
End Type

Declare Function GetCursorPos Lib "user32" (lpPoint As PointApi) As Long
Public Const SPI_GETWORKAREA& = 48
Public Declare Function SystemParametersInfo Lib "user32" Alias _
         "SystemParametersInfoA" (ByVal uAction As Long, _
         ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long

Sub auto_open()
islem
End Sub

    
Sub islem()
Dim diz As Long, lbl As Object, z As String
Dim rct As RECT
Dim zz As Long

Static FareX, FareY
zz = SystemParametersInfo(SPI_GETWORKAREA, 0&, rct, 0&)

Do
If dur Then dur = False: Exit Sub
z = GetCursorPos(FareXY)
If FareX <> FareXY.x Or FareY <> FareXY.y Then
diz = 10
Set sht = ThisWorkbook.Sheets(1)
    For Each lbl In sht.Shapes
        If lbl.Name <> "Emre" Then
           With lbl
            .Top = FareXY.y * Application.Height / rct.Bottom - 150
            .Left = FareXY.x * Application.Width / rct.Right + diz - 2
            diz = diz + 7
           End With
        End If
    Next
FareX = FareXY.x
FareY = FareXY.y
End If
DoEvents
Loop
End Sub

ThisWorkbook kısmına da;

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    dur = True
End Sub

 

[Muhammet Okumuş]

Sn Murat Bey dediğiniz işlemleri yaptım ama olmadı.

 

[Murat OSMA]

Dosyayı dener misiniz ?

 

[Muhammet Okumuş]

Sn Murat Bey teşekkür ederim ama mouse bağlamak pek kullanışlı olmayacak. Mouse yerine kaydırma çubuğu olmalı. Ben araştırmam sonucu aktif satıra bağladım.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim ws As Worksheet
Dim rng As Range
Set ws = Sheets("Sayfa1")
x = ActiveWindow.ScrollRow

Set rng = ws.Range("B" & x)

With ws.Shapes("Picture 1")
.LockAspectRatio = msoFalse
.Top = rng.Top
.Left = rng.Left

End With
End Sub

bu kodu kaydırma çubuğuna bağlayabilirmiyiz?

 

[ikikan]

Kolay gelsin arkadaşlar bu kodu çözüldümü kaydırma çubuguna bağlıya bildinizmi?

Sn Murat Bey teşekkür ederim ama mouse bağlamak pek kullanışlı olmayacak. Mouse yerine kaydırma çubuğu olmalı. Ben araştırmam sonucu aktif satıra bağladım.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim ws As Worksheet
Dim rng As Range
Set ws = Sheets("Sayfa1")
x = ActiveWindow.ScrollRow

Set rng = ws.Range("B" & x)

With ws.Shapes("Picture 1")
.LockAspectRatio = msoFalse
.Top = rng.Top
.Left = rng.Left

End With
End Sub

bu kodu kaydırma çubuğuna bağlayabilirmiyiz?

 

[halit3]

Alternatif kod

Resim imleçle beraber gidiyor

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
ekle1 = 1
ekle2 = 4
If Target.Column = Columns.Count Then ekle1 = 0
If Target.Row = Rows.Count Then ekle2 = 0
adres1 = ActiveWindow.RangeSelection.Address
adres2 = Len(adres1)
a = InStr(Trim(adres1), ":") - 1
If a = -1 Then
ActiveSheet.Shapes("Resim 1").Top = Cells(Target.Row + ekle2, Target.Column + ekle1).Rows.Top
ActiveSheet.Shapes("Resim 1").Left = Cells(Target.Row + ekle2, Target.Column + ekle1).Rows.Left
ActiveSheet.Shapes("Resim 1").Height = 70
ActiveSheet.Shapes("Resim 1").Width = 120
Exit Sub
End If
If Len(Replace(Mid(adres1, 1, a), "$", "")) = 1 Then Exit Sub
If IsNumeric(Mid(Replace(Mid(adres1, 1, a), "$", ""), 1, 1)) = True Then Exit Sub
son1 = Range(Mid(adres1, a + 2, adres2 - a)).Row + ekle2
son2 = Range(Mid(adres1, a + 2, adres2 - a)).Column + ekle1
ActiveSheet.Shapes("Resim 1").Top = Cells(son1, son2).Rows.Top
ActiveSheet.Shapes("Resim 1").Left = Cells(son1, son2).Rows.Left
ActiveSheet.Shapes("Resim 1").Height = 70
ActiveSheet.Shapes("Resim 1").Width = 120
End Sub

 

[ikikan]

Çok Denedim farkli bir kod fakat ScrollRow bağlamak mümkün gözükmüyor, bence.
Halit ve Murat beyin verdiği kodlarda ise mausa bağımlı kalınıyor.
Aslında mausun Scroll una bağlana bilse gayet güzel olurdu .

Altarnetif kod:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
f = ActiveWindow.ScrollRow
Y = Sheets("HES").Range("A" & f).RowHeight
X = ActiveWindow.ScrollRow
Z = Y * X
G = Z + ActiveSheet.Shapes("ListBox1").Height

If ActiveWindow.ScrollRow = X Then
Sheets("HES").ListBox1.Top = Z
ActiveSheet.Shapes("Grup 3").Top = G

End If
End Sub