Programmer 7500/MAX_PROGRAMMERS.iso/VISUAL_B/CODIGO_2/TOOL_WND/VBQHELP.BAS

BASIC Source File | 1994-05-26 | 20.5 KB | 503 lines

Option Explicit

Global Const MouseMove = 1
Global Const MouseDown = 2
Global Const MouseButton = 3

Global Const vbQHFalse = 1
Global Const vbQHTrue = 2

Dim forced                  As Integer
Dim loaded                  As Integer
Dim sUsed                   As Integer
Dim pUsed                   As Integer
Dim qhloaded                As Integer
'Dim qvisible                As Integer

Dim MyStrings()             As String
Dim ToolRecs()              As apiRect
'Dim tRect()                 As apiRect

Dim tRect()                 As apiRect

Declare Function GetCursor Lib "User" () As Integer
Declare Function LoadCursor Lib "User" (ByVal hInstance As Integer, ByVal lpCursorName As Any) As Integer
Declare Function DestroyCursor Lib "User" (ByVal hCursor As Integer) As Integer

Sub vbCopyTool (src As Control, trg As Control, Flag As Integer)
Dim sep As Integer, i As Integer, rc As Integer
Dim x As Integer, Y As Integer, dx As Integer, dy As Integer
Dim temp$
Dim tRect As apiRect
Static tools As Integer
    temp$ = src.Tag
    If Len(temp$) Then
        x = Val(temp$)
        sep = InStr(temp$, ",")
        temp$ = Right$(temp$, Len(temp$) - sep)
        Y = Val(temp$)
        sep = InStr(temp$, ",")
        temp$ = Right$(temp$, Len(temp$) - sep)
        dx = Val(temp$)
        sep = InStr(temp$, ",")
        temp$ = Right$(temp$, Len(temp$) - sep)
        dy = Val(temp$)
        GetWindowRect src.hWnd, tRect
        trg.AutoRedraw = True
        rc = StretchBlt(trg.hDC, x, Y, dx, dy, src.hDC, 0, 0, tRect.Right - tRect.Left, tRect.Bottom - tRect.Top, SrcCopy)

        trg.Refresh
        trg.Picture = trg.Image
        If Flag = vbQHTrue Then
            If tools Then
                ReDim Preserve ToolRecs(UBound(ToolRecs) + 1)
            Else
                ReDim ToolRecs(0)
                tools = True
            End If
            rc = (UBound(ToolRecs))
            ToolRecs(rc).Left = x
            ToolRecs(rc).Top = Y
            ToolRecs(rc).Right = dx
            ToolRecs(rc).Bottom = dy
        End If
    Else
        MsgBox "Keine Position fⁿr Tool angegeben!", 4096
    End If
End Sub

Function vbGetCursorHeight () As Integer
Dim hCur As Integer, rc As Integer
Dim hsx As Integer, hsy As Integer
    hCur = GetCursor()
    'vbQHelpForm.Show
    rc = DrawIcon(vbQHelpForm.hDC, 0, 0, hCur)
    vbQHelpForm.Refresh
    ' Find the height
    vbGetCursorHeight = GetSystemMetrics(14)
    For hsy = GetSystemMetrics(14) To 1 Step -1
        For hsx = GetSystemMetrics(13) To 1 Step -1
            If vbQHelpForm.Point(hsx, hsy) = 0 Then
                vbGetCursorHeight = hsy
                GoTo vbGetCursorHeightExit
            End If
            'vbQHelpForm.PSet (hsx, hsy)
        Next hsx
    Next hsy
vbGetCursorHeightExit:
    vbQHelpForm.Cls
End Function

Function vbPaintedToolExt (MyBar As Control, Flag As Integer, Status As Control) As Integer
Dim i As Integer
Dim bRect As apiRect', dRect As apiRect
Static wPoint As apiPoint
Dim temp$
Static vbNext As Integer, tButton As Integer
Static rc As Integer
    Select Case Flag
        Case MouseDown
            If tButton <> True Then
                If vbNext Then
                    GetCursorPos wPoint
                    For i = 0 To rc
                        If wPoint.x > tRect(i).Left And wPoint.x < tRect(i).Right - 1 And wPoint.Y > tRect(i).Top And wPoint.Y < tRect(i).Bottom Then Exit For
                    Next i
                    If i <= rc Then tButton = i
                End If
                temp$ = vbQHGetString(tButton)
                i = InStr(temp$, "|")
                temp$ = Left$(temp$, i - 1)
                Status.Caption = temp$
                If vbToolExt(MyBar, Flag, ToolRecs(tButton), tButton) Then
                    vbPaintedToolExt = tButton
                Else
                    vbPaintedToolExt = True
                End If
            Else
                If Not sUsed Then
                    sUsed = True
                    vbNext = False
                    rc = vbPaintedToolExt(MyBar, MouseButton, Status)
                    rc = vbPaintedToolExt(MyBar, MouseDown, Status)
                    vbPaintedToolExt = rc
                    tButton = True
                    sUsed = False
                End If
            End If
            'Do
            '    DoEvents
            'Loop Until GetKeyState(1) >= 0
        Case MouseMove, MouseButton
            If pUsed Then Exit Function
            pUsed = True
            Do
                If Not vbNext Then
                    vbNext = True
                    rc = UBound(ToolRecs)
                    GetWindowRect MyBar.hWnd, bRect
                    ReDim tRect(rc)  As apiRect
                    For i = 0 To rc
                        tRect(i).Top = bRect.Top + ToolRecs(i).Top
                        tRect(i).Left = bRect.Left + ToolRecs(i).Left
                        tRect(i).Right = tRect(i).Left + ToolRecs(i).Right
                        tRect(i).Bottom = tRect(i).Top + ToolRecs(i).Bottom
                    Next i
                End If
                GetCursorPos wPoint
                For i = 0 To rc
                    If wPoint.x > tRect(i).Left And wPoint.x < tRect(i).Right - 1 And wPoint.Y > tRect(i).Top And wPoint.Y < tRect(i).Bottom Then Exit For
                Next i
                If i <= rc Then
                    tButton = i
                    If Flag = MouseButton Then pUsed = False: Exit Function
                    i = vbToolExt(MyBar, MouseMove, ToolRecs(i), i)
                End If
                tButton = True
                DoEvents
            Loop While wPoint.x > bRect.Left And wPoint.x < bRect.Right - 1 And wPoint.Y > bRect.Top And wPoint.Y < bRect.Bottom
            pUsed = False
            vbNext = False
            vbPaintedToolExt = True
    End Select
End Function

Sub vbqHelp (MyControl As Control, ForceStop As Integer)
Dim mWidth  As Integer, mHeight As Integer, rd As Integer, sep As Integer
Dim wPoint As apiPoint, wRect As apiRect
Dim NewTime As Long
Dim temp$
Static used As Integer, LastTime As Long
    If ForceStop Then   'Not forced And
        forced = ForceStop
        If loaded Then
            'vbQHelpForm.Hide
            'vbQHelpForm.Move -1000, -1000
            SetWindowPos vbQHelpForm.hWnd, -1, 0, 0, 0, 0, &H80'&H20 Or &H1 Or &H40 Or &H10 'Or &H8
        End If
    End If
    If used Then Exit Sub
    rd = MyControl.ScaleMode
    MyControl.ScaleMode = 3
    mWidth = MyControl.Width
    mHeight = MyControl.Height
    NewTime = GetTickCount()
    used = True
    GetWindowRect MyControl.hWnd, wRect
    If NewTime - LastTime > 1000 Then
        WaitZehntel 9
    End If
    Do
        DoEvents
        GetCursorPos wPoint
        If forced Then
            forced = False
            used = False
            loaded = False
            Unload vbQHelpForm
            Exit Sub
        End If
        If wPoint.x < wRect.Left Or wPoint.x > wRect.Right - 1 Or wPoint.Y < wRect.Top Or wPoint.Y > wRect.Bottom Then
            Exit Do
        Else
            If Not loaded Then
                Load vbQHelpForm
                sep = InStr(MyControl.Tag, "|")
                temp$ = Right$(MyControl.Tag, Len(MyControl.Tag) - sep)
                vbQHelpForm.CurrentX = 30
                vbQHelpForm.CurrentY = 30
                vbQHelpForm.Print temp$
                vbQHelpForm.Height = vbQHelpForm.TextHeight(temp$) + 60
                vbQHelpForm.Width = vbQHelpForm.TextWidth(temp$) + 60
                vbQHelpForm.Move 7.5 * (wRect.Left + wRect.Right) - .5 * vbQHelpForm.Width, stppy * (wPoint.Y + 16)
                vbQHelpForm.Line (0, 0)-(vbQHelpForm.Width - stppx, vbQHelpForm.Height - stppy), , B
                SetWindowPos vbQHelpForm.hWnd, -1, 0, 0, 0, 0, &H20 Or &H1 Or &H40 Or &H10 'Or &H8
                loaded = True
            End If
        End If
    Loop
    MyControl.ScaleMode = rd
    If loaded Then Unload vbQHelpForm
    loaded = False
    LastTime = GetTickCount()
    used = False
End Sub

Function vbQHGetString (Index As Integer) As String
    On Error Resume Next
    vbQHGetString = MyStrings(Index)
End Function

Sub vbQHPutString (Index As Integer, Help As String)
Static MyFlag As Integer
    If MyFlag Then
        If Index >= UBound(MyStrings) Then
            ReDim Preserve MyStrings(Index)
        End If
    Else
        ReDim MyStrings(Index)
        MyFlag = True
    End If
    MyStrings(Index) = Help
End Sub

Function vbTool (MyTool As Control, Flag As Integer) As Integer
Dim mKey As Integer, mWidth As Integer, mHeight As Integer, sm As Integer
Dim ButtonState As Integer, ds As Integer, dm As Integer, sep As Integer
Dim wPoint As apiPoint, wRect As apiRect
Dim temp$
Dim NewTime As Long
Dim rc As Integer, py As Integer, px As Integer
Static LastTime As Long
    On Error Resume Next
    Select Case Flag
        Case MouseDown
            MyTool.Cls
            GetWindowRect MyTool.hWnd, wRect
            mWidth = wRect.Right - wRect.Left
            mHeight = wRect.Bottom - wRect.Top
            sm = MyTool.ScaleMode
            ds = MyTool.DrawStyle
            dm = MyTool.DrawMode
            MyTool.ScaleMode = 3
            MyTool.DrawStyle = 0
            MyTool.DrawMode = 13
            Do
                mKey = GetKeyState(1)
                DoEvents
                GetCursorPos wPoint
                If mKey >= 0 Then
                    Exit Do
                End If
                If wPoint.x < wRect.Left Or wPoint.x > wRect.Right - 1 Or wPoint.Y < wRect.Top Or wPoint.Y > wRect.Bottom Then
                    If ButtonState Then MyTool.Cls
                    ButtonState = False
                Else
                    If mKey < 0 Then
                        If ButtonState = False Then
                            rc = BitBlt(MyTool.hDC, 3, 3, mWidth - 4, mHeight - 4, MyTool.hDC, 2, 2, SrcCopy)
                            MyTool.Line (2, 2)-(mWidth - 2, 2), RGB(192, 192, 192)
                            MyTool.Line (2, 3)-(2, mHeight - 2), RGB(192, 192, 192)
                            MyTool.Line (1, 1)-(1, mHeight - 2), RGB(128, 128, 128)
                            MyTool.Line (1, 1)-(mWidth - 2, 1), RGB(128, 128, 128)
                            MyTool.Line (2, mHeight - 2)-(mWidth - 2, mHeight - 2), RGB(192, 192, 192)'RGB(255, 255, 255)
                            MyTool.Line (mWidth - 2, 2)-(mWidth - 2, mHeight - 1), RGB(192, 192, 192)'RGB(255, 255, 255)
                            DoEvents
                            ButtonState = True
                            If qhloaded Then
                                SetWindowPos vbQHelpForm.hWnd, -1, 0, 0, 0, 0, &H80 Or &H10
                            End If
                        End If
                    Else
                        If ButtonState Then
                            MyTool.Cls
                            ButtonState = False
                        Else
                        End If
                    End If
                End If
            Loop
            vbTool = ButtonState
            If ButtonState Then forced = True
            ButtonState = False
            MyTool.ScaleMode = sm
            MyTool.DrawStyle = ds
            MyTool.DrawMode = dm
            MyTool.Cls
            MyTool.Refresh
        Case MouseMove
            If sUsed Then Exit Function
            sUsed = True
            NewTime = GetTickCount()
            GetWindowRect MyTool.hWnd, wRect
            mWidth = wRect.Right - wRect.Left
            mHeight = wRect.Bottom - wRect.Top
            If NewTime - LastTime > 1000 Then
                WaitZehntel 9
            End If
            Do
                GetCursorPos wPoint
                DoEvents
                If forced Then
                    forced = False
                    sUsed = False
                    qhloaded = False
                    Unload vbQHelpForm
                    vbTool = False
                    Exit Function
                End If
                If wPoint.x < wRect.Left Or wPoint.x > wRect.Right - 1 Or wPoint.Y < wRect.Top Or wPoint.Y > wRect.Bottom Then
                    Exit Do
                Else
                    If Not qhloaded Then
                        Load vbQHelpForm
                        sep = InStr(MyTool.Tag, "|")
                        temp$ = Right$(MyTool.Tag, Len(MyTool.Tag) - sep)
                        vbQHelpForm.CurrentX = 30
                        vbQHelpForm.CurrentY = 30
                        vbQHelpForm.Print temp$
                        vbQHelpForm.Height = vbQHelpForm.TextHeight(temp$) + 60
                        vbQHelpForm.Width = vbQHelpForm.TextWidth(temp$) + 60
                        vbQHelpForm.Line (0, 0)-(vbQHelpForm.Width - stppx, vbQHelpForm.Height - stppy), , B
                        GetCursorPos wPoint
                        sep = GetSystemMetrics(14)
                        px = ((wRect.Left + wRect.Right) - vbQHelpForm.Width / stppx) / 2
                        If px < 0 Then
                            px = 0
                        ElseIf (px + vbQHelpForm.Width / stppx) > GetSystemMetrics(0) Then
                            px = GetSystemMetrics(0) - vbQHelpForm.Width / stppx
                        End If
                        py = (wPoint.Y + 18)
                        If py + vbQHelpForm.Height / stppy > GetSystemMetrics(1) Then
                            py = wPoint.Y - 2 - vbQHelpForm.Height / stppy
                        End If
                        vbQHelpForm.Move px * stppx, stppy * py
                        SetWindowPos vbQHelpForm.hWnd, -1, 0, 0, 0, 0, &H20 Or &H1 Or &H40 Or &H10 'Or &H8
                        qhloaded = True
                    End If
                End If
            Loop
            If qhloaded Then Unload vbQHelpForm
            qhloaded = False
            LastTime = GetTickCount()
            sUsed = False
            vbTool = True
    End Select
End Function

Function vbToolExt (MyTool As Control, Flag As Integer, MyRect As apiRect, Index As Integer) As Integer
Dim mKey As Integer, mWidth As Integer, mHeight As Integer, sm As Integer
Dim ButtonState As Integer, ds As Integer, dm As Integer, sep As Integer
Dim wPoint As apiPoint, wRect As apiRect
Dim temp$
Dim NewTime As Long
Dim rc As Integer, py As Integer, px As Integer
Static LastTime As Long
    On Error Resume Next
    Select Case Flag
        Case MouseDown
            MyTool.Cls
            GetWindowRect MyTool.hWnd, wRect
            wRect.Top = wRect.Top + MyRect.Top
            wRect.Left = wRect.Left + MyRect.Left
            wRect.Right = wRect.Left + MyRect.Right
            wRect.Bottom = wRect.Top + MyRect.Bottom
            mWidth = wRect.Right - wRect.Left
            mHeight = wRect.Bottom - wRect.Top
            sm = MyTool.ScaleMode
            ds = MyTool.DrawStyle
            dm = MyTool.DrawMode
            MyTool.ScaleMode = 3
            MyTool.DrawStyle = 0
            MyTool.DrawMode = 13
            Do
                mKey = GetKeyState(1)
                DoEvents
                GetCursorPos wPoint
                If mKey >= 0 Then
                    Exit Do
                End If
                If wPoint.x < wRect.Left Or wPoint.x > wRect.Right - 1 Or wPoint.Y < wRect.Top Or wPoint.Y > wRect.Bottom Then
                    If ButtonState Then MyTool.Cls
                    ButtonState = False
                Else
                    If mKey < 0 Then
                        If ButtonState = False Then
                            rc = BitBlt(MyTool.hDC, 3 + MyRect.Left, 3 + MyRect.Top, mWidth - 4, mHeight - 4, MyTool.hDC, 2 + MyRect.Left, 2 + MyRect.Top, SrcCopy)
                            MyTool.Line (2 + MyRect.Left, 2 + MyRect.Top)-(mWidth - 2 + MyRect.Left, 2 + MyRect.Top), RGB(192, 192, 192)
                            MyTool.Line (2 + MyRect.Left, 3 + MyRect.Top)-(2 + MyRect.Left, mHeight - 2 + MyRect.Top), RGB(192, 192, 192)
                            MyTool.Line (1 + MyRect.Left, 1 + MyRect.Top)-(1 + MyRect.Left, mHeight - 2 + MyRect.Top), RGB(128, 128, 128)
                            MyTool.Line (1 + MyRect.Left, 1 + MyRect.Top)-(mWidth - 2 + MyRect.Left, 1 + MyRect.Top), RGB(128, 128, 128)
                            MyTool.Line (2 + MyRect.Left, mHeight - 2 + MyRect.Top)-(mWidth - 2 + MyRect.Left, mHeight - 2 + MyRect.Top), RGB(192, 192, 192)'RGB(255, 255, 255)
                            MyTool.Line (mWidth - 2 + MyRect.Left, 2 + MyRect.Top)-(mWidth - 2 + MyRect.Left, mHeight - 1 + MyRect.Top), RGB(192, 192, 192)'RGB(255, 255, 255)
                            DoEvents
                            ButtonState = True
                            If qhloaded Then
                                SetWindowPos vbQHelpForm.hWnd, -1, 0, 0, 0, 0, &H80 Or &H10
                                qhloaded = False
                            End If
                        End If
                    Else
                        If ButtonState Then
                            MyTool.Cls
                            ButtonState = False
                        Else
                        End If
                    End If
                End If
            Loop
            vbToolExt = ButtonState
            If ButtonState Then forced = True
            ButtonState = False
            MyTool.ScaleMode = sm
            MyTool.DrawStyle = ds
            MyTool.DrawMode = dm
            MyTool.Cls
            MyTool.Refresh
        Case MouseMove
            If sUsed Then Exit Function
            sUsed = True
            NewTime = GetTickCount()
            GetWindowRect MyTool.hWnd, wRect
            wRect.Top = wRect.Top + MyRect.Top
            wRect.Left = wRect.Left + MyRect.Left
            wRect.Right = wRect.Left + MyRect.Right
            wRect.Bottom = wRect.Top + MyRect.Bottom
            mWidth = wRect.Right - wRect.Left
            mHeight = wRect.Bottom - wRect.Top
            If NewTime - LastTime > 1000 Then
                WaitZehntel 9
            End If
            Do
                GetCursorPos wPoint
                DoEvents
                If forced Then
                    forced = False
                    sUsed = False
                    qhloaded = False
                    Unload vbQHelpForm
                    vbToolExt = False
                    Exit Function
                End If
                If wPoint.x < wRect.Left Or wPoint.x > wRect.Right - 1 Or wPoint.Y < wRect.Top Or wPoint.Y > wRect.Bottom Then
                    Exit Do
                Else
                    If Not qhloaded Then
                        Load vbQHelpForm
                        temp$ = vbQHGetString(Index)
                        sep = InStr(temp$, "|")
                        temp$ = Right$(temp$, Len(temp$) - sep)
                        sep = vbGetCursorHeight() - 1
                        vbQHelpForm.CurrentX = 2
                        vbQHelpForm.CurrentY = 2
                        vbQHelpForm.Print temp$
                        vbQHelpForm.Height = (vbQHelpForm.TextHeight(temp$) + 4) * stppx
                        vbQHelpForm.Width = (vbQHelpForm.TextWidth(temp$) + 4) * stppy
                        vbQHelpForm.Line (0, 0)-(vbQHelpForm.Width / stppx - 1, vbQHelpForm.Height / stppy - 1), , B
                        GetCursorPos wPoint

                        px = ((wRect.Left + wRect.Right) - vbQHelpForm.Width / stppx) / 2
                        If px < 0 Then
                            px = 0
                        ElseIf (px + vbQHelpForm.Width / stppx) > GetSystemMetrics(0) Then
                            px = GetSystemMetrics(0) - vbQHelpForm.Width / stppx
                        End If
                        py = (wPoint.Y + sep)
                        If py + vbQHelpForm.Height / stppy > GetSystemMetrics(1) Then
                            py = wPoint.Y - 2 - vbQHelpForm.Height / stppy
                        End If
                        vbQHelpForm.Move px * stppx, stppy * py
                        SetWindowPos vbQHelpForm.hWnd, -1, 0, 0, 0, 0, &H20 Or &H1 Or &H40 Or &H10 'Or &H8
                        qhloaded = True
                    End If
                End If
            Loop
            If qhloaded Then Unload vbQHelpForm
            qhloaded = False
            LastTime = GetTickCount()
            sUsed = False
            vbToolExt = True
    End Select
End Function