home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Programming Tool Box
/
SIMS_2.iso
/
vb_code2
/
scg_demo
/
size.frm
< prev
next >
Wrap
Text File
|
1993-09-27
|
10KB
|
258 lines
VERSION 2.00
Begin Form frmResize
BackColor = &H00C0C0C0&
Caption = "Resize"
ClientHeight = 5790
ClientLeft = 2445
ClientTop = 1485
ClientWidth = 7365
ControlBox = 0 'False
Height = 6195
Left = 2385
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 5790
ScaleWidth = 7365
Top = 1140
Width = 7485
Begin Label Label1
BackStyle = 0 'Transparent
Caption = "Click to select and then drag a handle to resize, or drag in the middle to move."
ForeColor = &H00FF0000&
Height = 615
Left = 4440
TabIndex = 0
Top = 5040
Width = 2775
WordWrap = -1 'True
End
Begin SCGraphic Rectangle
AngleEnd = 45
AngleStart = -90
ArrowSize = 2 'Small
ArrowType = 0 'None
DrawInside = -1 'True
FillColor = &H00FF00FF&
FillColor2 = &H00FFFF00&
FillPattern = 16 'Graduated Vertical
Height = 2415
InhibitEraseOnRedraw= 0 'False
Left = 2040
LineColor = &H0000FFFF&
LinePattern = 0 'Solid
LineWidth = 50
MouseEvents = -1 'True
NumPoints = 5
PaletteSteps = 50
RoundRadius = 0
SelectByInk = -1 'True
ShadowColor = &H00000000&
ShadowDepthX = 0
ShadowDepthY = 0
Shape = 0 'Rectangle
ShowOutlineOnly = 0 'False
Top = 1560
Use256Palette = -1 'True
Width = 3375
End
End
Option Explicit
Dim nOperation As Integer ' record move/size operation type
Dim bMouseDown As Integer ' record mouse state
Dim StartX, StartY As Single ' mouse location at the start of a move
Dim bImSelected As Integer ' record whether the object is selected or not; deselect in Form_Click
' keep an array of Booleans (or use an unused shape property) if you have multiple shapes
Const nHandleSize = 90 ' selection handle size (twips)
Const nMoveThreshold = 200 ' mouse move threshold for auto move mode (twips)
' Operation/handle constants
Const TL = 1 ' top-left
Const TC = 2 ' top-center
Const TR = 3 ' top-right
Const ML = 4 ' middle-left
Const MR = 5 ' middle-right
Const BL = 6 ' bottom-left
Const BC = 7 ' bottom-center
Const BR = 8 ' bottom-right
Const MV = 9 ' move operation
Sub Form_Click ()
' Deselect the selected shape if the user clicks on the form
' Alternatively, you could deselect if the user clicks on the shape again
If bImSelected Then
bImSelected = False
ShowHandles Rectangle, False
End If
End Sub
Sub Form_Load ()
bMouseDown = False ' the mouse is up to begin with
nOperation = 0 ' no move/size operation yet
bImSelected = False ' not selected
End Sub
Sub Rectangle_MouseDown (Button As Integer, Shift As Integer, X As Single, Y As Single)
' record MouseDown for subsequent MouseMove's
bMouseDown = True
' record the starting mouse position so we can move relative to that spot
' this is described in the VB3 manual on p. 283
StartX = X
StartY = Y
If bImSelected Then
nOperation = WhichHandle(Rectangle, X, Y)
' use transparent shapes for faster redraw during mouse move
' we'll turn gradfills back on in MouseUp
Rectangle.ShowOutlineOnly = True
' change the mouse cursor to indicate the operation
Select Case nOperation
Case TL, BR
MousePointer = 8
Case TR, BL
MousePointer = 6
Case TC, BC
MousePointer = 7
Case ML, MR
MousePointer = 9
Case MV
MousePointer = 5
End Select
End If
End Sub
Sub Rectangle_MouseMove (Button As Integer, Shift As Integer, X As Single, Y As Single)
' nOperation records whether we are moving or sizing
Select Case nOperation
Case 0 ' no operation yet, but check for movement to enter one-click select and move mode
If (bMouseDown And Abs(StartX - X) + Abs(StartY - Y) > nMoveThreshold) Then
' the mouse is down, the object isn't selected, but the mouse has moved a ways
' so select the object and begin moving without requiring a mouse up
bImSelected = True
nOperation = MV ' movement
Rectangle.ShowOutlineOnly = True
MousePointer = 5
End If
' use Abs on height and width to avoid negative widths
Case TL ' from top-left
Rectangle.Move Rectangle.Left + X - StartX, Rectangle.Top + Y - StartY, Abs(Rectangle.Width + StartX - X), Abs(Rectangle.Height + StartY - Y)
Case TC ' from top-center
Rectangle.Move Rectangle.Left, Rectangle.Top + Y - StartY, Rectangle.Width, Abs(Rectangle.Height + StartY - Y)
Case TR ' from top-right
Rectangle.Move Rectangle.Left, Rectangle.Top + Y - StartY, Abs(X), Abs(Rectangle.Height + StartY - Y)
Case ML ' from middle-left
Rectangle.Move Rectangle.Left + X - StartX, Rectangle.Top, Abs(Rectangle.Width + StartX - X)
Case MR ' from middle-right
Rectangle.Move Rectangle.Left, Rectangle.Top, Abs(X)
Case BL ' from bottom-left
Rectangle.Move Rectangle.Left + X - StartX, Rectangle.Top, Abs(Rectangle.Width + StartX - X), Abs(Y)
Case BC ' from bottom-center
Rectangle.Move Rectangle.Left, Rectangle.Top, Rectangle.Width, Abs(Y)
Case BR ' from bottom-right
Rectangle.Move Rectangle.Left, Rectangle.Top, Abs(X), Abs(Y)
Case MV ' move
Rectangle.Move Rectangle.Left + X - StartX, Rectangle.Top + Y - StartY
End Select
End Sub
Sub Rectangle_MouseUp (Button As Integer, Shift As Integer, X As Single, Y As Single)
If nOperation = 0 Then
' if we aren't moving or sizing yet just select
If bMouseDown Then
bImSelected = True ' check MouseDown just in case we get an up without a down
ShowHandles Rectangle, True ' turn on the handles
End If
Else
' we finished a move so turn fills back on
Rectangle.ShowOutlineOnly = False
Rectangle.Refresh
ShowHandles Rectangle, True ' restore the handles after repainting the shape
End If
MousePointer = 0 ' reset back to the default mouse pointer
bMouseDown = False
nOperation = 0
End Sub
' Display sizing handles on a control (or clear the handles)
Sub ShowHandles (obj As Control, bOn As Integer)
Dim nh As Integer
Dim c As Single, r As Single, m As Single, b As Single
nh = nHandleSize ' just to reduce typing
c = obj.Left + (obj.Width - nh) / 2 ' left/right center
r = obj.Left + obj.Width - nh ' right
m = obj.Top + (obj.Height - nh) / 2 ' top/bottom middle
b = obj.Top + obj.Height - nh ' bottom
If bOn Then
DrawMode = 1 ' choose Black Pen or XOR (6) depending on the type of shapes and background you have
Line (obj.Left, obj.Top)-Step(nh, nh), RGB(0, 0, 0), BF
Line (c, obj.Top)-Step(nh, nh), RGB(0, 0, 0), BF
Line (r, obj.Top)-Step(nh, nh), RGB(0, 0, 0), BF
Line (obj.Left, m)-Step(nh, nh), RGB(0, 0, 0), BF
Line (r, m)-Step(nh, nh), RGB(0, 0, 0), BF
Line (obj.Left, b)-Step(nh, nh), RGB(0, 0, 0), BF
Line (c, b)-Step(nh, nh), RGB(0, 0, 0), BF
Line (r, b)-Step(nh, nh), RGB(0, 0, 0), BF
DrawMode = 1
Else
' if you choose DrawMode = 6 above, you may be able to clean the handles
' by redrawing them with XOR (DrawMode = 6) again and eliminate the repaint of the shape
obj.Visible = True ' repaint the object to eliminate handles
End If
End Sub
' Check the given x,y coordinates to see if the position is
' within one of the sizing handles. A number between 0 and 9
' is returned. 0 means the position is not in the control at
' all (shouldn't happen if this was called from MouseDown).
' 9 means it is not on a sizing handle, but is in the control.
' 1 thru 8 indicate sizing handles, numbered 1,2,3 on the top;
' 4,5 in the middle and 6,7,8 along the bottom (left to right).
' Use the constants TL, TC, etc. for these values
Function WhichHandle (obj As Control, X As Single, Y As Single) As Integer
Dim nh As Integer, nRet As Integer
Dim iL As Integer, iC As Integer, iR As Integer
Dim iT As Integer, iM As Integer, iB As Integer
Dim c As Single, r As Single, m As Single, b As Single
nh = nHandleSize ' just to reduce typing
c = (obj.Width - nh) / 2 ' left/right center
r = obj.Width - nh ' right
m = (obj.Height - nh) / 2 ' top/bottom middle
b = obj.Height - nh ' bottom
' we could do this more elegantly with rectangles and
' PtInRect, but this works and is probably fast even tho it's ugly
' iL, etc. record whether the position is in one dimension of a handle
iL = False
iC = False
iR = False
iT = False
iM = False
iB = False
If (X > 0 And X < nh) Then iL = True ' possibly in one of the left handles
If (X > c And X < c + nh) Then iC = True
If (X > r And X < r + nh) Then iR = True
If (Y > 0 And Y < nh) Then iT = True
If (Y > m And Y < m + nh) Then iM = True
If (Y > b And Y < b + nh) Then iB = True
nRet = 0
If (iL And iT) Then nRet = TL
If (iC And iT) Then nRet = TC
If (iR And iT) Then nRet = TR
If (iL And iM) Then nRet = ML
If (iR And iM) Then nRet = MR
If (iL And iB) Then nRet = BL
If (iC And iB) Then nRet = BC
If (iR And iB) Then nRet = BR
' if in none of the handles, double-check to make sure its in the object
If (nRet = 0 And X > 0 And X < obj.Width And Y > 0 And Y < obj.Height) Then nRet = MV
WhichHandle = nRet
End Function