AccessTr.neT

Bul · 19/05/2020, 10:43

ellerinze sağlık çok güel olmuş
keşke form metin kutusunun hemen altında açılsa idi

Bul · 19/05/2020, 19:09

🔍konusundaki örnekte kullanılmış kodları çalışmanıza ekleyebilirsiniz. Oradan modülü alıp en altta yer alan 2 değişikliği yapmanız yeterli
Önce bir Modül ekleyin
Modül Kodu:

Option Compare Database
Option Explicit
'DEVELOPED AND TESTED UNDER MICROSOFT Access 97 and 2K VBA
'
'Copyright: Stephen Lebans - Lebans Holdings 1999 Ltd.  www.lebans.com
'           You may use this code in your own private or commercial applications
'           without cost. Simply leave this copyright notice in the source code.
'           You may not sell htis code by itself or as part of a collection.
'Name:      PositionFormRelativeToControl
'Version:   1.5
'Purpose:   To allow you to open a second form relative to a control on the parent form.
'Author:    Stephen Lebans
'Email:     Stephen@lebans.com
'
'Web Site:  www.lebans.com

Private Type POINTAPI
  X As Long
  Y As Long
End Type

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

Private Declare PtrSafe Function GetSystemMetrics Lib "user32" _
(ByVal nIndex As Long) As Long

Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long

Private Declare PtrSafe Function GetClientRect Lib "user32" _
(ByVal hwnd As Long, lpRect As RECT) As Long
    
Private Declare PtrSafe Function GetWindowRect Lib "user32" _
(ByVal hwnd As Long, lpRect As RECT) As Long

Private Declare PtrSafe Function ClientToScreen Lib "user32" _
(ByVal hwnd As Long, lpPoint As POINTAPI) As Long

Private Declare PtrSafe Function ScreenToClient Lib "user32" _
(ByVal hwnd As Long, lpPoint As POINTAPI) As Long

Private Declare PtrSafe Function GetDesktopWindow Lib "user32" () As Long

Private Declare PtrSafe Function apiGetWindowLong Lib "user32" _
  Alias "GetWindowLongA" _
  (ByVal hwnd As Long, _
  ByVal nIndex As Long) As Long

Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As Long) As Long

Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long

Private Declare PtrSafe Function apiGetDeviceCaps Lib "gdi32" _
Alias "GetDeviceCaps" (ByVal hDC As Long, ByVal nIndex As Long) As Long

Private Declare PtrSafe Function ReleaseDC Lib "user32" _
(ByVal hwnd As Long, ByVal hDC As Long) As Long


Private Declare PtrSafe Function SendMessage Lib "user32" _
Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long

Private Declare PtrSafe Function apiGetWindow Lib "user32" _
Alias "GetWindow" _
(ByVal hwnd As Long, _
ByVal wCmd As Long) _
As Long

Private Declare PtrSafe Function apiGetClassName Lib "user32" _
Alias "GetClassNameA" _
(ByVal hwnd As Long, _
ByVal lpClassName As String, _
ByVal nMaxCount As Long) _
As Long
    
Private Declare PtrSafe Function FindWindowEx Lib "user32" _
Alias "FindWindowExA" (ByVal hwnd1 As Long, ByVal hwnd2 As Long, _
ByVal lpsz1 As String, ByVal lpsz2 As String) As Long

Private Declare PtrSafe Function SetWindowPos Lib "user32" _
(ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, _
ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long


' Window Styles
Private Const WS_OVERLAPPED = &H0&
Private Const WS_POPUP = &H80000000
Private Const WS_CHILD = &H40000000
Private Const WS_MINIMIZE = &H20000000
Private Const WS_VISIBLE = &H10000000
Private Const WS_DISABLED = &H8000000
Private Const WS_CLIPSIBLINGS = &H4000000
Private Const WS_CLIPCHILDREN = &H2000000
Private Const WS_MAXIMIZE = &H1000000
Private Const WS_CAPTION = &HC00000                  '  WS_BORDER Or WS_DLGFRAME
Private Const WS_BORDER = &H800000
Private Const WS_DLGFRAME = &H400000
Private Const WS_VSCROLL = &H200000
Private Const WS_HSCROLL = &H100000
Private Const WS_SYSMENU = &H80000
Private Const WS_THICKFRAME = &H40000
Private Const WS_GROUP = &H20000
Private Const WS_TABSTOP = &H10000

Private Const WS_MINIMIZEBOX = &H20000
Private Const WS_MAXIMIZEBOX = &H10000

Private Const WS_TILED = WS_OVERLAPPED
Private Const WS_ICONIC = WS_MINIMIZE
Private Const WS_SIZEBOX = WS_THICKFRAME
Private Const WS_OVERLAPPEDWINDOW = (WS_OVERLAPPED Or WS_CAPTION Or WS_SYSMENU Or WS_THICKFRAME Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX)
Private Const WS_TILEDWINDOW = WS_OVERLAPPEDWINDOW

Private Const WS_POPUPWINDOW = (WS_POPUP Or WS_BORDER Or WS_SYSMENU)
Private Const WS_CHILDWINDOW = (WS_CHILD)

' Extended Window Styles
Private Const WS_EX_DLGMODALFRAME = &H1&
Private Const WS_EX_NOPARENTNOTIFY = &H4&
Private Const WS_EX_TOPMOST = &H8&
Private Const WS_EX_ACCEPTFILES = &H10&
Private Const WS_EX_TRANSPARENT = &H20&

' GetWindow() Constants
Private Const GW_HWNDFIRST = 0
Private Const GW_HWNDLAST = 1
Private Const GW_HWNDNEXT = 2
Private Const GW_HWNDPREV = 3
Private Const GW_OWNER = 4
Private Const GW_CHILD = 5
Private Const GW_MAX = 5


' App instance
Private Const GWL_HINSTANCE = (-6)
Private Const GWL_STYLE = (-16)
' Twips per inch
Private Const TWIPSPERINCH = 1440&

'  Device Parameters for GetDeviceCaps()
Private Const LOGPIXELSX = 88        '  Logical pixels/inch in X
Private Const LOGPIXELSY = 90        '  Logical pixels/inch in Y
Private Const BITSPIXEL = 12         '  Number of bits per pixel

Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1
Private Const SM_CXVSCROLL = 2
Private Const SM_CYHSCROLL = 3
Private Const SM_CXBORDER = 5
Private Const SM_CYBORDER = 6

' SetWindowPos Flags
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOZORDER = &H4
Private Const SWP_NOREDRAW = &H8
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_FRAMECHANGED = &H20        '  The frame changed: send WM_NCCALCSIZE
Private Const SWP_SHOWWINDOW = &H40
Private Const SWP_HIDEWINDOW = &H80
Private Const SWP_NOCOPYBITS = &H100
Private Const SWP_NOOWNERZORDER = &H200      '  Don't do owner Z ordering

Private Const SWP_DRAWFRAME = SWP_FRAMECHANGED
Private Const SWP_NOREPOSITION = SWP_NOOWNERZORDER

' SetWindowPos() hWndInsertAfter values
Private Const HWND_TOP = 0
Private Const HWND_BOTTOM = 1
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
Private Const TITLE = ""

' Horizontal and Vertical Screen resolution
Private m_ScreenXdpi As Long
Private m_ScreenYdpi As Long

' Junk return vars
Private lRet As Long

Public Function PositionFormRelativeToControl(frmName As String, ctl As Access.Control, Optional Position As Long = 0) As Boolean
Position:
' 0 = Underneath
' 1 = On Top
' 2 = Right side
' 3 = Left side
' 4 = Bottom Right Hand Corner

' Window handle to our Form's Detail Section
Dim m_hWndSection As Long

' Form we will position under the control
Dim frm As Access.Form

' Access MDI document window
Dim hWndMDI As Long
' MDI borders
Dim MDIborderX As Long
Dim MDIborderY As Long

' For positioning window
Dim rc As RECT
Dim rcWin As RECT
Dim pt As POINTAPI
Dim lOffsetX As Long, lOffsetY As Long

' Screen dimensions
Dim m_ScreenWidth As Long
Dim m_ScreenHeight As Long

' Window Style var
Dim lStyle As Long

' Since we are turning off screen redraw ignore all errors
 On Error Resume Next
 
' Turn off redraw
' Leave this alone util you are done debugging
'Application.Echo False

' Open the Form
DoCmd.OpenForm frmName
' Does form exist?
Set frm = Forms.Item(frmName)

If Not frm Is Nothing Then
         
    ' Get the Window handle for the form Section containing this control
    m_hWndSection = fFindSectionhWnd(ctl)
    ' Calculate the LEFT offset for this control from the edge of the Section
    ' First calc our screen resolution
    GetScreenDPI
    ' Now get our screen dimensions
    m_ScreenWidth = GetSystemMetrics(SM_CXSCREEN)
    m_ScreenHeight = GetSystemMetrics(SM_CYSCREEN)
    
    Select Case Position
        
        Case 0
        lOffsetX = ctl.Left / (TWIPSPERINCH / m_ScreenXdpi)
        lOffsetY = (ctl.Top + ctl.Height) / (TWIPSPERINCH / m_ScreenYdpi)
        
        Case 1
        lOffsetX = ctl.Left / (TWIPSPERINCH / m_ScreenXdpi)
        lOffsetY = (-frm.WindowHeight + ctl.Top) / (TWIPSPERINCH / m_ScreenYdpi)
        
        Case 2
        lOffsetX = (ctl.Left + ctl.Width) / (TWIPSPERINCH / m_ScreenXdpi)
        lOffsetY = (ctl.Top) / (TWIPSPERINCH / m_ScreenYdpi)
        
        Case 3
        ' Nov-2004 Logic error
        ' Must use Form's width NOT COntrol's width
        'lOffsetX = (ctl.Left - ctl.Width) / (TWIPSPERINCH / m_ScreenXdpi)
        lOffsetX = (ctl.Left - frm.WindowWidth) / (TWIPSPERINCH / m_ScreenXdpi)
        lOffsetY = (ctl.Top) / (TWIPSPERINCH / m_ScreenYdpi)
        
        Case 4
        lOffsetX = (ctl.Left + ctl.Width) / (TWIPSPERINCH / m_ScreenXdpi)
        lOffsetY = (ctl.Top + ctl.Height) / (TWIPSPERINCH / m_ScreenYdpi)
        
        Case Else
        ' Default to Underneath
        lOffsetX = ctl.Left / (TWIPSPERINCH / m_ScreenXdpi)
        lOffsetY = (ctl.Top + ctl.Height) / (TWIPSPERINCH / m_ScreenYdpi)
        
    End Select
        
    ' Get window rectangle of the Section
    lRet = GetWindowRect(m_hWndSection, rc)
    ' Add in offsets for the calling control
    pt.X = lOffsetX + rc.Left&
    pt.Y = lOffsetY + rc.Top
    
    ' Bounds checking to ensure form will be completely visible on screen
    
    lRet = GetWindowRect(frm.hwnd, rcWin)
    
    With rcWin
        If m_ScreenWidth - pt.X < .Right - .Left Then
                pt.X = m_ScreenWidth - (.Right - .Left)
        ElseIf pt.X < 2 Then 'm_S
                pt.X = 2
        End If
            
        If m_ScreenHeight - pt.Y < .Bottom - .Top Then
            pt.Y = m_ScreenHeight - (.Bottom - .Top)
        ElseIf pt.Y < 2 Then
            pt.Y = 2
        End If
        
    End With
        
        
    ' If the Form's POPUP property is True then skip the
    ' ScreenToClient stuff
    If Not frm.PopUp = True Then
        
        ' find MDIClient window
        hWndMDI = FindWindowEx(Application.hWndAccessApp, 0&, "MDIClient", TITLE)
        ' COnvert to Client coordinates of our MDI window
        lRet = ScreenToClient(hWndMDI, pt)
        ' We have to subtract our MDI window's Border
        lRet = GetWindowRect(hWndMDI, rcWin)
        lRet = GetClientRect(hWndMDI, rc)
        MDIborderX = ((rcWin.Right - rcWin.Left) - (rc.Right - rc.Left))
        MDIborderY = ((rcWin.Bottom - rcWin.Top) - (rc.Bottom - rc.Top))
        
        ' See if ScrollBar is visible in the MDI window
        lStyle = GetWindowLong(hWndMDI, GWL_STYLE)
        
        If lStyle And WS_HSCROLL Then
            MDIborderY = MDIborderY - GetSystemMetrics(SM_CYHSCROLL)
        End If
        
        If lStyle And WS_VSCROLL Then
            MDIborderX = MDIborderX - GetSystemMetrics(SM_CXVSCROLL)
        End If
        ' Remainder is our Border thickness
        MDIborderX = MDIborderX / 2
        MDIborderY = MDIborderY / 2
    Else
        ' POPUP = True
        ' We need to subtract the Border thickness of the main Access Aplication Window
        MDIborderX = GetSystemMetrics(SM_CXBORDER)
        MDIborderY = GetSystemMetrics(SM_CYBORDER)
    End If
    
    ' Position our Form underneath of the calling control
    Call SetWindowPos(frm.hwnd, 0&, pt.X - MDIborderX, pt.Y - MDIborderY, 0, 0, SWP_NOSIZE)
    
End If

' Turn on redraw
'Application.Echo True
 ' Cleanup
Set frm = Nothing

' Return Success
PositionFormRelativeToControl = True

End Function

Private Sub GetScreenDPI()
Dim lngDC As Long

' Grab any DC
lngDC = GetDC(0)
'Horizontal
m_ScreenXdpi = apiGetDeviceCaps(lngDC, LOGPIXELSX)
'Vertical
m_ScreenYdpi = apiGetDeviceCaps(lngDC, LOGPIXELSY)

lngDC = ReleaseDC(0, lngDC)
End Sub

Private Function fFindSectionhWnd(ctl As Access.Control) As Long
On Error GoTo Err_fFindSectionhWnd
    ' Get ListBox's hWnd
    Dim hWnd_LSB As Long
    Dim hWnd_Temp As Long
    
    ' Window RECT vars
    Dim rc As RECT
    Dim pt As POINTAPI
    
    ' Loop Counters
    Dim SectionCounter As Long
    Dim ctr As Long

     ' Which Section contains the Control?
     Select Case ctl.Section
         Case acDetail   '0
             SectionCounter = 2
         Case acHeader   '1
             SectionCounter = 1
         Case acFooter   '2
             SectionCounter = 3
         Case Else
             '  ****   NEED ERROR HANDLING! ****
     End Select
     
    ' Setup SectionCounter
    ' Form Header, Detail and then Footer
    ctr = 1

    ' Nov -2004 - Modification by Onno Willems
    ' Let's get first Child Window of the FORM
    If TypeOf ctl.Parent Is Access.Page Then
        ' If the control is on a page on a tab, we can't get a window handle
        If TypeOf ctl.Parent.Parent Is Access.TabControl Then
            ' As expected, the page is on a tab
            If TypeOf ctl.Parent.Parent.Parent Is Access.Form Then
                ' And the parent of the tab is the form we wanted
                hWnd_LSB = apiGetWindow(ctl.Parent.Parent.Parent.hwnd, GW_CHILD)
            End If
        End If
    Else
        ' Normal control directly on form
        hWnd_LSB = apiGetWindow(ctl.Parent.hwnd, GW_CHILD)
    End If
    
    ' Let's walk through every sibling window of the Form
    Do
        If fGetClassName(hWnd_LSB) = "OFormSub" Then
            ' First OFormSub is the Form's Header. We want the next next one
            ' which is the detail section
            If ctr = SectionCounter Then
                fFindSectionhWnd = hWnd_LSB
                Exit Function
            End If
               
             ' Increment our Section Counter
            ctr = ctr + 1
            
        End If
    
        ' Let's get the NEXT SIBLING Window
        hWnd_LSB = apiGetWindow(hWnd_LSB, GW_HWNDNEXT)
    
        ' Let's Start the process from the Top again
        ' Really just an error check
    Loop While hWnd_LSB <> 0
    
    ' SORRY - NO ListBox hWnd is available
    fFindSectionhWnd = 0
    
Exit_fFindSectionhWnd:
    Exit Function

Err_fFindSectionhWnd:
    MsgBox Err.Description
    Resume Exit_fFindSectionhWnd
    
End Function

' From Dev Ashish's Site
' The Access Web
' http://www.mvps.org/access/


Private Function fGetClassName(hwnd As Long)
Dim strBuffer As String
Dim lngLen As Long
Const MAX_LEN = 255
    strBuffer = Space$(MAX_LEN)
    lngLen = apiGetClassName(hwnd, strBuffer, MAX_LEN)
    If lngLen > 0 Then fGetClassName = Left$(strBuffer, lngLen)
End Function

saat24 foermundaki SeciliZaman fonksiyonu

Function SeciliZaman(Optional Target_Control As Object) As String
      Set txtbox = Target_Control           
End Function

Form1'deki Metin0_ÇiftTık olayı

Private Sub Metin0_DblClick(Cancel As Integer)
Dim blRet As Boolean '<--eklenen
blRet = PositionFormRelativeToControl("saat24", Me.ActiveControl) '<--eklenen
 
    Call Form_Saat24.SeciliZaman(Me.ActiveControl)
End Sub

Bul · 20/05/2020, 01:08

Alıntı:ellerinze sağlık çok güel olmuşkeşke form metin kutusunun hemen altında açılsa idi

sizi ibretle izliyorum, bukadar zaman, bukadar konu ve mesaj..... pes.

Alıntı:Oradan modülü alıp en altta yer alan 2 değişikliği yapmanız yeterliÖnce bir Modül ekleyin

tahmin edeyim yapamayacak, sayin @berduş, @ozanakkaya ve @feraz bilginize, sabriniza ve emeginize hayranim, bence forumda sorusu cevap bekleyen, ogrenmeye ac uyelere yonelin. Bu kadar emeginize yazik bunlar nerede kullanılacak textbox a 22:18 yazmak bu kadar mi zor.

Bul · 20/05/2020, 01:37

"22:18 yazmak bukadarmi zor" derken bu dediğiniz ölçü birimi nedir
Neye kıyasla zor veya kolay diye belirliyorsunuz
Benim için mouse u bırakıp tek harf için klavyeyi kullanmak zor mesela
Birilerine bir şeyler zor gelmeseydi hala taş devrinde olurduk
Birde burada paylaşılan çözülen soruların tek kişi için olduğunu zanneden birileri var
Zannediyorlar ki bu sadece soruyu soranın işine yarayacak
Çok ilginç anlamakta zorluk çekiyorum
Ama yinede zahmet edip ilgi duyup yazmışsınız teşekkürler

Bul · 20/05/2020, 02:11

Birisi şöyle demiş "bunlar nerede kullanılacak"
Bana Rutherford B. Hayes' in(ABD Başkanı). 1876 yılında ilk telefonu gördükten sonra yaptığı yorumu hatırlattı
Vizyon meselesi

Bul · 20/05/2020, 02:19

Ben daha bu saat be işe yarar anlamadım.Zaten içteki ve dıştaki rakamlar yer değişmeli sanki.

Accessman hocamız accessi yavaşlatmak için elinden geleni yapıyor bence.ilk önce heralde dünya saatleri uygulaması yapacak sandım Img-grin

AccessTr.neT

Analog Timepicker

Analog Timepicker

Bir hesap oluşturun veya yorum yapmak için giriş yapın

Giriş yap

Hesap oluştur

Konu Linkleri