modlogui.bas

把VB 源码转化为VC源码的程序

            DumpBoxClassProc = 0
            Exit Function
        Case WM_HSCROLL
            Select Case (wParam And &HFFFF&)
                Case SB_LINELEFT
                    ReturnScrollValue = SendMessage(GetParent(hwnd), DUMPBOX_LINELEFT, GetScrollPos(hwnd, SB_HORZ), ByVal (wParam And &HFFFF0000) \ &H10000)
                    SetScrollPos hwnd, SB_HORZ, ReturnScrollValue, 1
                Case SB_LINERIGHT
                    ReturnScrollValue = SendMessage(GetParent(hwnd), DUMPBOX_LINERIGHT, GetScrollPos(hwnd, SB_HORZ), ByVal (wParam And &HFFFF0000) \ &H10000)
                    SetScrollPos hwnd, SB_HORZ, ReturnScrollValue, 1
                Case SB_PAGELEFT
                    ReturnScrollValue = SendMessage(GetParent(hwnd), DUMPBOX_PAGELEFT, GetScrollPos(hwnd, SB_HORZ), ByVal (wParam And &HFFFF0000) \ &H10000)
                    SetScrollPos hwnd, SB_HORZ, ReturnScrollValue, 1
                Case SB_PAGERIGHT
                    ReturnScrollValue = SendMessage(GetParent(hwnd), DUMPBOX_PAGERIGHT, GetScrollPos(hwnd, SB_HORZ), ByVal (wParam And &HFFFF0000) \ &H10000)
                    SetScrollPos hwnd, SB_HORZ, ReturnScrollValue, 1
                Case SB_THUMBTRACK
                    ReturnScrollValue = SendMessage(GetParent(hwnd), DUMPBOX_TRACKLEFTRIGHT, GetScrollPos(hwnd, SB_HORZ), ByVal (wParam And &HFFFF0000) \ &H10000)
                    SetScrollPos hwnd, SB_HORZ, ReturnScrollValue, 1
                Case SB_THUMBPOSITION
                    ReturnScrollValue = SendMessage(GetParent(hwnd), DUMPBOX_POSITIONLEFTRIGHT, GetScrollPos(hwnd, SB_HORZ), ByVal (wParam And &HFFFF0000) \ &H10000)
                    SetScrollPos hwnd, SB_HORZ, ReturnScrollValue, 1
                Case SB_TOP
                    ReturnScrollValue = SendMessage(GetParent(hwnd), DUMPBOX_LEFT, GetScrollPos(hwnd, SB_HORZ), ByVal (wParam And &HFFFF0000) \ &H10000)
                    SetScrollPos hwnd, SB_HORZ, ReturnScrollValue, 1
                Case SB_BOTTOM
                    ReturnScrollValue = SendMessage(GetParent(hwnd), DUMPBOX_RIGHT, GetScrollPos(hwnd, SB_HORZ), ByVal (wParam And &HFFFF0000) \ &H10000)
                    SetScrollPos hwnd, SB_HORZ, ReturnScrollValue, 1
            End Select
            DumpBoxClassProc = 0
            Exit Function
        Case WM_VSCROLL
            Select Case (wParam And &HFFFF&)
                Case SB_LINEUP
                    ReturnScrollValue = SendMessage(GetParent(hwnd), DUMPBOX_LINEUP, GetScrollPos(hwnd, SB_VERT), ByVal (wParam And &HFFFF0000) \ &H10000)
                    SetScrollPos hwnd, SB_VERT, ReturnScrollValue, 1
                Case SB_LINEDOWN
                    ReturnScrollValue = SendMessage(GetParent(hwnd), DUMPBOX_LINEDOWN, GetScrollPos(hwnd, SB_VERT), ByVal (wParam And &HFFFF0000) \ &H10000)
                    SetScrollPos hwnd, SB_VERT, ReturnScrollValue, 1
                Case SB_PAGEUP
                    ReturnScrollValue = SendMessage(GetParent(hwnd), DUMPBOX_PAGEUP, GetScrollPos(hwnd, SB_VERT), ByVal (wParam And &HFFFF0000) \ &H10000)
                    SetScrollPos hwnd, SB_VERT, ReturnScrollValue, 1
                Case SB_PAGEDOWN
                    ReturnScrollValue = SendMessage(GetParent(hwnd), DUMPBOX_PAGEDOWN, GetScrollPos(hwnd, SB_VERT), ByVal (wParam And &HFFFF0000) \ &H10000)
                    SetScrollPos hwnd, SB_VERT, ReturnScrollValue, 1
                Case SB_THUMBTRACK
                    ReturnScrollValue = SendMessage(GetParent(hwnd), DUMPBOX_TRACKUPDOWN, GetScrollPos(hwnd, SB_VERT), ByVal (wParam And &HFFFF0000) \ &H10000)
                    SetScrollPos hwnd, SB_VERT, ReturnScrollValue, 1
                Case SB_THUMBPOSITION
                    ReturnScrollValue = SendMessage(GetParent(hwnd), DUMPBOX_POSITIONUPDOWN, GetScrollPos(hwnd, SB_VERT), ByVal (wParam And &HFFFF0000) \ &H10000)
                    SetScrollPos hwnd, SB_VERT, ReturnScrollValue, 1
                Case SB_TOP
                    ReturnScrollValue = SendMessage(GetParent(hwnd), DUMPBOX_TOP, GetScrollPos(hwnd, SB_VERT), ByVal (wParam And &HFFFF0000) \ &H10000)
                    SetScrollPos hwnd, SB_VERT, ReturnScrollValue, 1
                Case SB_BOTTOM
                    ReturnScrollValue = SendMessage(GetParent(hwnd), DUMPBOX_BOTTOM, GetScrollPos(hwnd, SB_VERT), ByVal (wParam And &HFFFF0000) \ &H10000)
                    SetScrollPos hwnd, SB_VERT, ReturnScrollValue, 1
            End Select
            DumpBoxClassProc = 0
            Exit Function
    End Select
    DumpBoxClassProc = DefWindowProc(hwnd, uMsg, wParam, lParam)
End Function

' --- Draw a text on screen --- '
Public Sub GDIWriteText(ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal Text As String, ByVal TextColor As Long, ByVal hTextFont As Long, ByVal TextTransparent As Long, ByVal BackGroundColor As Long)
    Dim OldhObj As Long
    Dim OldBkMode As Long
    Dim OldTextColor As Long
    Dim OldBkColor As Long
    OldhObj = SelectObject(hDC, hTextFont)
    OldTextColor = SetTextColor(hDC, TextColor)
    If TextTransparent = 1 Then
        OldBkMode = SetBkMode(hDC, TRANSPARENT)
    Else
        OldBkMode = SetBkMode(hDC, OPAQUE)
        OldBkColor = SetBkColor(hDC, BackGroundColor)
    End If
    TextOut hDC, X, Y, Text, lstrlen(Text)
    If OldBkColor <> 0 Then SetBkColor hDC, OldBkColor
    SetTextColor hDC, OldTextColor
    SetBkMode hDC, OldBkMode
    SelectObject hDC, OldhObj
End Sub

' --- Retrieve the width of a font --- '
Public Function GDIGetFontWidth(ByVal hwnd As Long, ByVal hFont As Long) As Long
    Dim FonthDC As Long
    Dim hOldFont As Long
    Dim FontMetrics As TEXTMETRIC
    FonthDC = GetDC(hwnd)
    hOldFont = SelectObject(FonthDC, hFont)
    GetTextMetrics FonthDC, FontMetrics
    SelectObject FonthDC, hOldFont
    ReleaseDC hwnd, FonthDC
    GDIGetFontWidth = FontMetrics.tmAveCharWidth
End Function

' --- Retrieve the height of a font --- '
Public Function GDIGetFontHeight(ByVal hwnd As Long, ByVal hFont As Long) As Long
    Dim FonthDC As Long
    Dim hOldFont As Long
    Dim FontMetrics As TEXTMETRIC
    FonthDC = GetDC(hwnd)
    hOldFont = SelectObject(FonthDC, hFont)
    GetTextMetrics FonthDC, FontMetrics
    SelectObject FonthDC, hOldFont
    ReleaseDC hwnd, FonthDC
    GDIGetFontHeight = FontMetrics.tmHeight + FontMetrics.tmExternalLeading
End Function

' --- Retrieve text width --- '
Public Function GDIGetTextWidth(ByVal hwnd As Long, ByVal hFont As Long, ByVal Txt As String) As Long
    Dim ReturnValue As Long
    Dim TWHdc As Long
    Dim OldFont As Long
    Dim TmpTxt As String
    Dim FontSize As Size
    TWHdc = GetDC(hwnd)
    ' Select the font
    OldFont = SelectObject(TWHdc, hFont)
    GetTextExtentPoint32 TWHdc, Txt, lstrlen(Txt), FontSize
    ReturnValue = FontSize.cx
    SelectObject TWHdc, OldFont
    ReleaseDC hwnd, TWHdc
    GDIGetTextWidth = ReturnValue
End Function

' --- Create a systab control --- '
Public Function CreateSysTab(ByVal FLeft As Long, ByVal FTop As Long, ByVal FWidth As Long, ByVal FHeight As Long, ByVal hParent As Long, ByVal CtrlID As Long, ByVal WinProc As Long, ByVal hImageList As Long, ByVal ExtraStyle As Long) As Long
    Dim ReturnValue As Long
    ControlBound hParent, FLeft, FTop, FWidth, FHeight
    ReturnValue = CreateWindowEx(0, "SysTabControl32", "", WS_VISIBLE Or WS_CHILD Or ExtraStyle, FLeft, FTop, FWidth, FHeight, hParent, CtrlID, App.hInstance, ByVal 0)
    If ReturnValue = 0 Then Exit Function
    If hImageList <> 0 Then SendMessage ReturnValue, TCM_SETIMAGELIST, 0, ByVal hImageList
    If WinProc <> 0 Then SetWindowLong ReturnValue, GWL_USERDATA, SetWindowLong(ReturnValue, GWL_WNDPROC, WinProc)
    ControlSetFont ReturnValue, SerifFont
    CreateSysTab = ReturnValue
End Function

' --- Add a tab to a systab control --- '
Public Function SysTabAddItem(ByVal htab As Long, ByVal TabText As String, ByVal TabIndex As Long, ByVal ImgIndex As Long) As Long
    Dim TabItem As TC_ITEM
    TabItem.iImage = ImgIndex
    TabItem.imask = TCIF_IMAGE
    If lstrlen(TabText) <> 0 Then
        TabItem.imask = TabItem.imask Or TCIF_TEXT
        TabItem.pszText = TabText
        TabItem.cchTextMax = lstrlen(TabText)
    End If
    SysTabAddItem = SendMessage(htab, TCM_INSERTITEM, TabIndex, TabItem)
End Function

' --- Retrieve the current selection of a tab control --- '
Public Function SysTabGetCurrentItem(ByVal htab As Long) As Long
    SysTabGetCurrentItem = SendMessage(htab, TCM_GETCURSEL, 0, ByVal 0)
End Function

' --- Show/Hide a control --- '
Public Function ControlVisible(ByVal hwnd As Long, ByVal CState As Boolean) As Long
    Dim ReturnValue As Long
    Select Case CState
        Case False
            ReturnValue = ShowWindow(hwnd, SW_HIDE)
        Case True
            ReturnValue = ShowWindow(hwnd, SW_SHOW)
    End Select
    ControlVisible = ReturnValue
End Function

' --- Create a colorbox control --- '
Public Function CreateColorBox(ByVal LLeft As Long, ByVal LTop As Long, ByVal LWidth As Long, ByVal LHeight As Long, ByVal hParent As Long, ByVal CtrlID As Long, ByVal Color As Long, ByVal ExtraStyle As Long) As Long
    Dim ReturnValue As Long
    ControlBound hParent, LLeft, LTop, LWidth, LHeight
    ReturnValue = CreateWindowEx(0, "VB2CppColorBoxClass", "", WS_VISIBLE Or WS_CHILD Or ExtraStyle, LLeft, LTop, LWidth, LHeight, hParent, CtrlID, App.hInstance, ByVal 0)
    If ReturnValue = 0 Then Exit Function
    SetWindowLong ReturnValue, GWL_USERDATA, Color
    ControlSetFont ReturnValue, SerifFont
    CreateColorBox = ReturnValue
End Function

' --- Retrieve color from a colorbox control --- '
Public Function ColorBoxGetColor(ByVal hwnd As Long) As Long
    ColorBoxGetColor = GetWindowLong(hwnd, GWL_USERDATA)
End Function

' --- Retrieve color from a colorbox control --- '
Public Function ColorBoxSetColor(ByVal hwnd As Long, ByVal Color As Long) As Long
    SetWindowLong hwnd, GWL_USERDATA, Color
    ColorBoxSetColor = RedrawWindow(hwnd, 0, 0, RDW_ERASE Or RDW_INVALIDATE)
End Function

' --- Default class hook for colorbox controls --- '
Private Function ColorBoxClassProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim PaintRect As RECT
    Dim BlackBrush As LOGBRUSH
    Dim hBlackBrush As Long
    Dim Hicolor As Long
    Dim HicolorR As Long
    Dim HicolorG As Long
    Dim HicolorB As Long
    Dim LoColor As Long
    Dim LoColorR As Long
    Dim LoColorG As Long
    Dim LoColorB As Long
    Select Case uMsg
        Case WM_LBUTTONDOWN
            SendMessage GetParent(hwnd), MSG_COLORBOX_CLICKED, hwnd, ByVal 0
            ColorBoxClassProc = 0
            Exit Function
        Case WM_ERASEBKGND
            GetClientRect hwnd, PaintRect
            BlackBrush.lbStyle = BS_SOLID
            BlackBrush.lbHatch = 0
            BlackBrush.lbColor = GetWindowLong(hwnd, GWL_USERDATA)
            hBlackBrush = CreateBrushIndirect(BlackBrush)
            FillRect wParam, PaintRect, hBlackBrush
            Hicolor = BlackBrush.lbColor
            HicolorR = (Hicolor And &HFF0000) \ &H10000
            HicolorG = (Hicolor And &HFF00&) \ &H100&
            HicolorB = Hicolor And &HFF&
            LoColorR = HicolorR - 64
            LoColorG = HicolorG - 64
            LoColorB = HicolorB - 64
            HicolorR = HicolorR + 64
            HicolorG = HicolorG + 64
            HicolorB = HicolorB + 64
            If HicolorR > &HFF& Then HicolorR = &HFF&
            If HicolorG > &HFF& Then HicolorG = &HFF&
            If HicolorB > &HFF& Then HicolorB = &HFF&
            If LoColorR < 0 Then LoColorR = 0
            If LoColorG < 0 Then LoColorG = 0
            If LoColorB < 0 Then LoColorB = 0
            Hicolor = (HicolorR * &H10000) Or (HicolorG * &H100) Or HicolorB
            LoColor = (LoColorR * &H10000) Or (LoColorG * &H100) Or LoColorB
            GDIDrawLine hwnd, 0, 0, 0, (PaintRect.bottom - PaintRect.top) - 1, Hicolor
            GDIDrawLine hwnd, 0, 0, (PaintRect.Right - PaintRect.left) - 1, 0, Hicolor
            GDIDrawLine hwnd, 1, (PaintRect.bottom - PaintRect.top) - 1, (PaintRect.Right - PaintRect.left), (PaintRect.bottom - PaintRect.top) - 1, LoColor
            GDIDrawLine hwnd, (PaintRect.Right - PaintRect.left) - 1, 1, (PaintRect.Right - PaintRect.left) - 1, (PaintRect.bottom - PaintRect.top) - 1, LoColor
            DeleteObject hBlackBrush
            ColorBoxClassProc = 1
            Exit Function
        Case WM_CLOSE
            DestroyWindow hwnd
            ColorBoxClassProc = 0
            Exit Function
    End Select
    ColorBoxClassProc = DefWindowProc(hwnd, uMsg, wParam, lParam)
End Function

' --- Choose a color from the palette --- '
Public Function MiscChooseCol(hwnd As Long, DefaultCol As Long) As Long
    MyColor.hInstance = App.hInstance
    MyColor.hwndOwner = hwnd
    MyColor.rgbResult = DefaultCol
    MyColor.lCustData = 0
    MyColor.lpCustColors = VarPtr(MyCustomColors)
    MyColor.lpfnHook = 0
    MyColor.flags = CC_FULLOPEN + CC_RGBINIT
    MyColor.lStructSize = Len(MyColor)
    MiscChooseCol = ChooseColor(MyColor)
End Function