By using this site, you agree to our updated Privacy Policy and our Terms of Use. Manage your Cookies Settings.
460,030 Members | 1,207 Online
Bytes IT Community
+ Ask a Question
Need help? Post your question and get tips & solutions from a community of 460,030 IT Pros & Developers. It's quick & easy.

Determining a form's actual location (when it is not current)

P: n/a
Greetings.

I am trying to position opened forms so that they are cascaded on the
screen. I have discovered the movesize action (for the DoCmd) and Move
property of a form (for Acc 2002/2003). However, if the application is
opened up on different monitors (e.g.; 17" or 19"), the relative
location of the opened form is not the same (i.e.; on the bigger monitor
the opened form is too far over to the right and too high).

What I want to do is ...

When the subsequent (or second) form is opened up I would like to find
the absolute location of the first form (always centered). This way I
will be able to reposition the second and third forms relative to the
first form.

Is this possible?

I'm having trouble referencing the first form from within the second
form. The first form is still open, but they are not linked forms (not
parent/child). I've tried:

forms("firstformname").left
forms("firstformname").top

but this does not work.

I've gone to online help and I've looked around in the newsgroups. But
can't find any info. Anybody out there will suggestions?

Regards,
SueB

*** Sent via Developersdex http://www.developersdex.com ***
Nov 13 '05 #1
Share this Question
Share on Google+
1 Reply


P: n/a
Within this code are procedures which will do what you want. The code
does many other things and I have posted it all, not extracted the
pertinent parts.

FormPlacement places the form in the area of the screen most "open"
with respect to the control used to open the form. You can change this
object, and change the logic of the form placement to effect a
cascading effect.

I'm aware that some of the API calls here are now redundant, but this
code goes back 7 or 8 years.

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 Type Dimensions
Width As Long
Height As Long
End Type

Private Declare Function GetCursorPos Lib "user32" (lpPoint As
POINTAPI) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As
Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long,
ByVal nIndex As Long) As Long
Private Declare Function GetFocus Lib "user32" () As Long
Private Declare Function GetQueueStatus Lib "user32" (ByVal fuFlags As
Long) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As
Long) As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Declare Function GetUserName Lib "advapi32.dll" Alias
"GetUserNameA" (ByVal lps As String, nSize As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias
"GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As
Long, lpRect As Rect) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long,
ByVal hdc As Long) As Long
Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long,
ByVal y As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias
"SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal
dwNewLong As Long) As Long
Private Declare 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

Private Const GWL_STYLE = (-16)
Private Const QS_MOUSEBUTTON = &H4
Private Const QS_MOUSEMOVE = &H2
Private Const SM_CXBORDER = 5
Private Const SM_CXSCREEN = 0
Private Const SM_CYBORDER = 6
Private Const SM_CYSCREEN = 1
Private Const SWP_NOZORDER = &H4
Private Const WS_SYSMENU = &H80000
Private Const LOGPIXELSY = 90
Private Const LOGPIXELSX = 88

Private Const DefaultCrementInterval As Single = 0.5

Dim mCallingControl As Control
Dim mCallingForm As Form
Dim mCrementInterval As Double
Dim mCrementIntervalPropertyName As String
Dim mCurrentControl As Control
Dim mAccessForm As AccessObject
Dim mDtmDate As Date
Dim mMaxBottom As Single
Dim mMinTop As Single
Dim mMoveSpeedControl As Boolean
Dim mPixelsPerTwipHorizontalFactor As Single
Dim mPixelsPerTwipVerticalFactor As Single
Dim mPreviousControl As Control
Dim mUndoDate As Date

Private Function CloseForm()
DoCmd.Close acForm, Me.Name
End Function

Private Sub Form_Draw()
Dim sCtl As Control
Dim sDtmDate As Date
Dim sDtmStartDate As Date
Dim sIntCounter As Integer
Dim sIntMonth As Integer

With Me
.Caption = Format(mDtmDate, "mmm yyyy")
.Painting = False
End With

sIntMonth = Month(mDtmDate)
sDtmStartDate = DateSerial(Year(mDtmDate), Month(mDtmDate), 1)
sDtmStartDate = sDtmStartDate - WeekDay(sDtmStartDate) + 1

For sIntCounter = 1 To 7
Set sCtl = Me.Controls("Label" & sIntCounter)
sCtl.Caption = Format(sIntCounter, "ddd")
Next sIntCounter

For sIntCounter = 8 To 49
sDtmDate = sDtmStartDate + sIntCounter - 8
Set sCtl = Me.Controls("Label" & sIntCounter)
With sCtl
.Caption = Format(sDtmDate, "d")
.Tag = sDtmDate

Select Case sDtmDate
Case VBA.Date
.ForeColor = vbRed
Case Else
If Month(sDtmDate) = sIntMonth Then
.ForeColor = vbBlack
Else
.ForeColor = vbWhite / 3
End If
End Select

If sDtmDate = mDtmDate Then
Set mCurrentControl = sCtl
Set mPreviousControl = sCtl
End If

.FontBold = (sDtmDate = mDtmDate) Or (sDtmDate = Date)

End With

Next sIntCounter

YearBackBlue.Tag = DateAdd("yyyy", -1, mDtmDate)
MonthBackBlue.Tag = DateAdd("m", -1, mDtmDate)
TodayBlue.Tag = VBA.Date
MonthForwardBlue.Tag = DateAdd("m", 1, mDtmDate)
YearForwardBlue.Tag = DateAdd("yyyy", 1, mDtmDate)

Me.Painting = True
End Sub

Private Sub Form_Close()
Set mCallingControl = Nothing
Set mCallingForm = Nothing
Set mCurrentControl = Nothing
Set mPreviousControl = Nothing
End Sub

Private Sub Form_Load()
Dim b As Long
Dim z As Long

For z = 1 To 7
Me.Controls("Label" & CStr(z)).Caption = Left(Format(z, "ddd"),
2)
Next z

With DoCmd
.Restore
.RunCommand acCmdSizeToFitForm
End With

b = GetSystemMetrics(SM_CYBORDER) / mPixelsPerTwipVerticalFactor
mMaxBottom = lblSpeedBar.Top + lblSpeedBar.Height -
lblSpeedControl.Height - b
mMinTop = lblSpeedBar.Top + 2 * b
lblSpeedControl.Top = mCrementInterval * mMaxBottom
SpeedControlColor

On Error GoTo NoDateAvailable
mDtmDate = mCallingControl.Value
ExitLoad:
mUndoDate = mDtmDate
RevertBlue.Tag = mUndoDate
Form_Draw
Exit Sub

NoDateAvailable:
mDtmDate = VBA.Date
On Error GoTo 0
Resume ExitLoad
End Sub

Private Sub Form_Open(Cancel As Integer)
Dim MeWindow As Long
Dim WindowStyleInformation As Long

MeWindow = Me.hwnd

PixelsPerTwipFactors

WindowStyleInformation = GetWindowLong(MeWindow, GWL_STYLE)
SetWindowLong MeWindow, GWL_STYLE, WindowStyleInformation And Not
WS_SYSMENU

On Error Resume Next
With Application.Screen
Set mCallingControl = .ActiveControl
Set mCallingForm = .ActiveForm
End With
If Not mCallingControl Is Nothing Then
FormPlacement mCallingControl
End If

On Error GoTo 0
Set mAccessForm = CurrentProject.AllForms(Me.Name)
mCrementIntervalPropertyName = UserName() & "CrementLevel"
GetCrementInterval
End Sub

Private Sub FormPlacement(ByRef ctl As Control)
Dim ctlRect As Rect
Dim frmDimensions As Dimensions
Dim frmRect As Rect
Dim scrDimensions As Dimensions

ctlRect = ControlRect(ctl)
frmDimensions = FormDimensions()
scrDimensions.Width = GetSystemMetrics(SM_CXSCREEN)
scrDimensions.Height = GetSystemMetrics(SM_CYSCREEN)
If (scrDimensions.Width - ctlRect.Right) > ctlRect.Left Then
frmRect.Left = ctlRect.Right + 2
Else
frmRect.Left = ctlRect.Left - frmDimensions.Width - 2
End If
If (scrDimensions.Height - ctlRect.Bottom) > ctlRect.Top Then
frmRect.Top = ctlRect.Top
Else
frmRect.Top = ctlRect.Bottom - frmDimensions.Height
End If
SetWindowPos Me.hwnd, 0, frmRect.Left, frmRect.Top, _
frmDimensions.Width, frmDimensions.Height, SWP_NOZORDER
Me.Visible = True
End Sub

Private Function ControlRect(ctl As Control) As Rect
ctl.SetFocus
GetWindowRect GetFocus(), ControlRect
End Function

Private Function FormDimensions() As Dimensions
Dim frmRect As Rect
GetWindowRect Me.hwnd, frmRect
FormDimensions.Width = frmRect.Right - frmRect.Left
FormDimensions.Height = frmRect.Bottom - frmRect.Top
End Function

Private Sub HiLite(ByRef AffectedControl As Control)
Static PreviousControl As Control
Dim MirrorControl As Control
On Error Resume Next
If PreviousControl Is Nothing Then
Set PreviousControl = mPreviousControl
End If
If PreviousControl.Name <> AffectedControl.Name Then
If IsDate(AffectedControl.Tag) Then
mCallingControl.Value = AffectedControl.Tag
Else
mCallingControl.Value = Null
End If
If PreviousControl.ControlType = acLabel Then
With PreviousControl
.FontBold = (DateValue(.Tag) = Date)
End With
Else
PreviousControl.Visible = True
Me.Controls(PreviousControl.Name & "Blue").Visible = False
End If
If AffectedControl.ControlType = acLabel Then
AffectedControl.FontBold = True
Set PreviousControl = AffectedControl
Else
Set MirrorControl = Me.Controls(Left(AffectedControl.Name,
Len(AffectedControl.Name) - 4))
MirrorControl.Visible = False
AffectedControl.Visible = True
AffectedControl.SetFocus
Set PreviousControl = MirrorControl
End If
End If
End Sub

Private Sub Form_Timer()
Dim p As AccessObjectProperty
On Error Resume Next
For Each p In mAccessForm.Properties
With p
If Right(.Name, 11) = "CrementName" And DateDiff("m",
VBA.Date(), .Value) > 1 Then
mAccessForm.Properties.Remove .Name
End If
End With
Next p
Me.TimerInterval = 0
End Sub

Private Sub Label8_MouseMove(Button As Integer, Shift As Integer, x As
Single, y As Single)
HiLite Me.Label8
End Sub

Private Sub Label9_MouseMove(Button As Integer, Shift As Integer, x As
Single, y As Single)
HiLite Me.Label9
End Sub

Private Sub Label10_MouseMove(Button As Integer, Shift As Integer, x As
Single, y As Single)
HiLite Me.Label10
End Sub

Private Sub Label11_MouseMove(Button As Integer, Shift As Integer, x As
Single, y As Single)
HiLite Me.Label11
End Sub

Private Sub Label12_MouseMove(Button As Integer, Shift As Integer, x As
Single, y As Single)
HiLite Me.Label12
End Sub

Private Sub Label13_MouseMove(Button As Integer, Shift As Integer, x As
Single, y As Single)
HiLite Me.Label13
End Sub

Private Sub Label14_MouseMove(Button As Integer, Shift As Integer, x As
Single, y As Single)
HiLite Me.Label14
End Sub

Private Sub Label15_MouseMove(Button As Integer, Shift As Integer, x As
Single, y As Single)
HiLite Me.Label15
End Sub

Private Sub Label16_MouseMove(Button As Integer, Shift As Integer, x As
Single, y As Single)
HiLite Me.Label16
End Sub

Private Sub Label17_MouseMove(Button As Integer, Shift As Integer, x As
Single, y As Single)
HiLite Me.Label17
End Sub

Private Sub Label18_MouseMove(Button As Integer, Shift As Integer, x As
Single, y As Single)
HiLite Me.Label18
End Sub

Private Sub Label19_MouseMove(Button As Integer, Shift As Integer, x As
Single, y As Single)
HiLite Me.Label19
End Sub

Private Sub Label20_MouseMove(Button As Integer, Shift As Integer, x As
Single, y As Single)
HiLite Me.Label20
End Sub

Private Sub Label21_MouseMove(Button As Integer, Shift As Integer, x As
Single, y As Single)
HiLite Me.Label21
End Sub

Private Sub Label22_MouseMove(Button As Integer, Shift As Integer, x As
Single, y As Single)
HiLite Me.Label22
End Sub

Private Sub Label23_MouseMove(Button As Integer, Shift As Integer, x As
Single, y As Single)
HiLite Me.Label23
End Sub

Private Sub Label24_MouseMove(Button As Integer, Shift As Integer, x As
Single, y As Single)
HiLite Me.Label24
End Sub

Private Sub Label25_MouseMove(Button As Integer, Shift As Integer, x As
Single, y As Single)
HiLite Me.Label25
End Sub

Private Sub Label26_MouseMove(Button As Integer, Shift As Integer, x As
Single, y As Single)
HiLite Me.Label26
End Sub

Private Sub Label27_MouseMove(Button As Integer, Shift As Integer, x As
Single, y As Single)
HiLite Me.Label27
End Sub

Private Sub Label28_MouseMove(Button As Integer, Shift As Integer, x As
Single, y As Single)
HiLite Me.Label28
End Sub

Private Sub Label29_MouseMove(Button As Integer, Shift As Integer, x As
Single, y As Single)
HiLite Me.Label29
End Sub

Private Sub Label30_MouseMove(Button As Integer, Shift As Integer, x As
Single, y As Single)
HiLite Me.Label30
End Sub

Private Sub Label31_MouseMove(Button As Integer, Shift As Integer, x As
Single, y As Single)
HiLite Me.Label31
End Sub

Private Sub Label32_MouseMove(Button As Integer, Shift As Integer, x As
Single, y As Single)
HiLite Me.Label32
End Sub

Private Sub Label33_MouseMove(Button As Integer, Shift As Integer, x As
Single, y As Single)
HiLite Me.Label33
End Sub

Private Sub Label34_MouseMove(Button As Integer, Shift As Integer, x As
Single, y As Single)
HiLite Me.Label34
End Sub

Private Sub Label35_MouseMove(Button As Integer, Shift As Integer, x As
Single, y As Single)
HiLite Me.Label35
End Sub

Private Sub Label36_MouseMove(Button As Integer, Shift As Integer, x As
Single, y As Single)
HiLite Me.Label36
End Sub

Private Sub Label37_MouseMove(Button As Integer, Shift As Integer, x As
Single, y As Single)
HiLite Me.Label37
End Sub

Private Sub Label38_MouseMove(Button As Integer, Shift As Integer, x As
Single, y As Single)
HiLite Me.Label38
End Sub

Private Sub Label39_MouseMove(Button As Integer, Shift As Integer, x As
Single, y As Single)
HiLite Me.Label39
End Sub

Private Sub Label40_MouseMove(Button As Integer, Shift As Integer, x As
Single, y As Single)
HiLite Me.Label40
End Sub

Private Sub Label41_MouseMove(Button As Integer, Shift As Integer, x As
Single, y As Single)
HiLite Me.Label41
End Sub

Private Sub Label42_MouseMove(Button As Integer, Shift As Integer, x As
Single, y As Single)
HiLite Me.Label42
End Sub

Private Sub Label43_MouseMove(Button As Integer, Shift As Integer, x As
Single, y As Single)
HiLite Me.Label43
End Sub

Private Sub Label44_MouseMove(Button As Integer, Shift As Integer, x As
Single, y As Single)
HiLite Me.Label44
End Sub

Private Sub Label45_MouseMove(Button As Integer, Shift As Integer, x As
Single, y As Single)
HiLite Me.Label45
End Sub

Private Sub Label46_MouseMove(Button As Integer, Shift As Integer, x As
Single, y As Single)
HiLite Me.Label46
End Sub

Private Sub Label47_MouseMove(Button As Integer, Shift As Integer, x As
Single, y As Single)
HiLite Me.Label47
End Sub

Private Sub Label48_MouseMove(Button As Integer, Shift As Integer, x As
Single, y As Single)
HiLite Me.Label48
End Sub

Private Sub Label49_MouseMove(Button As Integer, Shift As Integer, x As
Single, y As Single)
HiLite Me.Label49
End Sub

Private Sub lblSpeedControl_MouseDown(Button As Integer, Shift As
Integer, x As Single, y As Single)
Dim NewTop As Single
Dim pY As Single
Dim pX As Single
Dim c As Single
Dim p As POINTAPI
Dim r As Single
Dim t As Long
t = lblSpeedControl.Top
If Button = acLeftButton Then
GetCursorPos p
pX = p.x
pY = p.y
With lblSpeedControl
Do While Not CBool(GetQueueStatus(QS_MOUSEBUTTON))
GetCursorPos p
SetCursorPos pX, p.y
NewTop = t + (p.y - pY) / mPixelsPerTwipVerticalFactor
If NewTop < mMinTop Then
If .Top <> mMinTop Then
.Top = mMinTop
SpeedControlColor
Me.Repaint
If mMinTop - NewTop > 28 Then Exit Do
End If
ElseIf NewTop > mMaxBottom Then
If .Top <> mMaxBottom Then
.Top = mMaxBottom
SpeedControlColor
Me.Repaint
If NewTop - mMaxBottom > 28 Then Exit Do
End If
Else
.Top = NewTop
SpeedControlColor
Me.Repaint
End If
Loop
End With
SetCrementInterval lblSpeedControl.Top / mMaxBottom
End If
End Sub
' ********
' the change date controls

Private Sub YearBack_MouseMove(Button As Integer, Shift As Integer, x
As Single, y As Single)
HiLite Me.YearBackBlue
End Sub

Private Sub YearBackBlue_MouseDown(Button As Integer, Shift As Integer,
x As Single, y As Single)
ChangeMonth "yyyy", -1
End Sub

Private Sub MonthBack_MouseMove(Button As Integer, Shift As Integer, x
As Single, y As Single)
HiLite Me.MonthBackBlue
End Sub

Private Sub MonthBackBlue_MouseDown(Button As Integer, Shift As
Integer, x As Single, y As Single)
ChangeMonth "m", -1
End Sub

Private Sub Today_MouseMove(Button As Integer, Shift As Integer, x As
Single, y As Single)
HiLite Me.TodayBlue
End Sub

Private Sub TodayBlue_Click()
mDtmDate = VBA.Date
Form_Draw
End Sub

Private Sub MonthForward_MouseMove(Button As Integer, Shift As Integer,
x As Single, y As Single)
HiLite Me.MonthForwardBlue
End Sub

Private Sub MonthForwardBlue_MouseDown(Button As Integer, Shift As
Integer, x As Single, y As Single)
ChangeMonth "m", 1
End Sub

Private Sub YearForward_MouseMove(Button As Integer, Shift As Integer,
x As Single, y As Single)
HiLite Me.YearForwardBlue
End Sub

Private Sub YearForwardBlue_MouseDown(Button As Integer, Shift As
Integer, x As Single, y As Single)
ChangeMonth "yyyy", 1
End Sub

Private Sub Clear_MouseMove(Button As Integer, Shift As Integer, x As
Single, y As Single)
HiLite Me.ClearBlue
End Sub

Private Sub ClearBlue_Click()
DoCmd.Close acForm, Me.Name
End Sub

Private Sub Revert_MouseMove(Button As Integer, Shift As Integer, x As
Single, y As Single)
HiLite Me.RevertBlue
End Sub

Private Sub RevertBlue_Click()
DoCmd.Close acForm, Me.Name
End Sub

Private Sub ChangeMonth(ByVal Interval As String, ByVal Direction As
Long)
Dim c As Long
Dim t As Long
c = mCrementInterval * 1000
t = GetTickCount
If GetQueueStatus(QS_MOUSEBUTTON) <> 0 Then Exit Sub
mDtmDate = DateAdd(Interval, Direction, mDtmDate)
If Not mCallingControl Is Nothing Then
mCallingControl.Value = mDtmDate
mCallingForm.Repaint
End If
Form_Draw
Do Until GetTickCount - t >= c
Loop
ChangeMonth Interval, Direction
End Sub

Private Sub GetCrementInterval()
Dim d As Double
On Error GoTo GetCrementIntervalErr
d =
CDbl(mAccessForm.Properties(mCrementIntervalProper tyName).Value)
mCrementInterval = d - Fix(d)
If mCrementInterval = 0 Then mCrementInterval =
DefaultCrementInterval
mAccessForm.Properties(mCrementIntervalPropertyNam e).Value =
CStr(CDbl(VBA.Date + mCrementInterval))
GetCrementIntervalExit:
Exit Sub
GetCrementIntervalErr:
With Err
If .Number = 3270 Or .Number = 2455 Then
mAccessForm.Properties.Add mCrementIntervalPropertyName,
CStr(CDbl(VBA.Date + DefaultCrementInterval))
Else
MsgBox "Error Number: " & .Number & vbCrLf & .Description,
vbCritical, .Source & ": GetCrementInterval"
End If
End With
mCrementInterval = DefaultCrementInterval
Resume GetCrementIntervalExit
End Sub

Private Sub SetCrementInterval(ByVal r As Single)
If r >= 1 Then r = 0.999
mAccessForm.Properties(mCrementIntervalPropertyNam e).Value =
CStr(CDbl(VBA.Date + r))
GetCrementInterval
End Sub

Private Sub SetSpeedControlPositionandColor(ByVal r As Single)
Dim NewTop As Single
Dim c As Single
Dim t As Long
t = lblSpeedBar.Top
NewTop = t + r * lblSpeedBar.Height
If NewTop > mMinTop Then
NewTop = mMinTop
r = 1
ElseIf NewTop < lblSpeedBar.Top Then
NewTop = lblSpeedBar.Top
r = 0
End If
lblSpeedControl.Top = NewTop
c = 255 * r
lblSpeedControl.BackColor = RGB(c, 255 - c, 0)
lblSpeedControl.ForeColor = lblSpeedControl.BackColor
Me.Repaint
End Sub

Private Sub PixelsPerTwipFactors()
Dim l As Long
Dim PixelsPerInchHorizontal As Single
Dim PixelsPerInchVertical As Single
l = GetDC(0)
PixelsPerInchHorizontal = GetDeviceCaps(l, LOGPIXELSX)
PixelsPerInchVertical = GetDeviceCaps(l, LOGPIXELSY)
ReleaseDC 0, l
mPixelsPerTwipHorizontalFactor = PixelsPerInchHorizontal / 1440
mPixelsPerTwipVerticalFactor = PixelsPerInchVertical / 1440
End Sub

Private Sub SpeedControlColor()
Dim b As Byte
With lblSpeedControl
b = 255 * (.Top / mMaxBottom)
.BackColor = RGB(b, 255 - b, 0)
.ForeColor = lblSpeedControl.BackColor
End With
End Sub

Private Function UserName() As String
Dim l As Long
Dim s As String
GetUserName s, l
s = String(l, " ")
GetUserName s, l
UserName = Left(s, l - 1)
End Function

Nov 13 '05 #2

This discussion thread is closed

Replies have been disabled for this discussion.