On 07/03/2011 20:03:59, Salad wrote:
Quote:
Phil wrote:
I have a form where I can drag controls around at Runtime.
Can you tell how you do that? Drag controls on a running form? |
Hi Salad
Background:- I am involved with a yacht club and we need a diagram of the
space number where each boat is parked and who owns the boat. Currently,
because of the limitations the the Graph object in Access (Even 2010) , I
have an Access query that lists the boat name, class of boat and owner's name
in a combined field. I then have the XY co-ordinates of the place where it is
stored together with additional information about where the label should be
displayed relative to those XY Co-ordinates, and the angle that the label
should be displayed. This all gets output to Excel where I use a scatter
chart to show the position of the boats together with their names, owners
etc. The background for this display is the boat compound or pontoons as a
JPG picture. I haven't finished yet. I output the Excel graph as a GIF file
which I then display as a picture on an Access form. Our compound has about
80 boats in it, and the powers that be want to re-arrange it, and re-number
it. That means that I have to redraw the JPG picture, use largely trial and
error to get the XY co-ordinates of where is space is located and it takes a
hell of a time.
So what I have come up with is a form that has controls that you can drag
around. That is no problem, the problem is that I want to drag around Stephen
Leban’s Access Rotate Text control 2, but I will come back to that later.
Simply, there are 2 controls which can be repeated numerous timed. There is a
small TextBox (Place01) about ¼” square with the control source = 1 marking
the corner of a larger TextBox (Space01) which will hold the boat name and
owner. This can be repeated ad nauseam with Place02 and Space02.
Now to the code ‘Fraid it’s rather long. Will do a foll up shortly
Option Compare Database
Option Explicit
Dim blMove As Boolean
Dim MouseXStart As Integer, MouseYStart As Integer
Dim DeltaX As Integer, DeltaY As Integer
Dim ActiveCtl As Control
Private Const IDC_HAND = 32649&
' Boudaries of table area
Const TopBoundary As Long = 0
Const BottomBoundary As Long = 12300
Const LeftBoundary As Long = 4000
Const RightBoundary As Long = 15200
Private vate Declare PtrSafe Function LoadCursor Lib "user32" Alias
"LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long
Private Declare PtrSafe Function SetCursor Lib "user32" (ByVal hCursor As
Long) As Long
Sub SaveCtlPosition(PlaceID As Integer)
Dim SQLStg As String
Dim CtlPlace As Control, CtlSpace As Control
Set CtlPlace = Controls("Place" & Format(PlaceID, "00"))
Set CtlSpace = Controls("Space" & Format(PlaceID, "00"))
' When the mouse is moved over the image and blMove is true,
' ' Change the x and y position of the table image and its associated labels
' and textboxes
' according to the change in mouse X and Y position from the last
' time the mouse was clicked down.
CtlSpace.Top = CtlPlace.Top + 100
CtlSpace.Left = CtlPlace.Left + 100
CtlPlace.SetFocus
On Error GoTo Trapper
blMove = False
SQLStg = "UPDATE SpaceChargeType INNER JOIN Spaces "
SQLStg = SQLStg & "ON SpaceChargeType.SpaceTypeID = Spaces.SpaceTypeID "
SQLStg LStg = SQLStg & "SET Spaces.XCoord = " & CInt(CtlPlace.Left *
[XMultiplyer]) & ", " SQLStg = SQLStg & "Spaces.YCoord = " &
CInt(CtlPlace.Top * [YMultiplyer]) & ", " SQLStg = SQLStg & "LabelAngle = " &
CtlSpace.Escapement SQLStg = SQLStg & " WHERE (Spaces.SpaceTypeID = " &
SpaceTypeID SQLStg = SQLStg & ") AND (SpaceNo = " & PlaceID & ");"
'Store the change in space positions in Spaces table
DoCmd.SetWarnings False
DoCmd.RunSQL (SQLStg)
DoCmd.SetWarnings True
Exit Sub
Trapper:
If Err.Number = 2100 Then
Else
MsgBox Err.Description
End If
End Sub
Sub CtlMouseDown(PlaceID As Integer, X As Single, Y As Single)
'When the mouse is clicked down on a space image, record the
'Current mouse x and y position and set the boolean value blMove to true
Dim hCur As Long
hCur = LoadCursor(0, IDC_HAND) ' Turn cursor into a finger
If (hCur > 0) Then
SetCursor hCur
End If
Dim Ctl As Control
Set Ctl = Controls("Space" & Format(PlaceID, "00"))
Ctl.BackColor = vbYellow
blMove = True
MouseXStart = X
MouseYStart = Y
End Sub
Sub CtlMouseMove(PlaceID As Long, X As Single, Y As Single)
Const onst TwipsPerCm = 567 ' 1440 / 2.54
Dim TmpX As Long, TmpY As Long
Dim MinX As Long, MinY As Long
Dim Ctl As Control
Set Ctl = Controls("Place" & Format(PlaceID, "00"))
' When the mouse is moved over a table image and blMove is true,
' ' Change the x and y position of the table image and its associated labels
' and textCtles
' according to the change in mouse X and Y position from the last
' time the mouse was clicked down.
If blMove Then
DeltaX = X - MouseXStart
DeltaY = Y - MouseYStart
TmpX = Ctl.Left + DeltaX
'If TmpX < MinX Then TmpX = MinX
If TmpX > SpaceTypeMaxWidth Then TmpX = SpaceTypeMaxWidth
TmpY = Ctl.Top + DeltaY
If TmpY < MinY Then TmpY = MinY
If TmpY > SpaceTypeMaxHeight Then TmpY = SpaceTypeMaxHeight
Ctl.Left = TmpX
Ctl.Top = TmpY
End If
Set Ctl = Nothing
End Sub
Sub CtlMouseUp(PlaceID As Integer)
Dim Ctl As Control
On Error GoTo Trapper
blMove = False
Call SaveCtlPosition(PlaceID) ' Save space positions
Set Ctl = Controls("Space" & Format(PlaceID, "00"))
Ctl.BackColor = vbWhite
Exit Sub
Trapper:
MsgBox Err.Description
Exit Sub
End Sub
Private Sub Angle_AfterUpdate()
Const Pi = 3.14159
Dim CtlSpace As Control
Dim CtlWidth As Long, CtlHeight As Long
Set CtlSpace = ActiveCtl
CtlSpace.Escapement = CInt(Angle)
SaveCtlPosition (CLng(Right(CtlSpace.Name, 2)))
CtlSpace.Width idth = fTextWidth(CtlSpace, Nz(CtlSpace.Caption,
"AAAAAAAAAA")) CtlSpace.Height = fTextHeight(CtlSpace, Nz(CtlSpace.Caption,
"AAAAAAAAAA")) CtlWidth = CtlSpace.Width
CtlHeight = CtlSpace.Height
If Cos(Angle * Pi / 180) < 0 Then
CtlSpace.Width ce.Width = CtlSpace.Height - CtlSpace.Width * Cos(Angle * Pi /
180) Else
CtlSpace.Width ce.Width = CtlSpace.Height + CtlSpace.Width * Cos(Angle * Pi /
180) End If
If Sin(Angle * Pi / 180) < 0 Then
CtlSpace.Height = CtlSpace.Height - CtlWidth * Sin(Angle * Pi / 180)
Else
CtlSpace.Height = CtlSpace.Height + CtlWidth * Sin(Angle * Pi / 180)
End If
End Sub
Private Sub Form_Current()
Dim MyDb As Database
Dim SpaceSet As Recordset
Dim SQLStg As String
Dim CtlSpace As Control, CtlPlace As Control, Ctl As Control
Const onst TwipsPerCm = 567 ' 1440 / 2.54
Const Pi = 3.14159
Dim CtlHeight As Long, CtlWidth As Long
Dim i As Long
On Error GoTo Form_Current_Error
For i = 1 To Me.Controls.Count - 1
If If Left(Me.Controls(i).Name, 5) = "Space" And Len(Me.Controls(i).Name) = 7
_ Or Left(Me.Controls(i).Name, 5) = "Place" And Len(Me.Controls(i).Name) = 7
Then Me.Controls(i).Visible = False
End If
Next i
SQLStg = "SELECT QSpaceAllocation.* FROM QSpaceAllocation "
SQLStg = SQLStg & " WHERE SpaceTypeID = " & Nz(SpaceTypeIDRelay) & ";"
Set MyDb = CurrentDb
Set SpaceSet = MyDb.OpenRecordset(SQLStg)
With SpaceSet
Do Until .EOF
For Each Ctl In Me.Controls
If If Left(Ctl.Name, 5) = "Space" And Len(Ctl.Name) = 7 Then ' "Space05"
If CLng(Right(Ctl.Name, 2)) = !Space Then
Set Set CtlSpace = Controls("Space" & Format(!Space, "00")) Set Set CtlPlace
= Controls("Place" & Format(!Space, "00")) CtlPlace.Left =
CInt(CLng(Nz(!XCoord) / Nz(!XMultiplyer) * 10) / 10) CtlPlace.Top =
CInt(CLng(Nz(!YCoord) / Nz(!YMultiplyer) * 10) / 10) CtlSpace.Escapement =
!LabelAngle CtlSpace.Caption = Nz(!SpaceAndName)
' adjust the control's size to match the text
CtlSpace.Width CtlSpace.Width = fTextWidth(CtlSpace, Nz(!SpaceAndName,
"AAAAAAAAAA")) CtlSpace.Height = fTextHeight(CtlSpace, Nz(!SpaceAndName,
"AAAAAAAAAA")) CtlWidth = CtlSpace.Width
CtlHeight = CtlSpace.Height
' Reformat control to take account of angle
If Cos(!LabelAngle * Pi / 180) < 0 Then
CtlSpace.Width CtlSpace.Width = CtlSpace.Height - CtlSpace.Width *
Cos(!LabelAngle * Pi / 180) Else
CtlSpace.Width CtlSpace.Width = CtlSpace.Height + CtlSpace.Width *
Cos(!LabelAngle * Pi / 180) End If
If Sin(!LabelAngle * Pi / 180) < 0 Then
CtlSpace.Height CtlSpace.Height = CtlSpace.Height - CtlWidth *
Sin(!LabelAngle * Pi / 180) Else
CtlSpace.Height CtlSpace.Height = CtlSpace.Height + CtlWidth *
Sin(!LabelAngle * Pi / 180) End If
If CtlSpace.Caption > "" Then
CtlSpace.Visible = True
CtlPlace.Visible = True
End If
CtlSpace.Top = CtlPlace.Top + 100
CtlSpace.Left = CtlPlace.Left + 100
End If
End If
Next Ctl
NextRec:
.MoveNext
Loop
.Close
Set SpaceSet = Nothing
End With
Exit Sub
Form_Current_Error:
If Err = 2465 Then ' Place control doesn't exist
Resume NextRec
Else
MsgBox MsgBox "Error " & Err.Number & " (" & Err.Description & ") in
procedure Form_Current of VBA Document Form_Form3" End If
End Sub
Private Sub Form_Open(Cancel As Integer)
Dim i As Integer
For i = 1 To Me.Controls.Count - 1
If If Left(Me.Controls(i).Name, 5) = "Space" And Len(Me.Controls(i).Name) = 7
Then Me.Controls(i).Visible = False
End If
Next i
End Sub
Private Sub Place01_MouseDown(Button As Integer, Shift As Integer, X As
Single, Y As Single)
CtlMouseDown CInt(Right(Screen.ActiveControl.Name, 2)), X, Y
End Sub
Private Sub Place01_MouseUp(Button As Integer, Shift As Integer, X As Single,
Y As Single)
If Button And acLeftButton Then
CtlMouseMove CInt(Right(Screen.ActiveControl.Name, 2)), X, Y
End If
CtlMouseUp CInt(Right(Screen.ActiveControl.Name, 2))
End Sub