GFPBLabel/GFPBLabel.frm
VERSION 5.00
Begin VB.Form GFPBLabelfrm
BorderStyle = 0 'Kein
Caption = "GFPBLabelfrm"
ClientHeight = 3195
ClientLeft = 0
ClientTop = 0
ClientWidth = 4680
Enabled = 0 'False
LinkTopic = "Form1"
ScaleHeight = 3195
ScaleWidth = 4680
ShowInTaskbar = 0 'False
StartUpPosition = 3 'Windows‑Standard
Visible = 0 'False
Begin VB.PictureBox GFPBLabelCreationPicture
AutoRedraw = ‑1 'True
Enabled = 0 'False
Height = 315
Left = 60
ScaleHeight = 255
ScaleWidth = 135
TabIndex = 0
Top = 60
Visible = 0 'False
Width = 195
End
End
Attribute VB_Name = "GFPBLabelfrm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'(c)2001 by Louis.
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)
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
Const LabelXSizeMin As Single = 500 'also sets min text length in label
Const LabelYSizeMin As Single = 200
'LabelMousePos constants
Const LABEL_MOUSEPOS_NOTONLABEL As Integer = 0
Const LABEL_MOUSEPOS_LEFTEDGE As Integer = 1
Const LABEL_MOUSEPOS_RIGHTEDGE As Integer = 2
Const LABEL_MOUSEPOS_TOPEDGE As Integer = 3
Const LABEL_MOUSEPOS_BOTTOMEDGE As Integer = 4
Const LABEL_MOUSEPOS_LEFTTOP As Integer = 5
Const LABEL_MOUSEPOS_RIGHTTOP As Integer = 6
Const LABEL_MOUSEPOS_LEFTBOTTOM As Integer = 7
Const LABEL_MOUSEPOS_RIGHTBOTTOM As Integer = 8
Const LABEL_MOUSEPOS_CENTER As Integer = 9
'LabelMouseAction constants
Const LABEL_MOUSEACTION_NOACTION As Integer = 0
Const LABEL_MOUSEACTION_MOVE As Integer = 1
Const LABEL_MOUSEACTION_RESIZE As Integer = 2
'GFPBMouseStruct (storing information about mouse)
Private Type GFPBMouseStruct
MouseAction As Integer 'LabelMouseAction constant
MouseActionPos As Integer 'LabelMousePos constant
MouseActionLabelIndex As Integer 'label action is or was used on
MouseMoveDeltaXPos As Long
MouseMoveDeltaYPos As Long
End Type
Dim GFPBMouseStructVar As GFPBMouseStruct
Public Sub GFPBLabel_Create(ByVal LabelForeColor As Long, ByVal LabelBackColor As Long, ByRef LabelTargetPicture As PictureBox)
'on error resume next
If Not (GFPBLabelStructNumber = 32767) Then 'verify
GFPBLabelStructNumber = GFPBLabelStructNumber + 1
Else
MsgBox "internal error in GFPBLabel_Create: overflow !", vbOKOnly + vbExclamation
End If
ReDim Preserve GFPBLabelStructArray(1 To GFPBLabelStructNumber) As GFPBLabelStruct
'preset
GFPBLabelStructArray(GFPBLabelStructNumber).LabelText = ""
GFPBLabelStructArray(GFPBLabelStructNumber).LabelXPos = 0
GFPBLabelStructArray(GFPBLabelStructNumber).LabelYPos = 0
GFPBLabelStructArray(GFPBLabelStructNumber).LabelXSize = 2500
GFPBLabelStructArray(GFPBLabelStructNumber).LabelYSize = 2500
GFPBLabelStructArray(GFPBLabelStructNumber).LabelForeColor = LabelForeColor
GFPBLabelStructArray(GFPBLabelStructNumber).LabelBackColor = LabelBackColor
GFPBLabelStructArray(GFPBLabelStructNumber).LabelFont.FontName = "ARIAL"
GFPBLabelStructArray(GFPBLabelStructNumber).LabelFont.FontSize = 8
GFPBLabelStructArray(GFPBLabelStructNumber).LabelFont.FontBoldFlag = False
GFPBLabelStructArray(GFPBLabelStructNumber).LabelFont.FontItalicFlag = False
GFPBLabelStructArray(GFPBLabelStructNumber).LabelFont.FontUnderlineFlag = False
GFPBLabelStructArray(GFPBLabelStructNumber).LabelFont.FontStrikeThroughFlag = False
Set GFPBLabelStructArray(GFPBLabelStructNumber).LabelTargetPicture = LabelTargetPicture
'end of preset
End Sub
Public Sub GFPBLabel_Change(ByVal LabelIndex As Integer)
'on error resume next
'verify
If (LabelIndex < 1) Or (LabelIndex > GFPBLabelStructNumber) Then
MsgBox "internal error in GFPBLabel_Change(): passed value invalid !", vbOKOnly + vbExclamation
Exit Sub 'error
End If
'begin
Call GFPBLabelInputfrm.GFPBLabelInput_EditLabel(LabelIndex)
End Sub
Public Sub GFPBLabel_ReceiveMouseMove(ByVal MouseButton As Integer, ByVal MousePosX As Single, ByVal MousePosY As Single)
'on error resume next
Dim LabelMousePos As Integer
Dim LabelLoop As Integer
Dim Temp As Long 'do not use for loop (used to save positions)
'begin
With GFPBMouseStructVar
Select Case .MouseAction
Case LABEL_MOUSEACTION_NOACTION
For LabelLoop = GFPBLabelStructNumber To 1 Step (‑1) 'count backwards as last label is on top
LabelMousePos = GFPBLabel_GetMousePos(MousePosX, MousePosY, LabelLoop)
If Not (LabelMousePos = LABEL_MOUSEPOS_NOTONLABEL) Then
'corners
Select Case LabelMousePos
Case LABEL_MOUSEPOS_LEFTTOP
If MouseButton = vbLeftButton Then
.MouseAction = LABEL_MOUSEACTION_RESIZE
.MouseActionPos = LabelMousePos
.MouseActionLabelIndex = LabelLoop
End If
GFPBLabelStructArray(LabelLoop).LabelTargetPicture.MousePointer = vbSizeNWSE
Case LABEL_MOUSEPOS_RIGHTTOP
If MouseButton = vbLeftButton Then
.MouseAction = LABEL_MOUSEACTION_RESIZE
.MouseActionPos = LabelMousePos
.MouseActionLabelIndex = LabelLoop
End If
GFPBLabelStructArray(LabelLoop).LabelTargetPicture.MousePointer = vbSizeNESW
Case LABEL_MOUSEPOS_LEFTBOTTOM
If MouseButton = vbLeftButton Then
.MouseAction = LABEL_MOUSEACTION_RESIZE
.MouseActionPos = LabelMousePos
.MouseActionLabelIndex = LabelLoop
End If
GFPBLabelStructArray(LabelLoop).LabelTargetPicture.MousePointer = vbSizeNESW
Case LABEL_MOUSEPOS_RIGHTBOTTOM
If MouseButton = vbLeftButton Then
.MouseAction = LABEL_MOUSEACTION_RESIZE
.MouseActionPos = LabelMousePos
.MouseActionLabelIndex = LabelLoop
End If
GFPBLabelStructArray(LabelLoop).LabelTargetPicture.MousePointer = vbSizeNWSE
Case LABEL_MOUSEPOS_TOPEDGE
If MouseButton = vbLeftButton Then
.MouseAction = LABEL_MOUSEACTION_RESIZE
.MouseActionPos = LabelMousePos
.MouseActionLabelIndex = LabelLoop
End If
GFPBLabelStructArray(LabelLoop).LabelTargetPicture.MousePointer = vbSizeNS
Case LABEL_MOUSEPOS_BOTTOMEDGE
If MouseButton = vbLeftButton Then
.MouseAction = LABEL_MOUSEACTION_RESIZE
.MouseActionPos = LabelMousePos
.MouseActionLabelIndex = LabelLoop
End If
GFPBLabelStructArray(LabelLoop).LabelTargetPicture.MousePointer = vbSizeNS
Case LABEL_MOUSEPOS_LEFTEDGE
If MouseButton = vbLeftButton Then
.MouseAction = LABEL_MOUSEACTION_RESIZE
.MouseActionPos = LabelMousePos
.MouseActionLabelIndex = LabelLoop
End If
GFPBLabelStructArray(LabelLoop).LabelTargetPicture.MousePointer = vbSizeWE
Case LABEL_MOUSEPOS_RIGHTEDGE
If MouseButton = vbLeftButton Then
.MouseAction = LABEL_MOUSEACTION_RESIZE
.MouseActionPos = LabelMousePos
.MouseActionLabelIndex = LabelLoop
End If
GFPBLabelStructArray(LabelLoop).LabelTargetPicture.MousePointer = vbSizeWE
Case LABEL_MOUSEPOS_CENTER
If MouseButton = vbLeftButton Then
.MouseAction = LABEL_MOUSEACTION_MOVE
.MouseActionPos = LabelMousePos
.MouseActionLabelIndex = LabelLoop
.MouseMoveDeltaXPos = MousePosX ‑ GFPBLabelStructArray(LabelLoop).LabelXPos
.MouseMoveDeltaYPos = MousePosY ‑ GFPBLabelStructArray(LabelLoop).LabelYPos
End If
GFPBLabelStructArray(LabelLoop).LabelTargetPicture.MousePointer = vbNormal
End Select
Exit For 'important (don't move two labels at the same time)
Else 'mouse not on label
GFPBLabelStructArray(LabelLoop).LabelTargetPicture.MousePointer = vbNormal 'reset
End If
Next LabelLoop
Case LABEL_MOUSEACTION_MOVE
GFPBLabelStructArray(GFPBMouseStructVar.MouseActionLabelIndex).LabelXPos = MousePosX ‑ GFPBMouseStructVar.MouseMoveDeltaXPos
GFPBLabelStructArray(GFPBMouseStructVar.MouseActionLabelIndex).LabelYPos = MousePosY ‑ GFPBMouseStructVar.MouseMoveDeltaYPos
Call GFPBLabel_Draw 'display changes
Case LABEL_MOUSEACTION_RESIZE
Select Case .MouseActionPos
'corners
Case LABEL_MOUSEPOS_BOTTOMEDGE
GFPBLabelStructArray(.MouseActionLabelIndex).LabelYSize = MousePosY ‑ GFPBLabelStructArray(GFPBMouseStructVar.MouseActionLabelIndex).LabelYPos + .MouseMoveDeltaYPos
Case LABEL_MOUSEPOS_TOPEDGE
Temp = GFPBLabelStructArray(.MouseActionLabelIndex).LabelYPos + GFPBLabelStructArray(.MouseActionLabelIndex).LabelYSize ‑ 1 'old bottom edge y pos
If (Temp ‑ MousePosY) < LabelYSizeMin Then MousePosY = Temp ‑ LabelYSizeMin 'verify (avoid moving label)
GFPBLabelStructArray(.MouseActionLabelIndex).LabelYPos = MousePosY
GFPBLabelStructArray(.MouseActionLabelIndex).LabelYSize = Temp ‑ GFPBLabelStructArray(.MouseActionLabelIndex).LabelYPos + 1
Case LABEL_MOUSEPOS_RIGHTEDGE
GFPBLabelStructArray(.MouseActionLabelIndex).LabelXSize = MousePosX ‑ GFPBLabelStructArray(GFPBMouseStructVar.MouseActionLabelIndex).LabelXPos + .MouseMoveDeltaXPos
Case LABEL_MOUSEPOS_LEFTEDGE
Temp = GFPBLabelStructArray(.MouseActionLabelIndex).LabelXPos + GFPBLabelStructArray(.MouseActionLabelIndex).LabelXSize ‑ 1 'old left edge x pos
If (Temp ‑ MousePosX) < LabelXSizeMin Then MousePosX = Temp ‑ LabelXSizeMin 'verify (avoid moving label)
GFPBLabelStructArray(.MouseActionLabelIndex).LabelXPos = MousePosX
GFPBLabelStructArray(.MouseActionLabelIndex).LabelXSize = Temp ‑ GFPBLabelStructArray(.MouseActionLabelIndex).LabelXPos + 1
'corners (copy code from edges)
Case LABEL_MOUSEPOS_RIGHTTOP
GFPBLabelStructArray(.MouseActionLabelIndex).LabelXSize = MousePosX ‑ GFPBLabelStructArray(GFPBMouseStructVar.MouseActionLabelIndex).LabelXPos + .MouseMoveDeltaXPos
Temp = GFPBLabelStructArray(.MouseActionLabelIndex).LabelYPos + GFPBLabelStructArray(.MouseActionLabelIndex).LabelYSize ‑ 1 'old bottom edge y pos
If (Temp ‑ MousePosY) < LabelYSizeMin Then MousePosY = Temp ‑ LabelYSizeMin 'verify (avoid moving label)
GFPBLabelStructArray(.MouseActionLabelIndex).LabelYPos = MousePosY
GFPBLabelStructArray(.MouseActionLabelIndex).LabelYSize = Temp ‑ GFPBLabelStructArray(.MouseActionLabelIndex).LabelYPos + 1
Case LABEL_MOUSEPOS_LEFTTOP
Temp = GFPBLabelStructArray(.MouseActionLabelIndex).LabelXPos + GFPBLabelStructArray(.MouseActionLabelIndex).LabelXSize ‑ 1 'old left edge x pos
If (Temp ‑ MousePosX) < LabelXSizeMin Then MousePosX = Temp ‑ LabelXSizeMin 'verify (avoid moving label)
GFPBLabelStructArray(.MouseActionLabelIndex).LabelXPos = MousePosX
GFPBLabelStructArray(.MouseActionLabelIndex).LabelXSize = Temp ‑ GFPBLabelStructArray(.MouseActionLabelIndex).LabelXPos + 1
Temp = GFPBLabelStructArray(.MouseActionLabelIndex).LabelYPos + GFPBLabelStructArray(.MouseActionLabelIndex).LabelYSize ‑ 1 'old bottom edge y pos
If (Temp ‑ MousePosY) < LabelYSizeMin Then MousePosY = Temp ‑ LabelYSizeMin 'verify (avoid moving label)
GFPBLabelStructArray(.MouseActionLabelIndex).LabelYPos = MousePosY
GFPBLabelStructArray(.MouseActionLabelIndex).LabelYSize = Temp ‑ GFPBLabelStructArray(.MouseActionLabelIndex).LabelYPos + 1
Case LABEL_MOUSEPOS_RIGHTBOTTOM
GFPBLabelStructArray(.MouseActionLabelIndex).LabelXSize = MousePosX ‑ GFPBLabelStructArray(GFPBMouseStructVar.MouseActionLabelIndex).LabelXPos + .MouseMoveDeltaXPos
GFPBLabelStructArray(.MouseActionLabelIndex).LabelYSize = MousePosY ‑ GFPBLabelStructArray(GFPBMouseStructVar.MouseActionLabelIndex).LabelYPos + .MouseMoveDeltaYPos
Case LABEL_MOUSEPOS_LEFTBOTTOM
Temp = GFPBLabelStructArray(.MouseActionLabelIndex).LabelXPos + GFPBLabelStructArray(.MouseActionLabelIndex).LabelXSize ‑ 1 'old left edge x pos
If (Temp ‑ MousePosX) < LabelXSizeMin Then MousePosX = Temp ‑ LabelXSizeMin 'verify (avoid moving label)
GFPBLabelStructArray(.MouseActionLabelIndex).LabelXPos = MousePosX
GFPBLabelStructArray(.MouseActionLabelIndex).LabelXSize = Temp ‑ GFPBLabelStructArray(.MouseActionLabelIndex).LabelXPos + 1
GFPBLabelStructArray(.MouseActionLabelIndex).LabelYSize = MousePosY ‑ GFPBLabelStructArray(GFPBMouseStructVar.MouseActionLabelIndex).LabelYPos + .MouseMoveDeltaYPos
End Select
Call GFPBLabel_Draw 'display changes
End Select
End With
End Sub
Public Sub GFPBLabel_ReceiveMouseUp()
'on error resume next
With GFPBMouseStructVar
.MouseAction = LABEL_MOUSEACTION_NOACTION 'reset
.MouseActionPos = LABEL_MOUSEPOS_NOTONLABEL 'reset
'.MouseActionLabelIndex = 0 'reset no!
.MouseMoveDeltaXPos = 0 'reset
.MouseMoveDeltaYPos = 0 'reset
If Not ((.MouseActionLabelIndex < 1) Or (.MouseActionLabelIndex > GFPBLabelStructNumber)) Then 'verify (0 if no action existing)
GFPBLabelStructArray(.MouseActionLabelIndex).LabelTargetPicture.MousePointer = vbNormal 'reset
End If
End With
End Sub
Public Function GFPBLabel_GetFocusLabelIndex() As Integer
'on error resume next
GFPBLabel_GetFocusLabelIndex = GFPBMouseStructVar.MouseActionLabelIndex
End Function
Public Sub GFPBLabel_Edit(ByVal LabelIndex As Integer)
'on error resume next
'verify
If (LabelIndex < 1) Or (LabelIndex > GFPBLabelStructNumber) Then
MsgBox "Please select label to edit !", vbOKOnly + vbExclamation
Exit Sub 'no real error (LabelIndex could be zero after another label has been deleted)
End If
'begin
Call GFPBLabelInputfrm.GFPBLabelInput_EditLabel(LabelIndex)
Call GFPBLabel_Draw 'display changes
End Sub
Public Sub GFPBLabel_Delete(ByVal LabelIndex As Integer)
'on error resume next
Dim hWndArray() As Long
Dim hWndNumber As Integer
Dim hWndLoop As Integer
Dim LabelLoop As Integer
Dim Temp As Long
'verify
If (LabelIndex < 1) Or (LabelIndex > GFPBLabelStructNumber) Then
MsgBox "Please select label to delete !", vbOKOnly + vbExclamation
Exit Sub 'no real error (LabelIndex could be zero after another label has been deleted)
End If
'reset (code copied from GFPBLabel_Draw)
'
'NOTE: clear all used target picture boxes as this operation
'is not executed if no label is existing anymore.
'
For LabelLoop = 1 To GFPBLabelStructNumber
'clear target picture if not done yet
For hWndLoop = 1 To hWndNumber
If GFPBLabelStructArray(LabelLoop).LabelTargetPicture.hWnd = _
hWndArray(hWndLoop) Then
GoTo Jump:
End If
Next hWndLoop
hWndNumber = hWndNumber + 1 'LabelLoop cannot exceed 32767
ReDim Preserve hWndArray(1 To hWndNumber) As Long
hWndArray(hWndNumber) = GFPBLabelStructArray(LabelLoop).LabelTargetPicture.hWnd
GFPBLabelStructArray(LabelLoop).LabelTargetPicture.Cls 'reset
Jump:
Next LabelLoop
'begin
For Temp = LabelIndex To GFPBLabelStructNumber
If Not (Temp = GFPBLabelStructNumber) Then
Call CopyMemory(GFPBLabelStructArray(Temp), GFPBLabelStructArray(Temp + 1), Len(GFPBLabelStructArray(Temp)))
Else
GFPBLabelStructNumber = GFPBLabelStructNumber ‑ 1
Temp = GFPBLabelStructNumber 'Temp not used anymore
If Temp < 1 Then Temp = 1 'verify
ReDim Preserve GFPBLabelStructArray(1 To Temp) As GFPBLabelStruct
Exit For 'important
End If
Next Temp
Call GFPBLabel_Draw 'display changes
End Sub
Private Function GFPBLabel_GetMousePos(ByVal MousePosX As Single, ByVal MousePosY As Single, ByVal LabelIndex As Integer) As Integer
'on error resume next 'returns one of the LabelMousePos constants
Dim DeltaXPos As Long
Dim DeltaYPos As Long
'preset
DeltaXPos = 3 * Screen.TwipsPerPixelX
DeltaYPos = 3 * Screen.TwipsPerPixelY
'begin
'corners
If (Not (Abs(MousePosX ‑ GFPBLabelStructArray(LabelIndex).LabelXPos) > DeltaXPos)) And _
(Not (Abs(MousePosY ‑ GFPBLabelStructArray(LabelIndex).LabelYPos) > DeltaYPos)) Then
GFPBLabel_GetMousePos = LABEL_MOUSEPOS_LEFTTOP
Exit Function
End If
If (Not (Abs(MousePosX ‑ (GFPBLabelStructArray(LabelIndex).LabelXPos + GFPBLabelStructArray(LabelIndex).LabelXSize ‑ 1)) > DeltaXPos)) And _
(Not (Abs(MousePosY ‑ GFPBLabelStructArray(LabelIndex).LabelYPos) > DeltaYPos)) Then
GFPBLabel_GetMousePos = LABEL_MOUSEPOS_RIGHTTOP
Exit Function
End If
If (Not (Abs(MousePosX ‑ GFPBLabelStructArray(LabelIndex).LabelXPos) > DeltaXPos)) And _
(Not (Abs(MousePosY ‑ (GFPBLabelStructArray(LabelIndex).LabelYPos + GFPBLabelStructArray(LabelIndex).LabelYSize ‑ 1)) > DeltaYPos)) Then
GFPBLabel_GetMousePos = LABEL_MOUSEPOS_LEFTBOTTOM
Exit Function
End If
If (Not (Abs(MousePosX ‑ (GFPBLabelStructArray(LabelIndex).LabelXPos + GFPBLabelStructArray(LabelIndex).LabelXSize ‑ 1)) > DeltaXPos)) And _
(Not (Abs(MousePosY ‑ (GFPBLabelStructArray(LabelIndex).LabelYPos + GFPBLabelStructArray(LabelIndex).LabelYSize ‑ 1)) > DeltaYPos)) Then
GFPBLabel_GetMousePos = LABEL_MOUSEPOS_RIGHTBOTTOM
Exit Function
End If
'edges
If (Not (Abs(MousePosX ‑ GFPBLabelStructArray(LabelIndex).LabelXPos) > DeltaXPos)) And _
(MousePosY > GFPBLabelStructArray(LabelIndex).LabelYPos) And _
(MousePosY < (GFPBLabelStructArray(LabelIndex).LabelYPos + GFPBLabelStructArray(LabelIndex).LabelYSize ‑ 1)) Then
GFPBLabel_GetMousePos = LABEL_MOUSEPOS_LEFTEDGE
Exit Function
End If
If (Not (Abs(MousePosX ‑ (GFPBLabelStructArray(LabelIndex).LabelXPos + GFPBLabelStructArray(LabelIndex).LabelXSize ‑ 1)) > DeltaXPos)) And _
(MousePosY > GFPBLabelStructArray(LabelIndex).LabelYPos) And _
(MousePosY < (GFPBLabelStructArray(LabelIndex).LabelYPos + GFPBLabelStructArray(LabelIndex).LabelYSize ‑ 1)) Then
GFPBLabel_GetMousePos = LABEL_MOUSEPOS_RIGHTEDGE
Exit Function
End If
If (Not (Abs(MousePosY ‑ GFPBLabelStructArray(LabelIndex).LabelYPos) > DeltaYPos)) And _
(MousePosX > GFPBLabelStructArray(LabelIndex).LabelXPos) And _
(MousePosX < (GFPBLabelStructArray(LabelIndex).LabelXPos + GFPBLabelStructArray(LabelIndex).LabelXSize ‑ 1)) Then
GFPBLabel_GetMousePos = LABEL_MOUSEPOS_TOPEDGE
Exit Function
End If
If (Not (Abs(MousePosY ‑ (GFPBLabelStructArray(LabelIndex).LabelYPos + GFPBLabelStructArray(LabelIndex).LabelYSize ‑ 1)) > DeltaYPos)) And _
(MousePosX > GFPBLabelStructArray(LabelIndex).LabelXPos) And _
(MousePosX < (GFPBLabelStructArray(LabelIndex).LabelXPos + GFPBLabelStructArray(LabelIndex).LabelXSize ‑ 1)) Then
GFPBLabel_GetMousePos = LABEL_MOUSEPOS_BOTTOMEDGE
Exit Function
End If
'center
If IsPointInSquare(MousePosX, MousePosY, GFPBLabelStructArray(LabelIndex).LabelXPos, GFPBLabelStructArray(LabelIndex).LabelYPos, _
GFPBLabelStructArray(LabelIndex).LabelXSize, GFPBLabelStructArray(LabelIndex).LabelYSize) = True Then
GFPBLabel_GetMousePos = LABEL_MOUSEPOS_CENTER
Exit Function
End If
'other
GFPBLabel_GetMousePos = LABEL_MOUSEPOS_NOTONLABEL
Exit Function
End Function
Public Sub GFPBLabel_Draw()
'on error resume next
Dim LineArray() As String
Dim LineNumber As Integer
Dim LineLoop As Integer
Dim hWndArray() As Long
Dim hWndNumber As Integer
Dim hWndLoop As Integer
Dim LabelLoop As Integer
'begin
For LabelLoop = 1 To GFPBLabelStructNumber
'clear target picture if not done yet
For hWndLoop = 1 To hWndNumber
If GFPBLabelStructArray(LabelLoop).LabelTargetPicture.hWnd = _
hWndArray(hWndLoop) Then
GoTo Jump:
End If
Next hWndLoop
hWndNumber = hWndNumber + 1 'LabelLoop cannot exceed 32767
ReDim Preserve hWndArray(1 To hWndNumber) As Long
hWndArray(hWndNumber) = GFPBLabelStructArray(LabelLoop).LabelTargetPicture.hWnd
GFPBLabelStructArray(LabelLoop).LabelTargetPicture.Cls 'reset
Jump:
'preset
GFPBLabelCreationPicture.Font.Name = GFPBLabelStructArray(LabelLoop).LabelFont.FontName
GFPBLabelCreationPicture.Font.Size = GFPBLabelStructArray(LabelLoop).LabelFont.FontSize
GFPBLabelCreationPicture.Font.Bold = GFPBLabelStructArray(LabelLoop).LabelFont.FontBoldFlag
GFPBLabelCreationPicture.Font.Italic = GFPBLabelStructArray(LabelLoop).LabelFont.FontItalicFlag
GFPBLabelCreationPicture.Font.Underline = GFPBLabelStructArray(LabelLoop).LabelFont.FontUnderlineFlag
GFPBLabelCreationPicture.Font.Strikethrough = GFPBLabelStructArray(LabelLoop).LabelFont.FontStrikeThroughFlag
'verify
If GFPBLabelStructArray(LabelLoop).LabelXSize < LabelXSizeMin Then GFPBLabelStructArray(LabelLoop).LabelXSize = LabelXSizeMin
If GFPBLabelStructArray(LabelLoop).LabelYSize < LabelYSizeMin Then GFPBLabelStructArray(LabelLoop).LabelYSize = LabelYSizeMin
'begin
'
Call GFGetLineArrayThroughLineWidth(GFPBLabelStructArray(LabelLoop).LabelText, _
GFPBLabelStructArray(LabelLoop).LabelXSize ‑ LabelXSizeMin, LabelXSizeMin, Chr$(32), LineArray(), LineNumber, GFPBLabelCreationPicture)
'
GFPBLabelCreationPicture.Width = GetFormattedTwipsX((GFPBLabelStructArray(LabelLoop).LabelXSize) + (GFPBLabelCreationPicture.Width ‑ GFPBLabelCreationPicture.ScaleWidth)) 'important: use formatted twips or any MouseDown event will occur without end (VB ERROR?)
GFPBLabelCreationPicture.Height = GetFormattedTwipsY((GFPBLabelStructArray(LabelLoop).LabelYSize) + (GFPBLabelCreationPicture.Height ‑ GFPBLabelCreationPicture.ScaleHeight)) 'important: use formatted twips or any MouseDown event will occur without end (VB ERROR?)
GFPBLabelCreationPicture.ForeColor = GFPBLabelStructArray(LabelLoop).LabelForeColor
GFPBLabelCreationPicture.BackColor = GFPBLabelStructArray(LabelLoop).LabelBackColor
GFPBLabelCreationPicture.Cls 'reset
GFPBLabelCreationPicture.CurrentX = 0 'reset
GFPBLabelCreationPicture.CurrentY = 0 'reset
For LineLoop = 1 To LineNumber
GFPBLabelCreationPicture.Print LineArray(LineLoop)
'NOTE: if the text does not fit into the picture box, it will be cut.
Next LineLoop
'transfer label text
Call BitBlt(GFPBLabelStructArray(LabelLoop).LabelTargetPicture.hDC, _
GetPixelsFromTwipsX(GFPBLabelStructArray(LabelLoop).LabelXPos), _
GetPixelsFromTwipsY(GFPBLabelStructArray(LabelLoop).LabelYPos), _
GetPixelsFromTwipsX(GFPBLabelCreationPicture.ScaleWidth), _
GetPixelsFromTwipsY(GFPBLabelCreationPicture.ScaleHeight), _
GFPBLabelCreationPicture.hDC, 0, 0, vbSrcCopy)
If GFPBMouseStructVar.MouseActionLabelIndex = LabelLoop Then
GFPBLabelStructArray(LabelLoop).LabelTargetPicture.Line (GFPBLabelStructArray _
(LabelLoop).LabelXPos, GFPBLabelStructArray(LabelLoop).LabelYPos)‑ _
(GFPBLabelStructArray(LabelLoop).LabelXPos + GFPBLabelStructArray(LabelLoop).LabelXSize ‑ 1, GFPBLabelStructArray _
(LabelLoop).LabelYPos + GFPBLabelStructArray(LabelLoop).LabelYSize ‑ 1), RGB(200, 0, 200), B
End If
'GFPBLabelStructArray(LabelLoop).LabelTargetPicture.Refresh 'display changes 'no!
Next LabelLoop
End Sub
'***********************************GENERAL FUNCTIONS***********************************
Private Function IsPointInSquare(ByVal PointX As Long, ByVal PointY As Long, ByVal SquareX As Long, ByVal SquareY As Long, ByVal Width As Long, ByVal Height As Long) As Boolean
On Error Resume Next 'can be used as general function; square Squares belong to square
Select Case PointX
Case Is < SquareX
GoTo Jump:
Case Is > (SquareX + Width)
GoTo Jump:
End Select
Select Case PointY
Case Is < SquareY
GoTo Jump:
Case Is > (SquareY + Height)
GoTo Jump:
End Select
IsPointInSquare = True
Exit Function
Jump:
IsPointInSquare = False 'point is not in defined area
Exit Function
End Function
Private Function GFGetLineArrayThroughLineWidth(ByVal InputString As String, ByVal LineWidthMax As Long, ByVal LineWidthOverflowMax As Long, ByVal LineBorderChar As String, ByRef LineArray() As String, ByRef LineNumber As Integer, ByVal LineWidthPicture As PictureBox) As Boolean
'on error resume next 'use as general function to create a text block with defined width; function returns True for success or False for error
Dim Temp As Long
'preset
LineNumber = 0
ReDim LineArray(1 To 1) As String
'verify
If Not (Len(LineBorderChar) = 1) Then
GoTo Error:
End If
If InputString = "" Then
GFGetLineArrayThroughLineWidth = True 'ok
Exit Function
End If
'begin
Temp = 0 'reset
Do
Temp = Temp + 1
If Mid$(InputString, Temp, 2) = Chr$(13) + Chr$(10) Then
If Not (LineNumber = 32767) Then 'verify
LineNumber = LineNumber + 1
Else
GoTo Error:
End If
ReDim Preserve LineArray(1 To LineNumber) As String
LineArray(LineNumber) = Left$(InputString, Temp ‑ 1)
InputString = Right$(InputString, Len(InputString) ‑ Temp ‑ 1)
Temp = 0 'reset
Else
If Mid$(InputString, Temp, 1) = LineBorderChar Then
Select Case LineWidthPicture.TextWidth(Left$(InputString, Temp ‑ 1))
Case Is < LineWidthMax
'do nothing
Case Is >= LineWidthMax
If Not (LineNumber = 32767) Then 'verify
LineNumber = LineNumber + 1
Else
GoTo Error:
End If
ReDim Preserve LineArray(1 To LineNumber) As String
LineArray(LineNumber) = Left$(InputString, Temp ‑ 1)
InputString = Right$(InputString, Len(InputString) ‑ Temp + 0)
Temp = 0 'reset
End Select
Else
Select Case LineWidthPicture.TextWidth(Left$(InputString, Temp ‑ 1))
Case Is < LineWidthMax
'do nothing
Case Is >= (LineWidthMax + LineWidthOverflowMax)
If Not (LineNumber = 32767) Then 'verify
LineNumber = LineNumber + 1
Else
GoTo Error:
End If
ReDim Preserve LineArray(1 To LineNumber) As String
LineArray(LineNumber) = Left$(InputString, Temp ‑ 1)
InputString = Right$(InputString, Len(InputString) ‑ Temp + 1)
Temp = 0 'reset
End Select
End If
End If
If Temp = Len(InputString) Then
If Not (LineNumber = 32767) Then 'verify
LineNumber = LineNumber + 1
Else
GoTo Error:
End If
ReDim Preserve LineArray(1 To LineNumber) As String
LineArray(LineNumber) = InputString
Exit Do
End If
Loop
GFGetLineArrayThroughLineWidth = True 'ok
Exit Function
Error:
MsgBox "internal error in GFGetLineArrayThroughLineWidth() !", vbOKOnly + vbExclamation
GFGetLineArrayThroughLineWidth = False 'error
Exit Function
End Function
Private Function GetPixelsFromTwipsX(ByVal TwipsX As Single) As Long
'on error resume next
GetPixelsFromTwipsX = TwipsX / Screen.TwipsPerPixelX
End Function
Private Function GetPixelsFromTwipsY(ByVal TwipsY As Single) As Long
'on error resume next
GetPixelsFromTwipsY = TwipsY / Screen.TwipsPerPixelY
End Function
Private Function GetFormattedTwipsX(ByVal TwipsX As Single) As Single
'on error resume next 'verifies return value is Screen.TwipsPerPixelX * x (x E N)
GetFormattedTwipsX = Int(TwipsX) ‑ (Int(TwipsX) Mod Screen.TwipsPerPixelX)
End Function
Private Function GetFormattedTwipsY(ByVal TwipsY As Single) As Single
'on error resume next 'verifies return value is Screen.TwipsPerPixelY * x (x E N)
GetFormattedTwipsY = Int(TwipsY) ‑ (Int(TwipsY) Mod Screen.TwipsPerPixelY)
End Function
[END OF FILE]