GFSkinEngine/PolyRgnDesk/GFSkinEngine_PolyRgnDeskfrm.frm
VERSION 5.00
Begin VB.Form GFSkinEngine_PolyRgnDeskfrm
BackColor = &H00000000&
Caption = "Draw SE Poly Rgn"
ClientHeight = 3195
ClientLeft = 165
ClientTop = 450
ClientWidth = 4635
Enabled = 0 'False
Icon = "GFSkinEngine_PolyRgnDeskfrm.frx":0000
LinkTopic = "Form1"
ScaleHeight = 3195
ScaleWidth = 4635
StartUpPosition = 2 'Bildschirmmitte
Visible = 0 'False
WindowState = 2 'Maximiert
Begin VB.PictureBox DeskResetPicture
AutoSize = ‑1 'True
Enabled = 0 'False
Height = 255
Left = 1140
Picture = "GFSkinEngine_PolyRgnDeskfrm.frx":0442
ScaleHeight = 195
ScaleWidth = 195
TabIndex = 18
Top = 0
Visible = 0 'False
Width = 255
End
Begin VB.PictureBox DeskColorIconPicture3
AutoSize = ‑1 'True
Enabled = 0 'False
Height = 255
Left = 3840
Picture = "GFSkinEngine_PolyRgnDeskfrm.frx":068C
ScaleHeight = 195
ScaleWidth = 195
TabIndex = 17
Top = 0
Visible = 0 'False
Width = 255
End
Begin VB.PictureBox DeskColorIconPicture2
AutoSize = ‑1 'True
Enabled = 0 'False
Height = 255
Left = 3540
Picture = "GFSkinEngine_PolyRgnDeskfrm.frx":08D6
ScaleHeight = 195
ScaleWidth = 195
TabIndex = 16
Top = 0
Visible = 0 'False
Width = 255
End
Begin VB.PictureBox DeskColorIconPicture1
AutoSize = ‑1 'True
Enabled = 0 'False
Height = 255
Left = 3240
Picture = "GFSkinEngine_PolyRgnDeskfrm.frx":0B20
ScaleHeight = 195
ScaleWidth = 195
TabIndex = 15
Top = 0
Visible = 0 'False
Width = 255
End
Begin VB.PictureBox DeskKeysPicture
AutoSize = ‑1 'True
Enabled = 0 'False
Height = 255
Left = 2940
Picture = "GFSkinEngine_PolyRgnDeskfrm.frx":0D6A
ScaleHeight = 195
ScaleWidth = 195
TabIndex = 14
Top = 0
Visible = 0 'False
Width = 255
End
Begin VB.PictureBox DeskPolyRgnEditLogoPicture
AutoRedraw = ‑1 'True
AutoSize = ‑1 'True
Enabled = 0 'False
FillStyle = 0 'Ausgef�llt
Height = 1035
Left = 540
Picture = "GFSkinEngine_PolyRgnDeskfrm.frx":0FB4
ScaleHeight = 65
ScaleMode = 3 'Pixel
ScaleWidth = 185
TabIndex = 12
Top = 360
Visible = 0 'False
Width = 2835
End
Begin VB.PictureBox DeskBackPicturePicture
Enabled = 0 'False
Height = 315
Left = 0
ScaleHeight = 255
ScaleWidth = 135
TabIndex = 11
Top = 360
Visible = 0 'False
Width = 195
End
Begin VB.Frame DeskInfoFrame
BackColor = &H80000004&
BorderStyle = 0 'Kein
Height = 975
Left = 0
TabIndex = 9
Top = 2220
Width = 3848
Begin VB.PictureBox DeskInfoPicture
BackColor = &H00000000&
BorderStyle = 0 'Kein
BeginProperty Font
Name = "Courier New"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FFFFFF&
Height = 855
Left = 60
ScaleHeight = 855
ScaleWidth = 3015
TabIndex = 13
Top = 60
Width = 3015
End
Begin VB.PictureBox MagnifierPicture
Appearance = 0 '2D
BackColor = &H80000005&
ForeColor = &H80000008&
Height = 855
Left = 3120
ScaleHeight = 825
ScaleWidth = 630
TabIndex = 10
Top = 65
Width = 660
End
End
Begin VB.PictureBox DeskFinishDrawingPicture
AutoSize = ‑1 'True
Enabled = 0 'False
Height = 255
Left = 2040
Picture = "GFSkinEngine_PolyRgnDeskfrm.frx":43B2
ScaleHeight = 195
ScaleWidth = 195
TabIndex = 6
Top = 0
Visible = 0 'False
Width = 255
End
Begin VB.PictureBox DeskCopyPicture
AutoSize = ‑1 'True
Enabled = 0 'False
Height = 255
Left = 2340
Picture = "GFSkinEngine_PolyRgnDeskfrm.frx":45FC
ScaleHeight = 195
ScaleWidth = 195
TabIndex = 7
Top = 0
Visible = 0 'False
Width = 255
End
Begin VB.PictureBox DeskContinueDrawingPicture
AutoSize = ‑1 'True
Enabled = 0 'False
Height = 255
Left = 1740
Picture = "GFSkinEngine_PolyRgnDeskfrm.frx":4846
ScaleHeight = 195
ScaleWidth = 195
TabIndex = 5
Top = 0
Visible = 0 'False
Width = 255
End
Begin VB.PictureBox DeskPastePicture
AutoSize = ‑1 'True
Enabled = 0 'False
Height = 255
Left = 2640
Picture = "GFSkinEngine_PolyRgnDeskfrm.frx":4A90
ScaleHeight = 195
ScaleWidth = 195
TabIndex = 8
Top = 0
Visible = 0 'False
Width = 255
End
Begin VB.PictureBox DeskAbortPicture
AutoSize = ‑1 'True
Enabled = 0 'False
Height = 255
Left = 840
Picture = "GFSkinEngine_PolyRgnDeskfrm.frx":4CDA
ScaleHeight = 195
ScaleWidth = 195
TabIndex = 3
Top = 0
Visible = 0 'False
Width = 255
End
Begin VB.PictureBox DeskFinishedPicture
AutoSize = ‑1 'True
Enabled = 0 'False
Height = 255
Left = 540
Picture = "GFSkinEngine_PolyRgnDeskfrm.frx":4F24
ScaleHeight = 195
ScaleWidth = 195
TabIndex = 2
Top = 0
Visible = 0 'False
Width = 255
End
Begin VB.PictureBox DeskFitPicture
AutoSize = ‑1 'True
Enabled = 0 'False
Height = 255
Left = 1440
Picture = "GFSkinEngine_PolyRgnDeskfrm.frx":516E
ScaleHeight = 195
ScaleWidth = 195
TabIndex = 4
Top = 0
Visible = 0 'False
Width = 255
End
Begin VB.PictureBox GridMaskPicture
BackColor = &H00000000&
Enabled = 0 'False
ForeColor = &H00FFFFFF&
Height = 315
Left = 240
ScaleHeight = 255
ScaleWidth = 135
TabIndex = 1
Top = 0
Visible = 0 'False
Width = 195
End
Begin VB.PictureBox GridPicture
Enabled = 0 'False
Height = 315
Left = 0
ScaleHeight = 255
ScaleWidth = 135
TabIndex = 0
Top = 0
Visible = 0 'False
Width = 195
End
Begin VB.Menu MenuMyArtwork
Caption = "My Artwork"
Begin VB.Menu MenuFinished
Caption = "Great (Finished)"
End
Begin VB.Menu MenuSpacer1
Caption = "‑"
End
Begin VB.Menu MenuAbort
Caption = "Trash (Abort)"
End
Begin VB.Menu MenuReset
Caption = "Trash (Reset)"
End
End
Begin VB.Menu MenuOptions
Caption = "Options"
Begin VB.Menu MenuGridEnabled
Caption = "Grid Enabled"
Checked = ‑1 'True
Shortcut = ^G
End
Begin VB.Menu MenuGridVisible
Caption = "Grid Visible"
End
Begin VB.Menu MenuGridColor
Caption = "Grid Color..."
End
Begin VB.Menu MenuToggleGridZoomFactor
Caption = "[...]"
Enabled = 0 'False
Shortcut = ^Z
Visible = 0 'False
End
Begin VB.Menu MenuSpacer7
Caption = "‑"
End
Begin VB.Menu MenuBackPictureEnabled
Caption = "Backpicture Visible"
End
Begin VB.Menu MenuBackPictureInverted
Caption = "Backpicture Inverted (viewing aid)"
End
Begin VB.Menu MenuSpacer5
Caption = "‑"
End
Begin VB.Menu MenuInfoEnabled
Caption = "Show Info and Magnifier"
Checked = ‑1 'True
End
Begin VB.Menu MenuSpacer4
Caption = "‑"
End
Begin VB.Menu MenuLineInvertedEnabled
Caption = "Display Lines Inverted"
End
Begin VB.Menu MenuLineInColorEnabled
Caption = "Display Lines In Color"
End
Begin VB.Menu MenuLineNormalColor
Caption = "Line Normal Color..."
End
Begin VB.Menu MenuLineMarkedColor
Caption = "Line Marked Color..."
End
End
Begin VB.Menu MenuSpecials
Caption = "Specials"
Begin VB.Menu MenuFitRegion
Caption = "Fit Region to window"
End
Begin VB.Menu MenuContinueDrawing
Caption = "Continue Drawing"
End
Begin VB.Menu MenuFinishDrawing
Caption = "Finish Drawing"
End
Begin VB.Menu MenuSpacer2
Caption = "‑"
End
Begin VB.Menu MenuCopyRegion
Caption = "Copy Region"
End
Begin VB.Menu MenuPasteRegion
Caption = "Paste Region"
End
Begin VB.Menu MenuSpacer3
Caption = "‑"
Visible = 0 'False
End
Begin VB.Menu MenuCreateCircle
Caption = "Create Circle"
Visible = 0 'False
End
End
Begin VB.Menu MenuHelp
Caption = "?"
Begin VB.Menu MenuKeys
Caption = "Keys..."
End
End
End
Attribute VB_Name = "GFSkinEngine_PolyRgnDeskfrm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'(c)2001 by Louis (reviewed 2002). Part of the GFSkinEngine project.
'
'This form allows the user to create his/her own PolyRgns quickly and easily.
'
#Const ProgramDebugFlag = False 'disable when not testing desk as stand‑alone project
'
'NOTE: there are two features that are not available as they didn't work correctly:
'‑create circle
'‑grid zoom
'The related menu items are disabled and hidden so that the user doesn't
'see them and thus cannot use them (menu items are also partially disabled).
'
'Point_Verify
Private Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As POINTAPI, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long
Private Declare Function RectInRegion Lib "gdi32" (ByVal hRgn As Long, lpRect As RECT) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
'SE_EnableMenuBitmaps
Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function GetMenuItemID Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function SetMenuItemBitmaps Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal hBitmapUnchecked As Long, ByVal hBitmapChecked As Long) As Long
'Magnifier_Redraw
Private Declare Function StretchBlt Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
'PolyRgnDesk_Draw
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'GFMaskPrint
Private Declare Function BitBlt Lib "gdi32.dll" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
'ProgramGetMousePos[X, Y]
Private Declare Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
'Point_Verify
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'Point_Verify
Private Type POINTAPI
X As Long
Y As Long
End Type
'SE_EnableMenuBitmaps
Private Type MENUITEMINFO
cbSize As Long
fMask As Long
fType As Long
fState As Long
wID As Long
hSubMenu As Long
hbmpChecked As Long
hbmpUnchecked As Long
dwItemData As Long
dwTypeData As String
cch As Long
End Type
'SE_EnableMenuBitmaps
Const MF_BITMAP = &H4&
'ProgramGetMousePos[X, Y]
'Private Type POINTAPI
' x As Long
' y As Long
'End Type
'DeskStruct ‑ stores general data
Private Type DeskStruct
GridDistance As Long
GridColor As Long
GridEnabledFlag As Boolean
GridVisibleFlag As Boolean
GridZoomFactor As Single
PointRectDisabledFlag As Boolean 'if the point rects are hidden or not
PointRectColorNormal As Long
PointRectColorMarked As Long
LineInColorOrInvertedFlag As Boolean
LineColorNormal As Long
LineColorMarked As Long
DrawingFinishedFlag As Boolean
MarkedPointIndex As Integer
MarkedLineIndex As Integer 'index of the first point of the marked line in PointStructArray()
ContinueFlag As Boolean
CancelFlag As Boolean
DeskBackPictureName As String
DeskBackPictureEnabledFlag As Boolean
DeskBackPictureInvertedFlag As Boolean
DeskInfoEnabledFlag As Boolean 'if DeskInfoFrame is to be shown
DeskInitializedFlag As Boolean 'if desk was initialized yet
DeskWindowStateOld As Integer 'do not redraw grid is window is minimized and then restored
DeskChangesExistingFlag As Boolean 'if user made any changes
WindowWidth As Long 'target window width
WindowHeight As Long 'target window height
PolyRgnFormName As String
PolyRgnFormObject As Object
End Type
Dim DeskStructVar As DeskStruct
'DeskRedrawStruct ‑ stores DeskStruct data to determine if the desk needs to be redrawn or not
Private Type DeskRedrawStruct
GridEnabledFlagOld As Boolean
DrawingFinishedFlagOld As Boolean
MarkedPointIndex As Integer
MarkedLineIndex As Integer
PointStructNumber As Integer
DeskBackPictureName As String
DeskBackPictureEnabledFlag As Boolean
End Type
Dim DeskRedrawStructVar As DeskRedrawStruct
'DeskOffSetStruct ‑ used for moving desk image
Private Type DeskOffSetStruct
OffSetX As Long
OffSetY As Long
End Type
Dim DeskOffSetStructVar As DeskOffSetStruct
'DeskOffSetChangeStruct
Private Type DeskOffSetChangeStruct
OffSetChangeEnabledFlag As Boolean
OffSetXUnchanged As Long
OffSetYUnchanged As Long
MouseXUnchanged As Single
MouseYUnchanged As Single
End Type
Dim DeskOffSetChangeStructVar As DeskOffSetChangeStruct
'DeskInfoStruct ‑ data to be displayed in DeskInfoLabel
Private Type DeskInfoStruct
RgnWindowXSize As Long
RgnWindowYSize As Long
MouseXPos As Long
MouseYPos As Long
PointNumber As Integer
MarkedPointIndex As Integer
ViewXOffSet As Long 'should be equal to DeskOffSetStructVar.OffSetX
ViewYOffSet As Long 'should be equal to DeskOffSetStructVar.OffSetY
DeskInfoStringOld As String 'what was printed into DeskInfoPicture at last
End Type
Dim DeskInfoStructVar As DeskInfoStruct
'PointStruct ‑ stores line points
Private Type PointStruct
X As Long
Y As Long
End Type
Dim PointStructNumber As Integer
Dim PointStructArray() As PointStruct
'CopyPointStruct ‑ for copying a region
Dim CopyPointStructNumber As Integer
Dim CopyPointStructArray() As PointStruct
'PointMoveStruct ‑ used for moving the marked point
Private Type PointMoveStruct
PointMoveEnabledFlag As Boolean
PointStructIndex As Integer
End Type
Dim PointMoveStructVar As PointMoveStruct
'MagnifierStruct
Private Type MagnifierStruct
MouseXOld As Long
MouseYOld As Long
End Type
Dim MagnifierStructVar As MagnifierStruct
'CreateCircleStructVar ‑ information to create a (half‑) circle
'
'NOTE: the code to create special rgn shapes should be prefixed 'Create'.
'
Private Type CreateCircleStruct
CircleInCreationFlag As Boolean
CirclePointNumber As Integer
CirclePointStartIndex As Integer 'index of first circle point in PointStructArray()
CircleMiddlePoint As PointStruct
End Type
Dim CreateCircleStructVar As CreateCircleStruct
'PolyRgnDesk_Draw
Dim PolyRgnDesk_DrawCalledFlag As Boolean
'NOTE: drawing rules: the user must first create a closed region.
'If a point is set on the first point, the set point is not saved in the PointStructArray()
'(CreatePolygonRgn() does not require), but drawing has finished.
'Now the user can insert or delete points. When drawing is finished, the point (PointRect)
'closest to the mouse pointer is marked in a special color.
'The user can move this point using the mouse, or delete it using the keyboard.
'
'NOTE: generally the system should always use Get[X/Y]() instead of the X and Y values
'passed by VB as Get[X/Y]() verifies the mouse coordinates.
Private Sub Form_Load()
'On Error Resume Next
Call SE_EnableMenuBitmaps
Call DefineVars
Call DefineDeskBackPicturePicture
Call DefineMagnifierPicture
#If ProgramDebugFlag = True Then
'NOTE: except for debugging the target project must call PolyRgnDesk_Initialize().
Call PolyRgnDesk_Initialize(400, 300, 10, RGB(200, 200, 200), RGB(100, 255, 0), RGB(255, 100, 0), 0, RGB(255, 255, 255), "", Nothing)
Me.Enabled = True
Me.Visible = True
Me.Refresh
#End If
End Sub
Private Sub DefineVars()
'on error resume next
'
'NOTE: as this form is never unloaded (see Form_Unload()), the enabled flag
'of the grid is retained as long as the target project is executed.
'
DeskStructVar.GridEnabledFlag = True
MenuGridEnabled.Checked = True
End Sub
Private Sub DefineMagnifierPicture()
'on error resume next
MagnifierPicture.ScaleMode = vbPixels
MagnifierPicture.AutoRedraw = True
End Sub
Private Sub DefineDeskBackPicturePicture()
'on error resume next
DeskBackPicturePicture.ScaleMode = vbPixels
DeskBackPicturePicture.AutoRedraw = True
DeskBackPicturePicture.AutoSize = True
End Sub
Private Sub SE_EnableMenuBitmaps()
'on error resume next
Dim MenuHandle As Long
Dim SubMenuHandle1 As Long
Dim SubMenuHandle2 As Long
Dim SubMenuItemID As Long
'preset
MenuHandle = GetMenu(Me.hwnd)
'begin
SubMenuHandle1 = GetSubMenu(MenuHandle, 0)
SubMenuItemID = GetMenuItemID(SubMenuHandle1, 0)
Call SetMenuItemBitmaps(MenuHandle, SubMenuItemID, MF_BITMAP, DeskFinishedPicture.Picture.Handle, DeskFinishedPicture.Picture.Handle)
'
SubMenuHandle1 = GetSubMenu(MenuHandle, 0)
SubMenuItemID = GetMenuItemID(SubMenuHandle1, 2)
Call SetMenuItemBitmaps(MenuHandle, SubMenuItemID, MF_BITMAP, DeskAbortPicture.Picture.Handle, DeskAbortPicture.Picture.Handle)
'
SubMenuHandle1 = GetSubMenu(MenuHandle, 0)
SubMenuItemID = GetMenuItemID(SubMenuHandle1, 3)
Call SetMenuItemBitmaps(MenuHandle, SubMenuItemID, MF_BITMAP, DeskResetPicture.Picture.Handle, DeskResetPicture.Picture.Handle)
'
SubMenuHandle1 = GetSubMenu(MenuHandle, 2)
SubMenuItemID = GetMenuItemID(SubMenuHandle1, 0)
Call SetMenuItemBitmaps(MenuHandle, SubMenuItemID, MF_BITMAP, DeskFitPicture.Picture.Handle, DeskFitPicture.Picture.Handle)
'
SubMenuHandle1 = GetSubMenu(MenuHandle, 2)
SubMenuItemID = GetMenuItemID(SubMenuHandle1, 1)
Call SetMenuItemBitmaps(MenuHandle, SubMenuItemID, MF_BITMAP, DeskContinueDrawingPicture.Picture.Handle, DeskContinueDrawingPicture.Picture.Handle)
'
SubMenuHandle1 = GetSubMenu(MenuHandle, 2)
SubMenuItemID = GetMenuItemID(SubMenuHandle1, 2)
Call SetMenuItemBitmaps(MenuHandle, SubMenuItemID, MF_BITMAP, DeskContinueDrawingPicture.Picture.Handle, DeskFinishDrawingPicture.Picture.Handle)
'
SubMenuHandle1 = GetSubMenu(MenuHandle, 2)
SubMenuItemID = GetMenuItemID(SubMenuHandle1, 4)
Call SetMenuItemBitmaps(MenuHandle, SubMenuItemID, MF_BITMAP, DeskCopyPicture.Picture.Handle, DeskCopyPicture.Picture.Handle)
'
SubMenuHandle1 = GetSubMenu(MenuHandle, 2)
SubMenuItemID = GetMenuItemID(SubMenuHandle1, 5)
Call SetMenuItemBitmaps(MenuHandle, SubMenuItemID, MF_BITMAP, DeskPastePicture.Picture.Handle, DeskPastePicture.Picture.Handle)
'
' SubMenuHandle1 = GetSubMenu(MenuHandle, 1) 'color pictures didn't look good
' SubMenuItemID = GetMenuItemID(SubMenuHandle1, 2)
' Call SetMenuItemBitmaps(MenuHandle, SubMenuItemID, MF_BITMAP, DeskColorIconPicture1.Picture.Handle, DeskColorIconPicture1.Picture.Handle)
' SubMenuHandle1 = GetSubMenu(MenuHandle, 1)
' SubMenuItemID = GetMenuItemID(SubMenuHandle1, 11)
' Call SetMenuItemBitmaps(MenuHandle, SubMenuItemID, MF_BITMAP, DeskColorIconPicture2.Picture.Handle, DeskColorIconPicture2.Picture.Handle)
' SubMenuHandle1 = GetSubMenu(MenuHandle, 1)
' SubMenuItemID = GetMenuItemID(SubMenuHandle1, 12)
' Call SetMenuItemBitmaps(MenuHandle, SubMenuItemID, MF_BITMAP, DeskColorIconPicture3.Picture.Handle, DeskColorIconPicture3.Picture.Handle)
'
SubMenuHandle1 = GetSubMenu(MenuHandle, 3)
SubMenuItemID = GetMenuItemID(SubMenuHandle1, 0)
Call SetMenuItemBitmaps(MenuHandle, SubMenuItemID, MF_BITMAP, DeskKeysPicture.Picture.Handle, DeskKeysPicture.Picture.Handle)
'
End Sub
'**************************************FORM EVENTS**************************************
'NOTE: the entire graphic is printed directly onto the form (no picture box is used).
Private Sub Form_Resize()
'On Error Resume Next
If Not ((Me.WindowState = vbMinimized) Or ((Me.WindowState = vbNormal) And (DeskStructVar.DeskWindowStateOld = vbMinimized))) Then
'NOTE: the grid must not be redrawn if the window is minimized and then restored.
If Me.ScaleMode = vbTwips Then
'Call Grid_Create(150 * Screen.TwipsPerPixelX, 150 * Screen.TwipsPerPixelY, DeskStructVar)
Call Desk_Redraw(GetX, GetY, True) 'display changes
End If
If Me.ScaleMode = vbPixels Then
'Call Grid_Create(150 * Screen.TwipsPerPixelX, 150 * Screen.TwipsPerPixelY, DeskStructVar)
Call Desk_Redraw(GetX, GetY, True) 'display changes
End If
End If
DeskInfoFrame.Top = Me.ScaleHeight ‑ DeskInfoFrame.Height
DeskInfoFrame.Width = Me.ScaleWidth
MagnifierPicture.Width = MAX((DeskInfoFrame.Width ‑ (MagnifierPicture.Left / Screen.TwipsPerPixelX) ‑ 5) * Screen.TwipsPerPixelX, 5) 'another ScaleMode‑mess!
DeskStructVar.DeskWindowStateOld = Me.WindowState
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'On Error Resume Next
Select Case Button
Case vbLeftButton
Select Case Shift
Case 0
If Not (DeskStructVar.MarkedPointIndex = 0) Then
PointMoveStructVar.PointMoveEnabledFlag = True
PointMoveStructVar.PointStructIndex = DeskStructVar.MarkedPointIndex
End If
Case vbCtrlMask
Me.MousePointer = vbSizePointer
DeskOffSetChangeStructVar.OffSetChangeEnabledFlag = True
DeskOffSetChangeStructVar.OffSetXUnchanged = DeskOffSetStructVar.OffSetX
DeskOffSetChangeStructVar.OffSetYUnchanged = DeskOffSetStructVar.OffSetY
DeskOffSetChangeStructVar.MouseXUnchanged = X
DeskOffSetChangeStructVar.MouseYUnchanged = Y
End Select
Case vbRightButton
'
'NOTE: it is possible to change the back picture of the form whose poly rgn
'is currently changed. But as this function didn't work 100%
'and was rather useless it has been replaced with the offset changing.
'
'#If ProgramDebugFlag = False Then
' Call SE_OpenPopUpMenu(ProgramGetMousePosX, ProgramGetMousePosY, 3, DeskStructVar.PolyRgnFormName, DeskStructVar.PolyRgnFormObject) 'open pop up menu 'on' form whose poly rgn is to be changed
'#Else
Me.MousePointer = vbSizePointer
DeskOffSetChangeStructVar.OffSetChangeEnabledFlag = True
DeskOffSetChangeStructVar.OffSetXUnchanged = DeskOffSetStructVar.OffSetX
DeskOffSetChangeStructVar.OffSetYUnchanged = DeskOffSetStructVar.OffSetY
DeskOffSetChangeStructVar.MouseXUnchanged = X
DeskOffSetChangeStructVar.MouseYUnchanged = Y
'#End If
End Select
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'On Error Resume Next
Dim MouseXPos As Long
Dim MouseYPos As Long
Dim MouseGridXPos As Long
Dim MouseGridYPos As Long
'preset
MouseXPos = GetX
MouseYPos = GetY
MouseGridXPos = MouseXPos
MouseGridYPos = MouseYPos
Call GetGridPosFromMousePos(MouseGridXPos, MouseGridYPos)
'begin
DeskInfoStructVar.MouseXPos = MouseGridXPos
DeskInfoStructVar.MouseYPos = MouseGridYPos
Call DeskInfoPicture_Update(DeskInfoStructVar)
'
'NOTE: if the mouse leaves the form then the displayed mouse position
'stays equal to the last valid mouse position. It is not good to set a
'mouse capture as the Skin Engine itself does so
'(Windows does not allow to set more than one capture at a time).
'
If CreateCircleStructVar.CircleInCreationFlag = True Then
Dim MouseCircleDistance As Long
Dim PointLoop As Integer
MouseCircleDistance = GFMaths_Geometrymod.GetPointPointDistLong2D( _
MouseXPos, MouseYPos, _
CreateCircleStructVar.CircleMiddlePoint.X, CreateCircleStructVar.CircleMiddlePoint.Y) 'don't use grid mouse position
For PointLoop = 1 To CreateCircleStructVar.CirclePointNumber
'PointStructArray (CreateCircleStructVar.CirclePointStartIndex + PointLoop ‑ 1).X =
Next PointLoop
End If
If DeskStructVar.DrawingFinishedFlag = False Then
If PointMoveStructVar.PointMoveEnabledFlag = True Then
Call Point_Move(PointMoveStructVar.PointStructIndex, MouseGridXPos, MouseGridYPos)
Call Desk_Redraw(MouseXPos, MouseYPos, False) 'draw line from last point to mouse cursor
GoTo Jump1:
End If
If DeskOffSetChangeStructVar.OffSetChangeEnabledFlag = True Then
DeskOffSetStructVar.OffSetX = DeskOffSetChangeStructVar.OffSetXUnchanged + _
(X ‑ DeskOffSetChangeStructVar.MouseXUnchanged)
DeskOffSetStructVar.OffSetY = DeskOffSetChangeStructVar.OffSetYUnchanged + _
(Y ‑ DeskOffSetChangeStructVar.MouseYUnchanged)
Call GetGridPosFromMousePos(DeskOffSetStructVar.OffSetX, DeskOffSetStructVar.OffSetY) 'move on grid only
Call Desk_Redraw(MouseXPos, MouseYPos, True)
DeskInfoStructVar.ViewXOffSet = DeskOffSetStructVar.OffSetX
DeskInfoStructVar.ViewYOffSet = DeskOffSetStructVar.OffSetY
Call DeskInfoPicture_Update(DeskInfoStructVar)
GoTo Jump1:
End If
If 0 = 0 Then 'finally redraw only as mouse pos changed
Call Desk_Redraw(MouseXPos, MouseYPos, False) 'draw line from last point to mouse cursor
End If
Jump1:
Else
If PointMoveStructVar.PointMoveEnabledFlag = True Then
Call Point_Move(PointMoveStructVar.PointStructIndex, MouseGridXPos, MouseGridYPos)
Call Desk_Redraw(MouseXPos, MouseYPos, False) 'mark point closest to mouse cursor
GoTo Jump2:
End If
If DeskOffSetChangeStructVar.OffSetChangeEnabledFlag = True Then
DeskOffSetStructVar.OffSetX = DeskOffSetChangeStructVar.OffSetXUnchanged + _
(X ‑ DeskOffSetChangeStructVar.MouseXUnchanged)
DeskOffSetStructVar.OffSetY = DeskOffSetChangeStructVar.OffSetYUnchanged + _
(Y ‑ DeskOffSetChangeStructVar.MouseYUnchanged)
Call GetGridPosFromMousePos(DeskOffSetStructVar.OffSetX, DeskOffSetStructVar.OffSetY) 'move on grid only
Call Desk_Redraw(MouseXPos, MouseYPos, True)
DeskInfoStructVar.ViewXOffSet = DeskOffSetStructVar.OffSetX
DeskInfoStructVar.ViewYOffSet = DeskOffSetStructVar.OffSetY
Call DeskInfoPicture_Update(DeskInfoStructVar)
GoTo Jump2:
End If
Call Desk_Redraw(MouseXPos, MouseYPos, False) 'mark point closest to mouse cursor
Jump2:
End If
Call Magnifier_Redraw(X, Y)
Exit Sub
End Sub
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
'On Error Resume Next
Dim MouseXPos As Long
Dim MouseYPos As Long
'preset
MouseXPos = GetX
MouseYPos = GetY
Call GetGridPosFromMousePos(MouseXPos, MouseYPos)
'begin
If PointMoveStructVar.PointMoveEnabledFlag = True Then
PointMoveStructVar.PointMoveEnabledFlag = False 'reset
DeskStructVar.DeskChangesExistingFlag = True
Call Point_Move(PointMoveStructVar.PointStructIndex, MouseXPos, MouseYPos) 'make point fit to grid
Call Desk_Redraw(MouseXPos, MouseYPos, False) 'display changes
End If
If DeskOffSetChangeStructVar.OffSetChangeEnabledFlag = True Then
DeskOffSetChangeStructVar.OffSetChangeEnabledFlag = False 'reset
Me.MousePointer = vbNormal
End If
End Sub
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
'On Error Resume Next
Dim MouseXPos As Long
Dim MouseYPos As Long
'preset
MouseXPos = GetX
MouseYPos = GetY
'begin
Select Case KeyCode
Case vbKeyControl
Me.MousePointer = vbSizePointer
Case 32 'Space
If DeskStructVar.DrawingFinishedFlag = False Then
Call GetGridPosFromMousePos(MouseXPos, MouseYPos)
If Not (PointStructIndexFromMousePos(MouseXPos, MouseYPos) = 1) Then
'point to add does not match first added point
If PointStructIndexFromMousePos(MouseXPos, MouseYPos) = 0 Then 'do not add a point twice
DeskStructVar.DeskChangesExistingFlag = True
Call Point_Add(MouseXPos, MouseYPos)
Call Desk_Redraw(MouseXPos, MouseYPos, False)
Call Magnifier_Redraw(True, True) 'use last passed mouse position
End If
Else
'point to add matches first added point
If Not (PointStructNumber < 3) Then
DeskStructVar.DrawingFinishedFlag = True
DeskStructVar.DeskChangesExistingFlag = True
Call Desk_Redraw(MouseXPos, MouseYPos, False)
Call Magnifier_Redraw(True, True) 'use last passed mouse position
Else
MsgBox "Please create at least 3 points !", vbOKOnly + vbExclamation
End If
End If
Else
MsgBox "Drawing was finished, use 'Ins' to insert a point or choose 'Continue Drawing' from the window menu.", vbOKOnly + vbInformation
End If
Case 45 'Ins
If DeskStructVar.DrawingFinishedFlag = True Then
Call GetGridPosFromMousePos(MouseXPos, MouseYPos)
If PointStructIndexFromMousePos(MouseXPos, MouseYPos) = 0 Then
DeskStructVar.DeskChangesExistingFlag = True
Call Point_AutoInsert(MouseXPos, MouseYPos)
Call Desk_Redraw(MouseXPos, MouseYPos, False) 'display changes
Call Magnifier_Redraw(True, True) 'use last passed mouse position
End If
End If
Case 46 'Del
If Not (DeskStructVar.MarkedPointIndex = 0) Then 'verify
If (PointStructNumber > 3) Or (DeskStructVar.DrawingFinishedFlag = False) Then 'verify
DeskStructVar.DeskChangesExistingFlag = True
Call Point_Remove(DeskStructVar.MarkedPointIndex)
Call Desk_Redraw(MouseXPos, MouseYPos, False)
Call Magnifier_Redraw(True, True) 'use last passed mouse position
Else
MsgBox "At least 3 points must rest !", vbOKOnly + vbExclamation
End If
End If
Case 72 'h
DeskStructVar.PointRectDisabledFlag = True
Call Desk_Redraw(MouseXPos, MouseYPos, True)
Call Magnifier_Redraw(True, True) 'use last passed mouse position
End Select
End Sub
Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
'on error resume next
Dim MouseXPos As Long
Dim MouseYPos As Long
'preset
MouseXPos = GetX
MouseYPos = GetY
'begin
Select Case KeyCode
Case vbKeyControl
If DeskOffSetChangeStructVar.OffSetChangeEnabledFlag = False Then
'NOTE: if mouse pointer is not reset here then in Form_MouseUp().
Me.MousePointer = vbNormal
End If
Case vbKeyH
DeskStructVar.PointRectDisabledFlag = False 'reset
Call Desk_Redraw(MouseXPos, MouseYPos, True)
Call Magnifier_Redraw(True, True) 'use last passed mouse position
End Select
End Sub
'**********************************END OF FORM EVENTS***********************************
'**************************************MENU EVENTS**************************************
'NOTE: the menu click processing subs are ordered like the menu items
'(sub related to first menu item comes first).
Private Sub MenuAbort_Click()
'On Error Resume Next
DeskStructVar.CancelFlag = True
End Sub
Private Sub MenuBackPictureEnabled_Click()
'on error resume next
If DeskStructVar.DeskBackPictureEnabledFlag = True Then
DeskStructVar.DeskBackPictureEnabledFlag = False
MenuBackPictureEnabled.Checked = False
Else
DeskStructVar.DeskBackPictureEnabledFlag = True
MenuBackPictureEnabled.Checked = True
Call SEM_PolyRgn_BackPicture_Transfer(DeskStructVar.PolyRgnFormName, DeskStructVar.PolyRgnFormObject)
End If
Call DeskToReg 'save changes
Call Desk_Redraw(0, 0, True) 'display changes
End Sub
Private Sub MenuGridColor_Click()
'on error resume next
Dim NULLARRAYLONG(0 To 0) As Long
Dim GridColor As Long
'begin
GridColor = GFCDGetColor(DeskStructVar.GridColor, 0, NULLARRAYLONG())
If Not (GridColor = True) Then
DeskStructVar.GridColor = GridColor
Call DeskToReg 'save changes
Call Desk_Redraw(0, 0, True) 'display changes
End If
End Sub
Private Sub MenuKeys_Click()
'on error resume next
Call GFMsgBoxmod.GFStatisticsBox( _
"Use this tool to manipulate a window's region to make it look round," + Chr$(13) + Chr$(10) + _
"like an ellipse or having the form of its back picture. Just try it out !" + Chr$(13) + Chr$(10) + _
"You might need to use the following keys:" + Chr$(13) + Chr$(10) + _
Chr$(13) + Chr$(10) + _
"Draw mode" + Chr$(13) + Chr$(10) + _
"‑‑‑‑‑‑‑‑‑" + Chr$(13) + Chr$(10) + _
"Space.. : create point" + Chr$(13) + Chr$(10) + _
Chr$(13) + Chr$(10) + _
"Using the very first point as a line end point ends draw mode and" + Chr$(13) + Chr$(10) + _
"starts edit mode." + Chr$(13) + Chr$(10) + _
Chr$(13) + Chr$(10) + _
"Edit mode" + Chr$(13) + Chr$(10) + _
"‑‑‑‑‑‑‑‑‑" + Chr$(13) + Chr$(10) + _
"Ins.... : insert new point" + Chr$(13) + Chr$(10) + _
"Del.... : remove marked point" + Chr$(13) + Chr$(10) + _
Chr$(13) + Chr$(10) + _
"Press 'h' to hide the line end point boxes (full visibility of line shapes)" + Chr$(13) + Chr$(10) + _
Chr$(13) + Chr$(10) + _
"You may take advantage of the copy and paste function," + Chr$(13) + Chr$(10) + _
"See also Options menu for further settings.", _
App.ProductName)
End Sub
Private Sub MenuLineInvertedEnabled_Click()
'on error resume next
DeskStructVar.LineInColorOrInvertedFlag = False
Call DeskToReg 'save changes
Call Desk_Redraw(0, 0, True) 'display changes
End Sub
Private Sub MenuLineInColorEnabled_Click()
'on error resume next
DeskStructVar.LineInColorOrInvertedFlag = True
Call DeskToReg 'save changes
Call Desk_Redraw(0, 0, True) 'display changes
End Sub
Private Sub MenuLineNormalColor_Click()
'on error resume next
Dim NULLARRAYLONG(0 To 0) As Long
Dim LineNormalColor As Long
'begin
LineNormalColor = GFCDGetColor(DeskStructVar.LineColorNormal, 0, NULLARRAYLONG())
If Not (LineNormalColor = True) Then
DeskStructVar.LineColorNormal = LineNormalColor
Call DeskToReg 'save changes
Call Desk_Redraw(0, 0, True) 'display changes
End If
End Sub
Private Sub MenuLineMarkedColor_Click()
'on error resume next
Dim NULLARRAYLONG(0 To 0) As Long
Dim LineMarkedColor As Long
'begin
LineMarkedColor = GFCDGetColor(DeskStructVar.LineColorMarked, 0, NULLARRAYLONG())
If Not (LineMarkedColor = True) Then
DeskStructVar.LineColorMarked = LineMarkedColor
Call DeskToReg 'save changes
Call Desk_Redraw(0, 0, True) 'display changes
End If
End Sub
Private Sub MenuContinueDrawing_Click()
'on error resume next
DeskStructVar.DrawingFinishedFlag = False
DeskStructVar.DeskChangesExistingFlag = True
Call Desk_Redraw(0, 0, True)
End Sub
Private Sub MenuCopyRegion_Click()
'on error resume next
Dim TransferLoop As Integer
'verify
If Not (CopyPointStructNumber < 3) Then 'in a test I accidently deleted my copied region :‑(
If MsgBox("Do you want to overwrite the copied region in the buffer ?", vbYesNo + vbQuestion) = vbNo Then Exit Sub 'user canceled
End If
'begin
CopyPointStructNumber = PointStructNumber
If Not (CopyPointStructNumber = 0) Then
ReDim CopyPointStructArray(1 To CopyPointStructNumber) As PointStruct
For TransferLoop = 1 To PointStructNumber
CopyPointStructArray(TransferLoop) = PointStructArray(TransferLoop)
Next TransferLoop
Else
ReDim CopyPointStructArray(1 To 1) As PointStruct 'reset
End If
End Sub
Private Sub MenuCreateCircle_Click()
'on error resume next
Call Desk_CreateCircle
End Sub
Private Sub MenuFinishDrawing_Click()
'on error resume next
If Not (PointStructNumber < 3) Then 'verify
DeskStructVar.DrawingFinishedFlag = True
DeskStructVar.DeskChangesExistingFlag = True
Call Desk_Redraw(0, 0, True)
Else
MsgBox "Please create at least 3 points !", vbOKOnly + vbExclamation
End If
End Sub
Private Sub MenuFinished_Click()
'On Error Resume Next
If (Not (PointStructNumber < 3)) And (DeskStructVar.DrawingFinishedFlag = True) Then 'verify
DeskStructVar.ContinueFlag = True
Else
MsgBox "You must create at least 3 points and the last point must match the first one !", vbOKOnly + vbCritical
End If
End Sub
Private Sub MenuFitRegion_Click()
'On Error Resume Next
Dim PointLoop As Integer
'verify
If PointStructNumber > 4 Then
If MsgBox("The number of points will be decreased to 4. Continue ?", vbYesNo + vbQuestion) = vbNo Then
Exit Sub
Else
For PointLoop = 5 To PointStructNumber
Call Point_Remove(5) 'subsequent points will be moved 'downwards'
Next PointLoop
End If
End If
If PointStructNumber < 4 Then
For PointLoop = PointStructNumber To 3
Call Point_Add(0, 0)
Next PointLoop
End If
'begin (exactly 4 points are existing)
Call Point_Move(1, 0, 0)
Call Point_Move(2, DeskStructVar.WindowWidth, 0)
Call Point_Move(3, DeskStructVar.WindowWidth, DeskStructVar.WindowHeight)
Call Point_Move(4, 0, DeskStructVar.WindowHeight)
DeskStructVar.DrawingFinishedFlag = True 'user can continue if he/she wants
Call Desk_Redraw(0, 0, True) 'display changes
End Sub
Private Sub MenuGridEnabled_Click()
'On Error Resume Next
If DeskStructVar.GridEnabledFlag = True Then
DeskStructVar.GridEnabledFlag = False
MenuGridEnabled.Checked = False
Else
DeskStructVar.GridEnabledFlag = True
MenuGridEnabled.Checked = True
End If
Call DeskToReg 'save changes
Call Desk_Redraw(0, 0, True) 'display changes
End Sub
Private Sub MenuGridVisible_Click()
'on error resume next
If DeskStructVar.GridVisibleFlag = True Then
DeskStructVar.GridVisibleFlag = False
MenuGridVisible.Checked = False
Else
DeskStructVar.GridVisibleFlag = True
MenuGridVisible.Checked = True
End If
Call DeskToReg 'save changes
Call Desk_Redraw(0, 0, True) 'display changes
End Sub
Private Sub MenuToggleGridZoomFactor_Click()
'on error resume next
DeskStructVar.GridZoomFactor = DeskStructVar.GridZoomFactor + 0.25
Select Case DeskStructVar.GridZoomFactor
Case Is > 2!
DeskStructVar.GridZoomFactor = 1!
Case Is < 1! 'should not happen
DeskStructVar.GridZoomFactor = 1!
End Select
Call DeskToReg 'save changes
Call Desk_Redraw(0, 0, True) 'display changes
End Sub
Private Sub MenuInfoEnabled_Click()
'on error resume next
If DeskStructVar.DeskInfoEnabledFlag = True Then
DeskStructVar.DeskInfoEnabledFlag = False
DeskInfoFrame.Visible = False
MenuInfoEnabled.Checked = False
Else
DeskStructVar.DeskInfoEnabledFlag = True
DeskInfoFrame.Visible = True
MenuInfoEnabled.Checked = True
End If
Call DeskToReg 'save changes
Call Desk_Redraw(0, 0, True) 'display changes
End Sub
Private Sub MenuBackPictureInverted_Click()
'on error resume next
DeskStructVar.DeskBackPictureInvertedFlag = Not (DeskStructVar.DeskBackPictureInvertedFlag)
MenuBackPictureInverted.Checked = Not (MenuBackPictureInverted.Checked)
Call DeskToReg 'save changes
Call Desk_Redraw(0, 0, True) 'display changes
End Sub
Private Sub MenuPasteRegion_Click()
'on error resume next
Dim TransferLoop As Integer
'verify
If CopyPointStructNumber < 3 Then
MsgBox "The region to paste is invalid !", vbOKOnly + vbExclamation
Exit Sub 'error
End If
If Not (PointStructNumber = 0) Then
If MsgBox("Are you sure you want to overwrite the current region ?", vbYesNo + vbQuestion) = vbNo Then
Exit Sub
End If
End If
'begin
PointStructNumber = CopyPointStructNumber
If Not (PointStructNumber = 0) Then
ReDim PointStructArray(1 To CopyPointStructNumber) As PointStruct
For TransferLoop = 1 To PointStructNumber
PointStructArray(TransferLoop) = CopyPointStructArray(TransferLoop)
Next TransferLoop
Else
ReDim PointStructArray(1 To 1) As PointStruct 'reset
End If
DeskStructVar.DrawingFinishedFlag = True
DeskStructVar.DeskChangesExistingFlag = True
Call Desk_Redraw(0, 0, True)
End Sub
Private Sub MenuReset_Click()
'On Error Resume Next
If MsgBox("Are you sure you want to create a completely new poly rgn ?", vbYesNo + vbQuestion) = vbYes Then
DeskStructVar.DeskChangesExistingFlag = True
Call Desk_Reset
End If
End Sub
'**********************************END OF MENU EVENTS***********************************
'**************************************POLYRGNDESK**************************************
'NOTE: the target project should first call PolyRgndesk_Initialize() to initialize special settings,
'then call PolyRgnDesk_Draw() to show GFSkinEngine_PolyRgnDeskfrm and to allow
'the user to draw his/her poly rgn. By calling PolyRgnDesk_Abort the drawing
'can be ended by the target project (instead of by the user).
'***INTERFACE SUBS***
Public Sub PolyRgnDesk_Initialize(ByVal DeskWidth As Long, ByVal DeskHeight As Long, ByVal GridDistance As Long, ByVal GridColor As Long, ByVal PointRectColorNormal As Long, ByVal PointRectColorMarked As Long, ByVal LineColorNormal As Long, ByVal LineColorMarked As Long, ByVal PolyRgnFormName As String, ByRef PolyRgnFormObject As Object)
'On Error Resume Next 'format: pixels, pass "" to disable desk picture
'preset
DeskStructVar.GridDistance = GridDistance
DeskStructVar.GridColor = GridColor
DeskStructVar.PointRectColorNormal = PointRectColorNormal
DeskStructVar.PointRectColorMarked = PointRectColorMarked
DeskStructVar.LineColorNormal = LineColorNormal
DeskStructVar.LineColorMarked = LineColorMarked
'begin
'
'NOTE: the desk is the drawing area, some pixels must be added for the
'window frame and title bar.
'
GFSkinEngine_PolyRgnDeskfrm.ScaleMode = vbTwips
If GFSkinEngine_PolyRgnDeskfrm.WindowState = vbNormal Then 'verify (important)
'NOTE: set the form's non‑minimized or ‑maximized size once before showing the form the first time (maximized).
GFSkinEngine_PolyRgnDeskfrm.Width = DeskWidth * Screen.TwipsPerPixelX + (Me.Width ‑ Me.ScaleWidth)
GFSkinEngine_PolyRgnDeskfrm.Height = DeskHeight * Screen.TwipsPerPixelY + (Me.Height ‑ Me.ScaleHeight)
End If
'
GFSkinEngine_PolyRgnDeskfrm.AutoRedraw = True
GFSkinEngine_PolyRgnDeskfrm.ScaleMode = vbPixels 'set after setting form size
GFSkinEngine_PolyRgnDeskfrm.ForeColor = GridColor
'DeskStructVar.GridEnabledFlag = True 'done in Form_Load event to allow retaining flag
GridPicture.AutoRedraw = True
GridPicture.ScaleMode = vbPixels 'important
GridMaskPicture.AutoRedraw = True
GridMaskPicture.ScaleMode = vbPixels 'important
DeskStructVar.PolyRgnFormName = PolyRgnFormName
Set DeskStructVar.PolyRgnFormObject = PolyRgnFormObject
DeskStructVar.DeskBackPictureName = ""
DeskStructVar.DeskBackPictureEnabledFlag = False
DeskStructVar.DeskInfoEnabledFlag = True
DeskStructVar.DeskInitializedFlag = True
DeskStructVar.GridZoomFactor = 1! 'preset (important)
Call DeskFromReg 'if not DeskToReg was called in a former session the default values above will be used
Call Grid_Create(150, 150, DeskStructVar) 'container uses the format pixels, call after flag above (DeskInitializedFlag) has been set to True
Call Grid_Redraw 'important (otherwise only done when resizing form)
End Sub
Public Function PolyRgnDesk_Draw(ByRef PointNumber As Integer, ByRef PointXPosArray() As Long, ByRef PointYPosArray() As Long, ByVal WindowWidth As Long, ByVal WindowHeight As Long, ByVal PolyRgnFormName As String, ByRef PolyRgnFormObject As Object) As Boolean
'On Error Resume Next 'returns True if new poly rgn has been set, False if user aborted
Dim TransferLoop As Integer
Dim Temp As Long
'
'NOTE: the window width/height is used to allow creating a region that
'has exactly the window dimensions (does not influence Me.[Width/Height]).
'
'verify
If DeskStructVar.DeskInitializedFlag = False Then
MsgBox "internal error in PlayRgnDesk_Draw(): initialize first !", vbOKOnly + vbExclamation
PolyRgnDesk_Draw = False 'error
Exit Function 'error
End If
If PolyRgnDesk_DrawCalledFlag = True Then
PointNumber = 0 'reset
ReDim PointXPosArray(1 To 1) As Long 'reset
ReDim PointYPosArray(1 To 1) As Long 'reset
PolyRgnDesk_Draw = False
Else
PolyRgnDesk_DrawCalledFlag = True
End If
'preset
DeskStructVar.WindowWidth = WindowWidth 'format: pixels
DeskStructVar.WindowHeight = WindowHeight 'format: pixels
Me.Show 'important or Me.ScaleWidth is incorrect (form is maximized after displaying, VB sucks)
DeskOffSetStructVar.OffSetX = (Me.ScaleWidth / 2&) ‑ (WindowWidth / 2&)
If DeskInfoFrame.Visible = True Then
DeskOffSetStructVar.OffSetY = ((Me.ScaleHeight ‑ DeskInfoFrame.Height) / 2&) ‑ (WindowHeight / 2&)
Else
DeskOffSetStructVar.OffSetY = (Me.ScaleHeight / 2&) ‑ (WindowHeight / 2&)
End If
Call GetGridPosFromMousePos(DeskOffSetStructVar.OffSetX, DeskOffSetStructVar.OffSetY) 'move picture on grid only
DeskInfoStructVar.RgnWindowXSize = WindowWidth
DeskInfoStructVar.RgnWindowYSize = WindowHeight
Call DeskInfoPicture_Update(DeskInfoStructVar)
DeskStructVar.DeskChangesExistingFlag = False 'reset (enable from highest level only)
PointStructNumber = PointNumber
If Not (PointStructNumber = 0) Then 'verify
'transfer existing points to point struct
DeskStructVar.DrawingFinishedFlag = True
'
'NOTE: if a default poly rgn was passed, drawing has finished by default
'(the user can choose 'reset' from the menu to create a completely new rgn).
'
ReDim PointStructArray(1 To PointStructNumber) As PointStruct
For TransferLoop = 1 To PointNumber
PointStructArray(TransferLoop).X = PointXPosArray(TransferLoop)
PointStructArray(TransferLoop).Y = PointYPosArray(TransferLoop)
Next TransferLoop
Call Desk_Redraw(0, 0, True)
Else
'create 4 new points
Call MenuFitRegion_Click
End If
'show window
Me.Enabled = True
Me.Visible = True
Me.Refresh
Call SE_ForwardCallBackMessage(SECBMSG_POLYRGNDESKFRM_OPENED, "", "")
ReDo:
DeskStructVar.ContinueFlag = False
DeskStructVar.CancelFlag = False
Me.SetFocus
'begin
Do
Call Sleep(50)
DoEvents
Loop Until (DeskStructVar.ContinueFlag = True) Or (DeskStructVar.CancelFlag = True)
'verify created region
If DeskStructVar.ContinueFlag = True Then
If Point_Verify(PointStructNumber, PointStructArray(), WindowWidth, WindowHeight) = False Then GoTo ReDo:
End If
'hide window
Me.Visible = False
Me.Enabled = False
Me.Refresh
Call SE_ForwardCallBackMessage(SECBMSG_POLYRGNDESKFRM_CLOSED, "", "")
'transfer values
If DeskStructVar.ContinueFlag = True Then
If Not (PointStructNumber = 0) Then 'verify
PointNumber = PointStructNumber
ReDim PointXPosArray(1 To PointNumber) As Long
ReDim PointYPosArray(1 To PointNumber) As Long
For Temp = 1 To PointStructNumber
PointXPosArray(Temp) = PointStructArray(Temp).X
PointYPosArray(Temp) = PointStructArray(Temp).Y
Next Temp
PolyRgnDesk_DrawCalledFlag = False 'reset
PolyRgnDesk_Draw = True
Else
PointNumber = 0 'reset
ReDim PointXPosArray(1 To 1) As Long 'reset
ReDim PointYPosArray(1 To 1) As Long 'reset
PolyRgnDesk_DrawCalledFlag = False 'reset
PolyRgnDesk_Draw = True
End If
Else
PointNumber = 0 'reset
ReDim PointXPosArray(1 To 1) As Long 'reset
ReDim PointYPosArray(1 To 1) As Long 'reset
PolyRgnDesk_DrawCalledFlag = False 'reset
PolyRgnDesk_Draw = False
End If
Call Desk_Reset 'reset for next usage
End Function
Public Sub PolyRgnDesk_Abort()
'on error resume next 'call to immediately close this form as e.g. the current skin is to be changed
If PolyRgnDesk_DrawCalledFlag = True Then 'verify poly rgn desk is used
If DeskStructVar.DeskChangesExistingFlag = False Then
DeskStructVar.CancelFlag = True
Else
'NOTE: do not allow canceling like when closing form via X button.
If MsgBox("Save changes made on region ?", vbYesNo + vbQuestion) = vbYes Then
Call MenuFinished_Click
Else
Call MenuAbort_Click
End If
End If
End If
End Sub
'***END OF INTERFACE SUBS***
'**********************************END OF POLYRGNDESK***********************************
'*****************************************DESK******************************************
'NOTE: the Desk code is used to make the current poly rgn visible in
'GFSkinEngine_PolyRgnDeskfrm. The Desk code also provides an interface
'between the poly rgn edit code and the target project.
'***INTERFACE SUBS***
Public Function Desk_GetPolyRgnFormName() As String
'on error resume next 'name of form whose poly rgn is to be changed
Desk_GetPolyRgnFormName = DeskStructVar.PolyRgnFormName
End Function
Public Function Desk_GetPolyRgnFormObject() As Object
'on error resume next 'form object whose poly rgn is to be changed
Set Desk_GetPolyRgnFormObject = DeskStructVar.PolyRgnFormObject
End Function
Public Sub Desk_SetBackPicture(ByVal BackPictureName As String)
'on error resume next
If Not ((Dir$(BackPictureName) = "") Or (Right$(BackPictureName, 1) = "\") Or (BackPictureName = "")) Then 'verify
DeskStructVar.DeskBackPictureName = BackPictureName
DeskStructVar.DeskBackPictureEnabledFlag = True
MenuBackPictureEnabled.Checked = True
Call Desk_Redraw(0, 0, True)
Else
If Not (BackPictureName = "") Then 'nothing is valid for no desk picture
MsgBox "internal error in Desk_SetBackPicture() (GFSkinEngine): file '" + BackPictureName + "' not found !", vbOKOnly + vbExclamation
End If
End If
End Sub
Public Function Desk_GetBackPicture() As String
'on error resume next
Desk_GetBackPicture = DeskStructVar.DeskBackPictureName
End Function
'***END OF INTERFACE SUBS***
Private Sub Desk_UpdatePopUpMenu(ByVal MenuIndex As Integer)
'on error resume next 'update like a tracked pop up menu
Select Case MenuIndex
Case 1 'MenuMain
If (DeskStructVar.DrawingFinishedFlag = True) And (Not (PointStructNumber < 3)) Then
MenuFinished.Enabled = True
Else
MenuFinished.Enabled = False
End If
Case 2 'MenuGrid
If (DeskStructVar.GridEnabledFlag = True) Then
MenuGridEnabled.Checked = True
Else
MenuGridEnabled.Checked = False
End If
If (DeskStructVar.GridVisibleFlag = True) Then
MenuGridVisible.Checked = True
Else
MenuGridVisible.Checked = False
End If
MenuToggleGridZoomFactor.Caption = "Toggle Grid Zoom (currently " + LTrim$(Str$(DeskStructVar.GridZoomFactor * 100!)) + "%)"
If (DeskStructVar.LineInColorOrInvertedFlag = True) Then
MenuLineInvertedEnabled.Checked = False
MenuLineInColorEnabled.Checked = True
Else
MenuLineInvertedEnabled.Checked = True
MenuLineInColorEnabled.Checked = False
End If
Case 3 'MenuSpecials
If Not ((DeskStructVar.WindowWidth = 0) Or (DeskStructVar.WindowHeight = 0)) Then 'verify
MenuFitRegion.Enabled = True
Else
MenuFitRegion.Enabled = False
End If
If (DeskStructVar.DrawingFinishedFlag = True) Then
MenuContinueDrawing.Enabled = True
Else
MenuContinueDrawing.Enabled = False
End If
If (DeskStructVar.DrawingFinishedFlag = False) Then
MenuFinishDrawing.Enabled = True
Else
MenuFinishDrawing.Enabled = False
End If
If (DeskStructVar.DrawingFinishedFlag = True) And (Not (PointStructNumber < 3)) Then
MenuCopyRegion.Enabled = True
Else
MenuCopyRegion.Enabled = False
End If
If Not (CopyPointStructNumber < 3) Then
MenuPasteRegion.Enabled = True
Else
MenuPasteRegion.Enabled = False
End If
End Select
End Sub
Private Sub DeskToReg()
'on error resume next
'preset
Call Rmod.RegDeleteSubKey(SESystemStructVar.RegMainKey, SESystemStructVar.RegRootKey + "Desk\")
Call Rmod.RegCreateSubKey(SESystemStructVar.RegMainKey, SESystemStructVar.RegRootKey + "Desk\")
'begin
Call Rmod.RegSetKeyValue(SESystemStructVar.RegMainKey, SESystemStructVar.RegRootKey + "Desk\", _
"grid enabled", CVar(BOOLTOSTRING(DeskStructVar.GridEnabledFlag)), REG_SZ)
Call Rmod.RegSetKeyValue(SESystemStructVar.RegMainKey, SESystemStructVar.RegRootKey + "Desk\", _
"grid visible", CVar(BOOLTOSTRING(DeskStructVar.GridVisibleFlag)), REG_SZ)
Call Rmod.RegSetKeyValue(SESystemStructVar.RegMainKey, SESystemStructVar.RegRootKey + "Desk\", _
"grid color", CVar(COLORTOSTRING(DeskStructVar.GridColor)), REG_SZ)
Call Rmod.RegSetKeyValue(SESystemStructVar.RegMainKey, SESystemStructVar.RegRootKey + "Desk\", _
"back picture enabled", CVar(BOOLTOSTRING(DeskStructVar.DeskBackPictureEnabledFlag)), REG_SZ)
Call Rmod.RegSetKeyValue(SESystemStructVar.RegMainKey, SESystemStructVar.RegRootKey + "Desk\", _
"back picture inverted", CVar(BOOLTOSTRING(DeskStructVar.DeskBackPictureInvertedFlag)), REG_SZ)
Call Rmod.RegSetKeyValue(SESystemStructVar.RegMainKey, SESystemStructVar.RegRootKey + "Desk\", _
"info enabled", CVar(BOOLTOSTRING(DeskStructVar.DeskInfoEnabledFlag)), REG_SZ)
Call Rmod.RegSetKeyValue(SESystemStructVar.RegMainKey, SESystemStructVar.RegRootKey + "Desk\", _
"line in color or inverted", CVar(BOOLTOSTRING(DeskStructVar.LineInColorOrInvertedFlag)), REG_SZ)
Call Rmod.RegSetKeyValue(SESystemStructVar.RegMainKey, SESystemStructVar.RegRootKey + "Desk\", _
"line color normal", CVar(COLORTOSTRING(DeskStructVar.LineColorNormal)), REG_SZ)
Call Rmod.RegSetKeyValue(SESystemStructVar.RegMainKey, SESystemStructVar.RegRootKey + "Desk\", _
"line color marked", CVar(COLORTOSTRING(DeskStructVar.LineColorMarked)), REG_SZ)
End Sub
Private Sub DeskFromReg()
'on error resume next
Dim Tempstr$
'
Rmod.RegGetKeyValueErrorFlag = False 'reset
Tempstr$ = Rmod.RegGetKeyValue(SESystemStructVar.RegMainKey, SESystemStructVar.RegRootKey + "Desk\", _
"grid enabled")
If Rmod.RegGetKeyValueErrorFlag = False Then
DeskStructVar.GridEnabledFlag = STRINGTOBOOL(Tempstr$)
MenuGridEnabled.Checked = DeskStructVar.GridEnabledFlag
End If
'
Rmod.RegGetKeyValueErrorFlag = False 'reset
Tempstr$ = Rmod.RegGetKeyValue(SESystemStructVar.RegMainKey, SESystemStructVar.RegRootKey + "Desk\", _
"grid visible")
If Rmod.RegGetKeyValueErrorFlag = False Then
DeskStructVar.GridVisibleFlag = STRINGTOBOOL(Tempstr$)
MenuGridVisible.Checked = DeskStructVar.GridVisibleFlag
End If
'
Rmod.RegGetKeyValueErrorFlag = False 'reset
Tempstr$ = Rmod.RegGetKeyValue(SESystemStructVar.RegMainKey, SESystemStructVar.RegRootKey + "Desk\", _
"grid color")
If Rmod.RegGetKeyValueErrorFlag = False Then
DeskStructVar.GridColor = STRINGTOCOLOR(Tempstr$)
End If
'
Rmod.RegGetKeyValueErrorFlag = False 'reset
Tempstr$ = Rmod.RegGetKeyValue(SESystemStructVar.RegMainKey, SESystemStructVar.RegRootKey + "Desk\", _
"back picture enabled")
If Rmod.RegGetKeyValueErrorFlag = False Then
DeskStructVar.DeskBackPictureEnabledFlag = STRINGTOBOOL(Tempstr$)
MenuBackPictureEnabled.Checked = DeskStructVar.DeskBackPictureEnabledFlag
End If
'
Rmod.RegGetKeyValueErrorFlag = False 'reset
Tempstr$ = Rmod.RegGetKeyValue(SESystemStructVar.RegMainKey, SESystemStructVar.RegRootKey + "Desk\", _
"back picture inverted")
If Rmod.RegGetKeyValueErrorFlag = False Then
DeskStructVar.DeskBackPictureInvertedFlag = STRINGTOBOOL(Tempstr$)
MenuBackPictureInverted.Checked = DeskStructVar.DeskBackPictureInvertedFlag
End If
'
Rmod.RegGetKeyValueErrorFlag = False 'reset
Tempstr$ = Rmod.RegGetKeyValue(SESystemStructVar.RegMainKey, SESystemStructVar.RegRootKey + "Desk\", _
"info enabled")
If Rmod.RegGetKeyValueErrorFlag = False Then
DeskStructVar.DeskInfoEnabledFlag = STRINGTOBOOL(Tempstr$)
DeskInfoFrame.Visible = STRINGTOBOOL(Tempstr$)
MenuInfoEnabled.Checked = DeskStructVar.DeskInfoEnabledFlag
End If
'
Rmod.RegGetKeyValueErrorFlag = False 'reset
Tempstr$ = Rmod.RegGetKeyValue(SESystemStructVar.RegMainKey, SESystemStructVar.RegRootKey + "Desk\", _
"line in color or inverted")
If Rmod.RegGetKeyValueErrorFlag = False Then
DeskStructVar.LineInColorOrInvertedFlag = STRINGTOBOOL(Tempstr$)
MenuLineInColorEnabled.Checked = (DeskStructVar.LineInColorOrInvertedFlag)
MenuLineInvertedEnabled.Checked = Not (DeskStructVar.LineInColorOrInvertedFlag)
End If
'
Rmod.RegGetKeyValueErrorFlag = False 'reset
Tempstr$ = Rmod.RegGetKeyValue(SESystemStructVar.RegMainKey, SESystemStructVar.RegRootKey + "Desk\", _
"line color normal")
If Rmod.RegGetKeyValueErrorFlag = False Then DeskStructVar.LineColorNormal = STRINGTOCOLOR(Tempstr$)
'
Rmod.RegGetKeyValueErrorFlag = False 'reset
Tempstr$ = Rmod.RegGetKeyValue(SESystemStructVar.RegMainKey, SESystemStructVar.RegRootKey + "Desk\", _
"line color marked")
If Rmod.RegGetKeyValueErrorFlag = False Then DeskStructVar.LineColorMarked = STRINGTOCOLOR(Tempstr$)
'
End Sub
Private Sub Desk_Reset()
'On Error Resume Next
PointStructNumber = 0
ReDim PointStructArray(1 To 1) As PointStruct
DeskStructVar.DrawingFinishedFlag = False
DeskStructVar.DeskChangesExistingFlag = True 'maybe important for redrawing ( ;‑P )
Call Desk_Redraw(0, 0, True)
DeskStructVar.DeskChangesExistingFlag = False 'avoid annoying message when unloading
End Sub
Private Sub Desk_Redraw(ByVal MouseXPos As Long, ByVal MouseYPos As Long, ByVal ForceRedrawFlag As Boolean)
'On Error Resume Next
Dim RedrawFlag As Boolean 'True if desk needs to be redrawn
Dim DrawModeUnchanged As Integer
'preset
If PointMoveStructVar.PointMoveEnabledFlag = False Then
'avoid point‑ and line marking changing when moving a point
DeskStructVar.MarkedPointIndex = GetPointStructIndexFromMousePosEx(MouseXPos, MouseYPos, 35)
DeskInfoStructVar.MarkedPointIndex = DeskStructVar.MarkedPointIndex 'info will be updated anyway in this sub
DeskStructVar.MarkedLineIndex = GetMarkedLineIndexFromMousePos(MouseXPos, MouseYPos, 15)
End If
'
If Not (DeskRedrawStructVar.DrawingFinishedFlagOld = DeskStructVar.DrawingFinishedFlag) Then RedrawFlag = True
If Not (DeskRedrawStructVar.GridEnabledFlagOld = DeskStructVar.GridEnabledFlag) Then RedrawFlag = True
If Not (DeskRedrawStructVar.MarkedPointIndex = DeskStructVar.MarkedPointIndex) Then RedrawFlag = True
If Not (DeskRedrawStructVar.MarkedLineIndex = DeskStructVar.MarkedLineIndex) Then RedrawFlag = True
If Not (DeskRedrawStructVar.PointStructNumber = PointStructNumber) Then RedrawFlag = True
If PointMoveStructVar.PointMoveEnabledFlag = True Then RedrawFlag = True
If (DeskStructVar.DrawingFinishedFlag = False) And (Not (PointStructNumber = 0)) Then RedrawFlag = True
If ForceRedrawFlag = True Then RedrawFlag = True
'
If DeskStructVar.LineInColorOrInvertedFlag = True Then
Me.DrawMode = vbCopyPen
Else
Me.DrawMode = vbInvert
End If
'
If Not ((DeskRedrawStructVar.DeskBackPictureEnabledFlag = DeskStructVar.DeskBackPictureEnabledFlag) And _
(DeskRedrawStructVar.DeskBackPictureName = DeskStructVar.DeskBackPictureName)) Then
If (DeskStructVar.DeskBackPictureEnabledFlag = True) And (Not ((Dir$(DeskStructVar.DeskBackPictureName) = "") Or (Right$(DeskStructVar.DeskBackPictureName, 1) = "\") Or (DeskStructVar.DeskBackPictureName = ""))) Then 'verify
DeskBackPicturePicture.Picture = LoadPicture(DeskStructVar.DeskBackPictureName)
'RedrawFlag = True
Else
DeskBackPicturePicture.Picture = LoadPicture("") 'reset
'RedrawFlag = True
End If
End If
'begin
If RedrawFlag = True Then 'verify desk needs to be redrawn
GFSkinEngine_PolyRgnDeskfrm.Cls 'reset (desk picture is retained)
Call BitBlt(Me.hDC, _
(Me.ScaleWidth / 2!) ‑ (DeskPolyRgnEditLogoPicture.ScaleWidth / 2!), _
(Me.ScaleHeight / 2!) ‑ (DeskPolyRgnEditLogoPicture.ScaleHeight / 2!) ‑ (DeskInfoFrame.Height / 2!), _
DeskPolyRgnEditLogoPicture.ScaleWidth, DeskPolyRgnEditLogoPicture.ScaleHeight, _
DeskPolyRgnEditLogoPicture.hDC, 0, 0, vbSrcCopy)
If DeskStructVar.DeskBackPictureEnabledFlag = True Then
Call BitBlt(Me.hDC, DeskOffSetStructVar.OffSetX, DeskOffSetStructVar.OffSetY, _
DeskBackPicturePicture.ScaleWidth, DeskBackPicturePicture.ScaleHeight, DeskBackPicturePicture.hDC, _
0, 0, vbSrcCopy)
If DeskStructVar.DeskBackPictureInvertedFlag = True Then
DrawModeUnchanged = Me.DrawMode
Me.DrawMode = vbInvert
Me.Line (DeskOffSetStructVar.OffSetX, DeskOffSetStructVar.OffSetY)‑(DeskOffSetStructVar.OffSetX + DeskBackPicturePicture.ScaleWidth, DeskOffSetStructVar.OffSetY + DeskBackPicturePicture.ScaleHeight), 0, BF
Me.DrawMode = DrawModeUnchanged
Else
'Me.Line (DeskOffSetStructVar.OffSetX, DeskOffSetStructVar.OffSetY)‑(DeskOffSetStructVar.OffSetX + DeskBackPicturePicture.ScaleWidth, DeskOffSetStructVar.OffSetY + DeskBackPicturePicture.ScaleHeight), 0, B 'no! (region would not be visible anymore)
End If
Else
DrawModeUnchanged = Me.DrawMode
Me.DrawMode = vbCopyPen
Me.Line (DeskOffSetStructVar.OffSetX, DeskOffSetStructVar.OffSetY)‑(DeskOffSetStructVar.OffSetX + DeskBackPicturePicture.ScaleWidth, DeskOffSetStructVar.OffSetY + DeskBackPicturePicture.ScaleHeight), DeskStructVar.LineColorNormal, B
Me.DrawMode = DrawModeUnchanged
End If
If DeskStructVar.GridVisibleFlag = True Then
Call Grid_Redraw
End If
Call Points_Redraw(MouseXPos, MouseYPos)
GFSkinEngine_PolyRgnDeskfrm.Refresh
Call Desk_UpdatePopUpMenu(1) 'must be done somewhere
Call Desk_UpdatePopUpMenu(2)
Call Desk_UpdatePopUpMenu(3)
End If
'update PointNumber in DeskInfoLabel
DeskInfoStructVar.PointNumber = PointStructNumber
Call DeskInfoPicture_Update(DeskInfoStructVar)
'store current settings for next call of this sub
DeskRedrawStructVar.DrawingFinishedFlagOld = DeskStructVar.DrawingFinishedFlag
DeskRedrawStructVar.GridEnabledFlagOld = DeskStructVar.GridEnabledFlag
DeskRedrawStructVar.MarkedPointIndex = DeskStructVar.MarkedPointIndex
DeskRedrawStructVar.MarkedLineIndex = DeskStructVar.MarkedLineIndex
DeskRedrawStructVar.PointStructNumber = PointStructNumber
DeskRedrawStructVar.DeskBackPictureEnabledFlag = DeskStructVar.DeskBackPictureEnabledFlag
DeskRedrawStructVar.DeskBackPictureName = DeskStructVar.DeskBackPictureName
End Sub
Private Sub Desk_CreateCircle()
'on error resume next
Dim PointLoop As Integer
'
'NOTE: this sub creates a circle. This works as follows:
'(1) an existing line with two fixed end points must be marked (highlighted)
'(2) points are inserted between the end points, the greater the end point
' distance, the more points are inserted.
'(3) The user moves the mouse to size the circle. Sizing works as follows:
'(3a) The middle point between the line end points is determined
'(3b) The distance of the mouse pointer to the middle point sets the circle size
' and 'direction'
'(4) the user left‑clicks to apply the circle or presses 'Esc' or right‑clicks
' to abort
'
If Not (DeskStructVar.MarkedLineIndex = 0) Then 'verify
CreateCircleStructVar.CircleInCreationFlag = True
CreateCircleStructVar.CircleMiddlePoint.X = _
PointStructArray(DeskStructVar.MarkedLineIndex + 0).X + (PointStructArray(DeskStructVar.MarkedLineIndex + 0).X + PointStructArray(DeskStructVar.MarkedLineIndex + 1).X) / 2&
CreateCircleStructVar.CircleMiddlePoint.Y = _
PointStructArray(DeskStructVar.MarkedLineIndex + 0).Y + (PointStructArray(DeskStructVar.MarkedLineIndex + 0).Y + PointStructArray(DeskStructVar.MarkedLineIndex + 1).Y) / 2&
CreateCircleStructVar.CirclePointNumber = GFMaths_Geometrymod.GetPointPointDistLong2D( _
PointStructArray(DeskStructVar.MarkedLineIndex + 0).X, PointStructArray(DeskStructVar.MarkedLineIndex + 0).Y, _
PointStructArray(DeskStructVar.MarkedLineIndex + 1).X, PointStructArray(DeskStructVar.MarkedLineIndex + 0).Y) / _
DeskStructVar.GridDistance 'GridDistance should be around 10
If CreateCircleStructVar.CirclePointNumber < 3 Then CreateCircleStructVar.CirclePointNumber = 3 'verify
CreateCircleStructVar.CirclePointStartIndex = (DeskStructVar.MarkedLineIndex + 1)
'insert circle points into existing point data
For PointLoop = 1 To CreateCircleStructVar.CirclePointNumber
Call Point_Insert(CreateCircleStructVar.CirclePointStartIndex + PointLoop ‑ 1, _
PointStructArray(DeskStructVar.MarkedLineIndex + 0).X + (PointStructArray(DeskStructVar.MarkedLineIndex + 0).X + PointStructArray(DeskStructVar.MarkedLineIndex + PointLoop).X) / CLng(CreateCircleStructVar.CirclePointNumber) * CLng(PointLoop), _
PointStructArray(DeskStructVar.MarkedLineIndex + 0).Y + (PointStructArray(DeskStructVar.MarkedLineIndex + 0).Y + PointStructArray(DeskStructVar.MarkedLineIndex + PointLoop).Y) / CLng(CreateCircleStructVar.CirclePointNumber) * CLng(PointLoop))
'
'NOTE: as a point is inserted, the end point of the line moves 'upwards'
'(that's why PointLoop if added to DeskStructVar.MarkedLineIndex).
'
Next PointLoop
Else
MsgBox "Please mark a line by moving the mouse near the line so that it changes its color. The half‑circle will be created between the marked line's end points.", vbOKOnly + vbInformation 'no real error
End If
End Sub
Private Function GetX() As Long
'On Error Resume Next 'returns mouse coordinates related to desk form
GetX = ProgramGetMousePosX ‑ (GFSkinEngine_PolyRgnDeskfrm.Left / Screen.TwipsPerPixelX) ‑ ((Me.Width ‑ Me.ScaleWidth * Screen.TwipsPerPixelX) / 2 / Screen.TwipsPerPixelX) 'subtrat window frame width
GetX = GetX ‑ DeskOffSetStructVar.OffSetX
If GetX < 0 Then GetX = 0
'If GetX > Me.ScaleWidth Then GetX = Me.ScaleWidth 'no! Form may be larger than ScaleWidth!
If GetX > 5000 Then GetX = 5000
End Function
Private Function GetY() As Long
'On Error Resume Next 'returns mouse coordinates related to desk form
'
'NOTE: to get the screen coordinates of the client area (where drawing is permitted)
'a calculation is used that gets the window frame width for the vertical
'window edges. If a window does not have an equal frame size at
'all edges then the complete calculation below will fail (then damn Microsoft!).
'
GetY = ProgramGetMousePosY ‑ (GFSkinEngine_PolyRgnDeskfrm.Top / Screen.TwipsPerPixelY) ‑ (((Me.Height ‑ Me.ScaleHeight * Screen.TwipsPerPixelY) / Screen.TwipsPerPixelY) ‑ ((Me.Width ‑ Me.ScaleWidth * Screen.TwipsPerPixelX) / Screen.TwipsPerPixelX))
GetY = GetY ‑ DeskOffSetStructVar.OffSetY
If GetY < 0 Then GetY = 0
'If GetY > Me.ScaleHeight Then GetY = Me.ScaleHeight 'no! Form may be larger than ScaleWidth!
If GetY > 5000 Then GetY = 5000
End Function
'**************************************END OF DESK**************************************
'***********************************DESK INFO PICTURE***********************************
'NOTE: the DeskInfoPicture is located between the MagnifierPicture.
'It displays misc. info about the drawing process.
Private Sub DeskInfoPicture_Update(ByRef DeskInfoStructVar As DeskInfoStruct)
'on error resume next
Dim Tempstr$
'
'NOTE: update any value in DeskInfoStructVar and then call this sub to display the changes.
'Using a label instead of a picture box to display info was not possible because os the
'heavy flickering of the label.
'
'begin
Tempstr$ = "Window Size: " + LTrim$(Str$(DeskInfoStructVar.RgnWindowXSize)) + " x " + LTrim$(Str$(DeskInfoStructVar.RgnWindowYSize)) + Chr$(13) + Chr$(10) + _
"Mouse Pos: " + LTrim$(Str$(DeskInfoStructVar.MouseXPos)) + ", " + LTrim$(Str$(DeskInfoStructVar.MouseYPos)) + Chr$(13) + Chr$(10) + _
"Point Count: " + LTrim$(Str$(DeskInfoStructVar.PointNumber)) + " (marked: " + LTrim$(Str$(DeskInfoStructVar.MarkedPointIndex)) + ")" + Chr$(13) + Chr$(10) + _
"Viewing Offset: " + LTrim$(Str$(DeskInfoStructVar.ViewXOffSet)) + ", " + LTrim$(Str$(DeskInfoStructVar.ViewYOffSet))
If Not (Tempstr$ = DeskInfoStructVar.DeskInfoStringOld) Then 'verify to save CPU time
DeskInfoPicture.Cls 'reset
DeskInfoPicture.CurrentX = 0
DeskInfoPicture.CurrentY = 0
DeskInfoPicture.Print Tempstr$
End If
DeskInfoStructVar.DeskInfoStringOld = Tempstr$
End Sub
Private Sub DeskInfoPicture_Paint()
'on error resume next
'
'NOTE: we do not use AutoRedraw to save GUI memory.
'
'DeskInfoPicture.Cls 'not necessary
DeskInfoPicture.CurrentX = 0
DeskInfoPicture.CurrentY = 0
DeskInfoPicture.Print DeskInfoStructVar.DeskInfoStringOld
End Sub
'*******************************END OF DESK INFO PICTURE********************************
'***************************************MAGNIFIER***************************************
'NOTE: the magnifier is a picture box that displays the image around the mouse pointer
'enlarged (factor 2), so that the user can create regions that fit the related form's
'back picture rather exactly.
Private Sub MagnifierPicture_KeyDown(KeyCode As Integer, Shift As Integer)
'on error resume next
Call Form_KeyDown(KeyCode, Shift)
End Sub
Private Sub MagnifierPicture_KeyUp(KeyCode As Integer, Shift As Integer)
'on error resume next
Call Form_KeyUp(KeyCode, Shift)
End Sub
Private Sub Magnifier_Redraw(ByVal MousePosX As Long, ByVal MousePosY As Long)
'on error resume next 'pass mouse position form‑related and in the format pixels, if a mouse position coordinate is True then the last passed value will be used
Dim ViewXPos As Long
Dim ViewYPos As Long
Dim PointerXPos As Long
Dim PointerYPos As Long
'verify
If MousePosX = True Then MousePosX = MagnifierStructVar.MouseXOld
If MousePosY = True Then MousePosY = MagnifierStructVar.MouseYOld
'preset
ViewXPos = MIN(MAX(MousePosX ‑ CLng(MagnifierPicture.ScaleWidth / 4!), 0), Me.ScaleWidth ‑ CLng(MagnifierPicture.ScaleWidth / 2!))
ViewYPos = MIN(MAX(MousePosY ‑ CLng(MagnifierPicture.ScaleHeight / 4!), 0), Me.ScaleHeight ‑ CLng(MagnifierPicture.ScaleHeight / 2!))
'begin
Call StretchBlt(MagnifierPicture.hDC, 0, 0, MagnifierPicture.ScaleWidth, MagnifierPicture.ScaleHeight, _
Me.hDC, ViewXPos, ViewYPos, _
CLng(MagnifierPicture.ScaleWidth / 2!), CLng(MagnifierPicture.ScaleHeight / 2!), vbSrcCopy)
Call MagnifierPicture.Refresh
'
'NOTE: the center of the MagnifierPicture image does not have to
'represent the current mouse location, calculate where mouse mointer would
'be visible in MagnifierPicture and draw a cross there.
'
PointerXPos = (MousePosX ‑ ViewXPos) * 2 'stretched
PointerYPos = (MousePosY ‑ ViewYPos) * 2 'stretched
MagnifierPicture.Line (PointerXPos, PointerYPos ‑ 5)‑(PointerXPos, PointerYPos + 5), 0
MagnifierPicture.Line (PointerXPos ‑ 5, PointerYPos)‑(PointerXPos + 5, PointerYPos), 0
MagnifierStructVar.MouseXOld = MousePosX
MagnifierStructVar.MouseYOld = MousePosY
End Sub
'***********************************END OF MAGNIFIER************************************
'****************************************POINTS*****************************************
'NOTE: the Point subs/functions are used to manipulate the data in PointStructArray().
'The points set the corner locations of the poly rgn.
Private Sub Point_Add(ByVal PointXPos As Long, ByVal PointYPos As Long)
'On Error Resume Next
If Not (PointStructNumber = 32766) Then 'verify
PointStructNumber = PointStructNumber + 1
Else
MsgBox "internal error in Point_Add() (GFSkinEngine): overflow !", vbOKOnly + vbExclamation
End If
ReDim Preserve PointStructArray(1 To PointStructNumber) As PointStruct
PointStructArray(PointStructNumber).X = PointXPos
PointStructArray(PointStructNumber).Y = PointYPos
End Sub
Private Sub Point_Remove(ByVal PointStructIndex As Integer)
'On Error Resume Next
Dim StructLoop As Integer
'verify
If PointStructIndex = 0 Then Exit Sub
If PointStructIndex > PointStructNumber Then Exit Sub
'begin
For StructLoop = PointStructIndex To PointStructNumber
If Not (StructLoop = PointStructNumber) Then
PointStructArray(StructLoop) = PointStructArray(StructLoop + 1)
Else
PointStructNumber = PointStructNumber ‑ 1
StructLoop = PointStructNumber 'not used anymore
If StructLoop < 1 Then StructLoop = 1 'verify
ReDim Preserve PointStructArray(1 To StructLoop) As PointStruct
Exit For
End If
Next StructLoop
End Sub
Private Sub Point_AutoInsert(ByVal MouseXPos As Long, ByVal MouseYPos As Long)
'On Error Resume Next 'call this sub after drawing was finished, a point will be inserted into the line that is closest to the mouse cursor (no distance limit)
Dim MousePoint As PointSingle3D
Dim MarkedLine As LineSingle3D
Dim HelpPlane As PlaneSingle3D
Dim IntersectionPoint As PointSingle3D
Dim MarkedLineIndexOld As Integer
Dim PointNewXPos As Long
Dim PointNewYPos As Long
'preset
MarkedLineIndexOld = DeskStructVar.MarkedLineIndex
'
'NOTE: as there is no distance limit between the mouse cursor and the line where the point will
'be inserted we temporarily determine the marked line without using a maximum distance.
'
DeskStructVar.MarkedLineIndex = GetMarkedLineIndexFromMousePos(MouseXPos, MouseYPos, 256& ^ 3&)
'begin
If (DeskStructVar.DrawingFinishedFlag = True) And Not (DeskStructVar.MarkedLineIndex = 0) Then 'verify
MousePoint.X = MouseXPos
MousePoint.Y = MouseYPos
MousePoint.Z = 0
If Not (DeskStructVar.MarkedLineIndex = PointStructNumber) Then
MarkedLine.X1 = PointStructArray(DeskStructVar.MarkedLineIndex).X
MarkedLine.Y1 = PointStructArray(DeskStructVar.MarkedLineIndex).Y
MarkedLine.Z1 = 0
MarkedLine.X2 = PointStructArray(DeskStructVar.MarkedLineIndex + 1).X
MarkedLine.Y2 = PointStructArray(DeskStructVar.MarkedLineIndex + 1).Y
MarkedLine.Z2 = 0
Else
MarkedLine.X1 = PointStructArray(PointStructNumber).X
MarkedLine.Y1 = PointStructArray(PointStructNumber).Y
MarkedLine.Z1 = 0
MarkedLine.X2 = PointStructArray(1).X
MarkedLine.Y2 = PointStructArray(1).Y
MarkedLine.Z2 = 0
End If
HelpPlane = GetHelpPlane(MousePoint, MarkedLine)
If GetLinePlaneIntersectionPoint(MarkedLine, HelpPlane, IntersectionPoint) = True Then 'verify there is an intersection point
'
'NOTE: IntersectionPoint is the point where the marked line and the
'perpendicular ("Lot") of the mouse cursor on the marked line meet.
'
PointNewXPos = IntersectionPoint.X
PointNewYPos = IntersectionPoint.Y
Call GetGridPosFromMousePos(PointNewXPos, PointNewYPos)
If PointStructIndexFromMousePos(PointNewXPos, PointNewYPos) = 0 Then 'do not add a point twice
Call Point_Insert(DeskStructVar.MarkedLineIndex + 1, PointNewXPos, PointNewYPos)
End If
End If
End If
DeskStructVar.MarkedLineIndex = MarkedLineIndexOld
End Sub
Private Function Point_Verify(ByVal PointStructNumber As Integer, ByRef PointStructArray() As PointStruct, ByVal WindowWidth As Long, ByVal WindowHeight As Long) As Boolean
'on error resume next 'returns True if everything's alright, False if there is an error or if the user canceled
Dim XMin As Long
Dim YMin As Long
Dim XMax As Long
Dim YMax As Long
Dim XFor As Long
Dim YFor As Long
Dim FirstErrorFlag As Boolean
Dim PointLoop As Integer
Dim Vec1 As PointStruct
Dim Vec2 As PointStruct
Dim POINTArray() As POINTAPI
Dim RECTVar As RECT
Dim Temp As Long
'preset
For PointLoop = 1 To PointStructNumber
If PointStructArray(PointLoop).X > XMax Then XMax = PointStructArray(PointLoop).X
If PointStructArray(PointLoop).Y > YMax Then YMax = PointStructArray(PointLoop).Y
Next PointLoop
XMin = 256& ^ 3&
YMin = 256& ^ 3&
For PointLoop = 1 To PointStructNumber
If PointStructArray(PointLoop).X < XMin Then XMin = PointStructArray(PointLoop).X
If PointStructArray(PointLoop).Y < YMin Then YMin = PointStructArray(PointLoop).Y
Next PointLoop
FirstErrorFlag = True
'begin
For PointLoop = 1 To (PointStructNumber ‑ 2)
'
'NOTE: checking for invisibility is not so save.
'The user CAN create invisible regions, but then it's his/her fault when the window becomes invisible (these STUPID users !).
'
Vec1.X = PointStructArray(PointLoop).X ‑ PointStructArray(PointLoop + 1).X
Vec1.Y = PointStructArray(PointLoop).Y ‑ PointStructArray(PointLoop + 1).Y
Vec2.X = PointStructArray(PointLoop + 2).X ‑ PointStructArray(PointLoop + 1).X
Vec2.Y = PointStructArray(PointLoop + 2).Y ‑ PointStructArray(PointLoop + 1).Y
'NOTE: this is the old test that sometimes fails.
If Not ((Vec1.X * Vec2.Y ‑ Vec2.X * Vec1.X) = 0) Then 'use "Determinante" to verify lines are not "koliniar"
'If Not ((Vec1.X * Vec1.Y + Vec2.X * Vec1.Y) = 0) Then 'use "Skalarprodukt" to verify there is no 90 degree angle 'no! (cube)
GoTo Jump1:
'End If
End If
Next PointLoop
Jump1:
'NOTE: now comes the new invisibility test that always works.
If PointStructNumber > 2 Then 'verify (should not happen)
ReDim POINTArray(1 To PointStructNumber) As POINTAPI
For Temp = 1 To PointStructNumber
POINTArray(Temp).X = PointStructArray(Temp).X
POINTArray(Temp).Y = PointStructArray(Temp).Y
Next Temp
Temp = CreatePolygonRgn(POINTArray(1), PointStructNumber, 1)
'aaaabbb
'aaaabbb
'aaaabbb
'aaaabbb
'ccccdddd
'ccccdddd
'ccccdddd
'ccccdddd
For XFor = XMin To XMax Step 8&
For YFor = YMin To YMax Step 8&
RECTVar.Left = XFor
RECTVar.Right = XFor + 4&
RECTVar.Top = YFor
RECTVar.Bottom = YFor + 4&
If (RectInRegion(Temp, RECTVar)) Then 'returns non‑zero if rect is partially or completely within region
RECTVar.Left = XFor + 4&
RECTVar.Right = XFor + 8&
RECTVar.Top = YFor
RECTVar.Bottom = YFor + 4&
If (RectInRegion(Temp, RECTVar)) Then
RECTVar.Left = XFor
RECTVar.Right = XFor + 4&
RECTVar.Top = YFor + 4&
RECTVar.Bottom = YFor + 8&
If (RectInRegion(Temp, RECTVar)) Then
RECTVar.Left = XFor + 4&
RECTVar.Right = XFor + 8&
RECTVar.Top = YFor + 4&
RECTVar.Bottom = YFor + 8&
If (RectInRegion(Temp, RECTVar)) Then
Call DeleteObject(Temp) 'make sure region is deleted
GoTo Jump2:
End If
End If
End If
End If
Next YFor
Next XFor
Call DeleteObject(Temp) 'make sure region is deleted
Else
MsgBox "internal error in Point_Verify: PointStructNumber < 3 !", vbOKOnly + vbExclamation
End If
MsgBox "Your region is (almost) invisible !", vbOKOnly + vbCritical
GoTo Error:
Jump2:
If (XMax < (CSng(WindowWidth) * 0.9!)) Then
If FirstErrorFlag = True Then If MsgBox("Your region is surely great, but not the best one. Display warnings ?", vbYesNo + vbQuestion) = vbNo Then GoTo Jump3: 'allow skipping error messages
FirstErrorFlag = False
If MsgBox("Your region cuts the right edge of the window, use it nevertheless ?", vbYesNo + vbQuestion) = vbNo Then GoTo Error:
End If
If (XMin > (CSng(WindowWidth) * 0.1!)) Then
If FirstErrorFlag = True Then If MsgBox("Your region is surely great, but not the best one. Display warnings ?", vbYesNo + vbQuestion) = vbNo Then GoTo Jump3: 'allow skipping error messages
FirstErrorFlag = False
If MsgBox("Your region cuts the left edge of the window, use it nevertheless ?", vbYesNo + vbQuestion) = vbNo Then GoTo Error:
End If
If (YMax < (CSng(WindowHeight) * 0.9!)) Then
If FirstErrorFlag = True Then If MsgBox("Your region is surely great, but not the best one. Display warnings ?", vbYesNo + vbQuestion) = vbNo Then GoTo Jump3: 'allow skipping error messages
FirstErrorFlag = False
If MsgBox("Your region cuts the bottom edge of the window, use it nevertheless ?", vbYesNo + vbQuestion) = vbNo Then GoTo Error:
End If
If (YMin > (CSng(WindowHeight) * 0.1!)) Then
If FirstErrorFlag = True Then If MsgBox("Your region is surely great, but not the best one. Display warnings ?", vbYesNo + vbQuestion) = vbNo Then GoTo Jump3: 'allow skipping error messages
FirstErrorFlag = False
If MsgBox("Your region cuts the top edge of the window, use it nevertheless ?", vbYesNo + vbQuestion) = vbNo Then GoTo Error:
End If
If PointStructNumber > 32 Then
If FirstErrorFlag = True Then If MsgBox("Your region is surely great, but not the best one. Display warnings ?", vbYesNo + vbQuestion) = vbNo Then GoTo Jump3: 'allow skipping error messages
FirstErrorFlag = False
If MsgBox("Your region uses a high number of points, what could lead to slow downs when moving form on machines with few CPU power. Continue ?", vbYesNo + vbQuestion) = vbNo Then GoTo Error:
End If
Jump3:
Point_Verify = True 'ok
Exit Function
Error:
Point_Verify = False 'error
Exit Function
End Function
Private Sub Point_Insert(ByVal PointStructIndex As Integer, ByVal PointXPos As Long, ByVal PointYPos As Long)
'On Error Resume Next 'point will push the point related to PointStructIndex 'upwards' (point to insert will be drawn first)
Dim StructLoop As Integer
'verify
If PointStructNumber = 32766 Then Exit Sub
'begin
PointStructNumber = PointStructNumber + 1
ReDim Preserve PointStructArray(1 To PointStructNumber) As PointStruct
For StructLoop = (PointStructNumber ‑ 1) To PointStructIndex Step (‑1)
PointStructArray(StructLoop + 1) = PointStructArray(StructLoop)
Next StructLoop
PointStructArray(PointStructIndex).X = PointXPos
PointStructArray(PointStructIndex).Y = PointYPos
End Sub
Private Sub Point_Move(ByVal PointStructIndex As Integer, ByVal PointXPosNew As Long, ByVal PointYPosNew As Long)
'On Error Resume Next 'moves the specified point; passed point coordinates are not (!) made fit to grid
If Not ((PointStructIndex < 1) Or (PointStructIndex > PointStructNumber)) Then 'verify
PointStructArray(PointStructIndex).X = PointXPosNew
PointStructArray(PointStructIndex).Y = PointYPosNew
End If
End Sub
Private Sub Points_Redraw(ByVal MouseXPos As Long, ByVal MouseYPos As Long)
'On Error Resume Next
Dim LineXPosOld As Long
Dim LineyPosOld As Long
Dim PointLoop As Integer
'draw point rects
If DeskStructVar.PointRectDisabledFlag = False Then 'user can disable point rects to view the lines completely
For PointLoop = 1 To PointStructNumber
If DeskStructVar.DrawingFinishedFlag = False Then
'just draw point rects
Call PointRect_Draw( _
PointStructArray(PointLoop).X + DeskOffSetStructVar.OffSetX, _
PointStructArray(PointLoop).Y + DeskOffSetStructVar.OffSetY, False)
Else
'draw point rects, marked one in a special color
If PointLoop = DeskStructVar.MarkedPointIndex Then
Call PointRect_Draw( _
PointStructArray(PointLoop).X + DeskOffSetStructVar.OffSetX, _
PointStructArray(PointLoop).Y + DeskOffSetStructVar.OffSetY, True)
Else
Call PointRect_Draw( _
PointStructArray(PointLoop).X + DeskOffSetStructVar.OffSetX, _
PointStructArray(PointLoop).Y + DeskOffSetStructVar.OffSetY, False)
End If
End If
Next PointLoop
End If
'draw lines
If (PointStructNumber > 1) Then
LineXPosOld = PointStructArray(1).X
LineyPosOld = PointStructArray(1).Y
End If
For PointLoop = 2 To PointStructNumber
If DeskStructVar.DrawingFinishedFlag = False Then
GFSkinEngine_PolyRgnDeskfrm.Line ( _
LineXPosOld + DeskOffSetStructVar.OffSetX, _
LineyPosOld + DeskOffSetStructVar.OffSetY)‑( _
PointStructArray(PointLoop).X + DeskOffSetStructVar.OffSetX, _
PointStructArray(PointLoop).Y + DeskOffSetStructVar.OffSetY), DeskStructVar.LineColorNormal
Else
If Not ((PointLoop ‑ 1) = DeskStructVar.MarkedLineIndex) Then
GFSkinEngine_PolyRgnDeskfrm.Line ( _
LineXPosOld + DeskOffSetStructVar.OffSetX, _
LineyPosOld + DeskOffSetStructVar.OffSetY)‑( _
PointStructArray(PointLoop).X + DeskOffSetStructVar.OffSetX, _
PointStructArray(PointLoop).Y + DeskOffSetStructVar.OffSetY), DeskStructVar.LineColorNormal
Else
GFSkinEngine_PolyRgnDeskfrm.Line ( _
LineXPosOld + DeskOffSetStructVar.OffSetX, _
LineyPosOld + DeskOffSetStructVar.OffSetY)‑( _
PointStructArray(PointLoop).X + DeskOffSetStructVar.OffSetX, _
PointStructArray(PointLoop).Y + DeskOffSetStructVar.OffSetY), DeskStructVar.LineColorMarked
End If
End If
LineXPosOld = PointStructArray(PointLoop).X
LineyPosOld = PointStructArray(PointLoop).Y
Next PointLoop
If DeskStructVar.DrawingFinishedFlag = False Then
'
'NOTE: the last line ends in the mouse cursor and is freely movable
'(has no PointRect at its end).
'
If (PointStructNumber > 0) Then
'draw last line back to starting point
GFSkinEngine_PolyRgnDeskfrm.Line ( _
PointStructArray(PointStructNumber).X + DeskOffSetStructVar.OffSetX, _
PointStructArray(PointStructNumber).Y + DeskOffSetStructVar.OffSetY)‑( _
MouseXPos + DeskOffSetStructVar.OffSetX, _
MouseYPos + DeskOffSetStructVar.OffSetY), DeskStructVar.LineColorNormal
End If
Else
'
'NOTE: drawing has been finished, connect the last and the first point.
'
If (PointStructNumber > 0) Then
If Not (DeskStructVar.MarkedLineIndex = PointStructNumber) Then
GFSkinEngine_PolyRgnDeskfrm.Line ( _
PointStructArray(1).X + DeskOffSetStructVar.OffSetX, _
PointStructArray(1).Y + DeskOffSetStructVar.OffSetY)‑( _
PointStructArray(PointStructNumber).X + DeskOffSetStructVar.OffSetX, _
PointStructArray(PointStructNumber).Y + DeskOffSetStructVar.OffSetY), DeskStructVar.LineColorNormal
Else
GFSkinEngine_PolyRgnDeskfrm.Line ( _
PointStructArray(1).X + DeskOffSetStructVar.OffSetX, _
PointStructArray(1).Y + DeskOffSetStructVar.OffSetY)‑( _
PointStructArray(PointStructNumber).X + DeskOffSetStructVar.OffSetX, _
PointStructArray(PointStructNumber).Y + DeskOffSetStructVar.OffSetY), DeskStructVar.LineColorMarked
End If
End If
End If
End Sub
Private Sub PointRect_Draw(ByVal PointRectXPos As Long, ByVal PointRectYPos As Long, ByVal PointMarkedFlag As Boolean)
'On Error Resume Next
If PointMarkedFlag = False Then
GFSkinEngine_PolyRgnDeskfrm.Line (PointRectXPos ‑ 2, PointRectYPos ‑ 2)‑(PointRectXPos + 2, PointRectYPos + 2), DeskStructVar.PointRectColorNormal, B
Else
'NOTE: draw a marked point larger (if it's hidden under an other point).
GFSkinEngine_PolyRgnDeskfrm.Line (PointRectXPos ‑ 3, PointRectYPos ‑ 3)‑(PointRectXPos + 3, PointRectYPos + 3), DeskStructVar.PointRectColorMarked, B
End If
End Sub
Private Function PointStructIndexFromMousePos(ByVal MouseXPos As Long, ByVal MouseYPos As Long) As Integer
'On Error Resume Next 'returns 0 for error; both grid and mouse positions can be passed
Dim StructLoop As Integer
'preset
Call GetGridPosFromMousePos(MouseXPos, MouseYPos)
'begin
For StructLoop = 1 To PointStructNumber
If PointStructArray(StructLoop).X = MouseXPos Then
If PointStructArray(StructLoop).Y = MouseYPos Then
PointStructIndexFromMousePos = StructLoop
Exit Function
End If
End If
Next StructLoop
PointStructIndexFromMousePos = 0 'reset (error)
Exit Function
End Function
Private Function GetPointStructIndexFromMousePosEx(ByVal MouseXPos As Long, ByVal MouseYPos As Long, ByVal MousePointDistanceMax As Long) As Integer
'On Error Resume Next 'returns first point that is closest to passed mouse position; passed coordinates will not be converted or changed in any way
Dim DistMin As Long
Dim DistMinStructIndex As Integer
Dim StructLoop As Integer
'preset
DistMin = 256& ^ 3&
DistMinStructIndex = 0
'begin
For StructLoop = 1 To PointStructNumber
If GetPointPointDistLong2D(MouseXPos, MouseYPos, PointStructArray(StructLoop).X, PointStructArray(StructLoop).Y) < DistMin Then
DistMin = GetPointPointDistLong2D(MouseXPos, MouseYPos, PointStructArray(StructLoop).X, PointStructArray(StructLoop).Y)
DistMinStructIndex = StructLoop
End If
Next StructLoop
If Not (DistMin > MousePointDistanceMax) Then
GetPointStructIndexFromMousePosEx = DistMinStructIndex
Else
GetPointStructIndexFromMousePosEx = 0 'closest point is too far away from mouse cursor
End If
End Function
Private Function GetMarkedLineIndexFromMousePos(ByVal MouseXPos As Long, ByVal MouseYPos As Long, ByVal MouseLineDistMax As Long) As Integer
'On Error Resume Next 'returns PointStructArray() index of line start point, or 0
Dim LineStartPoint As PointStruct
Dim LineEndPoint As PointStruct
Dim DistCurrent As Long
Dim DistMin As Long
Dim DistMinStructIndex As Integer
Dim L As Single
Dim StructLoop As Integer
'preset
DistMin = 256& ^ 3&
DistMinStructIndex = 0
'begin
For StructLoop = 1 To PointStructNumber
If Not (StructLoop = PointStructNumber) Then
LineStartPoint.X = PointStructArray(StructLoop).X
LineStartPoint.Y = PointStructArray(StructLoop).Y
LineEndPoint.X = PointStructArray(StructLoop + 1).X
LineEndPoint.Y = PointStructArray(StructLoop + 1).Y
Else
LineStartPoint.X = PointStructArray(StructLoop).X
LineStartPoint.Y = PointStructArray(StructLoop).Y
LineEndPoint.X = PointStructArray(1).X
LineEndPoint.Y = PointStructArray(1).Y
End If
'get point ‑ straight (!) distance
DistCurrent = GetPointLineDistLong3D(MouseXPos, MouseYPos, 0, LineStartPoint.X, LineStartPoint.Y, 0, LineEndPoint.X, LineEndPoint.Y, 0, L)
If L < 0 Then
'point lies 'before' straight
DistCurrent = GetPointPointDistSingle3D(MouseXPos, MouseYPos, 0, LineStartPoint.X, LineStartPoint.Y, 0)
End If
If L > 1 Then
'point lies 'after' straight
DistCurrent = GetPointPointDistSingle3D(MouseXPos, MouseYPos, 0, LineEndPoint.X, LineEndPoint.Y, 0)
End If
If DistCurrent < DistMin Then
DistMin = DistCurrent
DistMinStructIndex = StructLoop
End If
Next StructLoop
If Not (DistMin > MouseLineDistMax) Then
GetMarkedLineIndexFromMousePos = DistMinStructIndex
Else
GetMarkedLineIndexFromMousePos = 0 'any line is too far away from mouse cursor
End If
End Function
'*************************************END OF POINTS*************************************
'*****************************************GRID******************************************
'NOTE: the grid must be drawn once in GridPicture and GridMaskPicture by calling
'Grid_Create(). Grid_Redraw will transfer the grid image from GridPicture and GridMaskPicture
'to the form (call to refresh the visible grid).
Private Sub Grid_Create(ByVal GridWidth As Long, ByVal GridHeight As Long, ByRef DeskStructVar As DeskStruct)
'On Error Resume Next 'format: twips, sets the grid's size to the form's size and creates the grid mask and the grid itself
Dim GridXLoop As Long
Dim GridYLoop As Long
'
'NOTE: pass coordinates in the format pixels as any container has the format pixels
'(ask Microsoft why every control is dependent on some others).
'
'verify
If DeskStructVar.DeskInitializedFlag = False Then Exit Sub 'important (scale mode must be correct)
'preset
GridPicture.Width = GridWidth
GridPicture.Height = GridHeight
GridPicture.DrawStyle = vbNormal
GridPicture.ScaleMode = vbTwips
GridMaskPicture.Width = GridWidth
GridMaskPicture.Height = GridHeight
GridMaskPicture.DrawStyle = vbNormal
GridMaskPicture.ScaleMode = vbTwips
'reset
GridPicture.Cls 'reset
GridMaskPicture.Cls 'reset
'begin
For GridXLoop = 1 To GridMaskPicture.ScaleWidth Step (DeskStructVar.GridDistance * DeskStructVar.GridZoomFactor) * Screen.TwipsPerPixelX
For GridYLoop = 1 To GridMaskPicture.ScaleHeight Step (DeskStructVar.GridDistance * DeskStructVar.GridZoomFactor) * Screen.TwipsPerPixelY
GridMaskPicture.Line (GridXLoop ‑ 1, 0)‑(GridXLoop ‑ 1, GridMaskPicture.ScaleHeight), RGB(255, 255, 255) '1 to 0 based
GridMaskPicture.Line (0, GridYLoop ‑ 1)‑(GridMaskPicture.ScaleWidth, GridYLoop ‑ 1), RGB(255, 255, 255) '1 to 0 based
Next GridYLoop
Next GridXLoop
For GridXLoop = 1 To GridPicture.ScaleWidth Step (DeskStructVar.GridDistance * DeskStructVar.GridZoomFactor) * Screen.TwipsPerPixelX
For GridYLoop = 1 To GridPicture.ScaleHeight Step (DeskStructVar.GridDistance * DeskStructVar.GridZoomFactor) * Screen.TwipsPerPixelY
GridPicture.Line (GridXLoop ‑ 1, 0)‑(GridXLoop ‑ 1, GridPicture.ScaleHeight), DeskStructVar.GridColor '1 to 0 based
GridPicture.Line (0, GridYLoop ‑ 1)‑(GridPicture.ScaleWidth, GridYLoop ‑ 1), DeskStructVar.GridColor '1 to 0 based
Next GridYLoop
Next GridXLoop
End Sub
Private Sub Grid_Redraw()
'On Error Resume Next
Dim DrawXLoop As Integer
Dim DrawYLoop As Integer
'preset
Call Grid_Create(150, 150, DeskStructVar)
'begin
For DrawXLoop = 1 To ‑Int(‑Me.ScaleWidth / 150)
For DrawYLoop = 1 To ‑Int(‑Me.ScaleHeight / 150)
Call GFMaskPrint(GFSkinEngine_PolyRgnDeskfrm, (DrawXLoop ‑ 1) * 150, (DrawYLoop ‑ 1) * 150, GridPicture, GridMaskPicture)
Next DrawYLoop
Next DrawXLoop
End Sub
Private Sub GetGridPosFromMousePos(ByRef MouseXPos As Long, ByRef MouseYPos As Long)
'On Error Resume Next 'format: pixels
'
'NOTE: this is the function that verifies points are on the grid.
'If the grid is disabled the passed points are not changed in any way.
'Note that the grid can be visible but also not enabled
'(check enabled state in this sub only).
'
If DeskStructVar.GridEnabledFlag = True Then
If (MouseXPos Mod DeskStructVar.GridDistance) > (DeskStructVar.GridDistance / 2) Then
MouseXPos = MouseXPos + (DeskStructVar.GridDistance ‑ (MouseXPos Mod DeskStructVar.GridDistance))
Else
MouseXPos = MouseXPos ‑ (MouseXPos Mod DeskStructVar.GridDistance)
End If
If (MouseYPos Mod DeskStructVar.GridDistance) > (DeskStructVar.GridDistance / 2) Then
MouseYPos = MouseYPos + (DeskStructVar.GridDistance ‑ (MouseYPos Mod DeskStructVar.GridDistance))
Else
MouseYPos = MouseYPos ‑ (MouseYPos Mod DeskStructVar.GridDistance)
End If
End If
End Sub
'**************************************END OF GRID**************************************
'***********************************GENERAL FUNCTIONS***********************************
Private Function GFMaskPrint(ByVal PrintTargetPictureBox As Object, ByVal PrintTargetPictureXPos As Long, ByVal PrintTargetPictureYPos As Long, ByVal PrintSourcePictureBox As PictureBox, ByVal PrintMaskPictureBox As PictureBox) As Boolean
On Error GoTo Error: 'function returns True if printing was successful, False if not
Dim PrintMaskPictureScaleModeUnchanged As Integer
'
'NOTE: use this function to print transparent text, non‑rectangular pictures, etc.
'The mask must consist of two colors only (black and white), everything that's white will be printed.
'Print[Source/Mask] must have the picture to print placed at (0|0), and must have been made fit to
'the picture's size.
'
PrintMaskPictureScaleModeUnchanged = PrintMaskPictureBox.ScaleMode
PrintMaskPictureBox.ScaleMode = vbPixels 'important
Call BitBlt(PrintTargetPictureBox.hDC, PrintTargetPictureXPos, PrintTargetPictureYPos, PrintMaskPictureBox.ScaleWidth, PrintMaskPictureBox.ScaleHeight, PrintMaskPictureBox.hDC, 0, 0, vbSrcPaint)
Call BitBlt(PrintSourcePictureBox.hDC, 0, 0, PrintMaskPictureBox.ScaleWidth, PrintMaskPictureBox.ScaleHeight, PrintMaskPictureBox.hDC, 0, 0, vbMergePaint)
Call BitBlt(PrintTargetPictureBox.hDC, PrintTargetPictureXPos, PrintTargetPictureYPos, PrintMaskPictureBox.ScaleWidth, PrintMaskPictureBox.ScaleHeight, PrintSourcePictureBox.hDC, 0, 0, vbSrcAnd)
PrintMaskPictureBox.ScaleMode = PrintMaskPictureScaleModeUnchanged 'reset
GFMaskPrint = True 'ok
Exit Function
Error:
If Not (PrintMaskPictureScaleModeUnchanged = 0) Then 'verify
PrintMaskPictureBox.ScaleMode = PrintMaskPictureScaleModeUnchanged 'reset
End If
GFMaskPrint = False 'error
Exit Function
End Function
Private Function ProgramGetMousePosX() As Long
'On Error Resume Next 'the format is: pixels
Dim ProgramGetMousePosXTemp As Long
Dim CurrentMousePos As POINTAPI
ProgramGetMousePosXTemp = GetCursorPos(CurrentMousePos)
ProgramGetMousePosX = CurrentMousePos.X
End Function
Private Function ProgramGetMousePosY() As Long
'On Error Resume Next 'the format is: pixels
Dim ProgramGetMousePosYTemp As Long
Dim CurrentMousePos As POINTAPI
ProgramGetMousePosYTemp = GetCursorPos(CurrentMousePos)
ProgramGetMousePosY = CurrentMousePos.Y
End Function
Private Function MIN(ByVal Value1 As Long, ByVal Value2 As Long) As Long
'on error resume next
If Value1 > Value2 Then
MIN = Value2
Else
MIN = Value1
End If
End Function
Private Function MAX(ByVal Value1 As Long, ByVal Value2 As Long) As Long
'on error resume next
If Value1 < Value2 Then
MAX = Value2
Else
MAX = Value1
End If
End Function
Private Function STRINGTOBOOL(ByVal StringString As String) As Boolean
'On Error Resume Next
If UCase$(StringString) = "TRUE" Then
STRINGTOBOOL = True
Else
STRINGTOBOOL = False
End If
End Function
Private Function BOOLTOSTRING(ByVal BooleanFlag As Boolean) As String
'On Error Resume Next
If BooleanFlag = True Then
BOOLTOSTRING = "True"
Else
BOOLTOSTRING = "False"
End If
End Function
Private Sub Form_Unload(Cancel As Integer)
'On Error Resume Next
'
'NOTE: do not unload window to retain GridEnabledFlag.
'NOTE: the code must not call this sub as the user will be asked
'if existing changes are to be saved
'(use DeskStructVar.[Cancel/Continue]Flag instead).
'
'Cancel = True 'no, unload to save memory (anyway, modal loop WILL be left normally)
If DeskStructVar.DeskChangesExistingFlag = False Then
DeskStructVar.CancelFlag = True
Else
If (Me.Enabled = True) And (Me.Visible = True) Then 'avoid annoying message when being unloaded by any other form
Select Case MsgBox("Save changes ?", vbYesNoCancel + vbExclamation)
Case vbCancel
Cancel = True 'don't unload and don't get out of modal loop
Case vbYes
'NOTE: the following sub will finish drawing only if rgn is valid:
Call MenuFinished_Click
Case vbNo
Call MenuAbort_Click
End Select
Else
DeskStructVar.CancelFlag = True 'get out of modal loop
End If
End If
End Sub
[END OF FILE]