modlogui.bas

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

    CursorSetNormal = SetCursor(LoadCursor(0, IDC_ARROW))
End Function

' --- Remove a form --- '
Public Sub UnLoadForm(hwnd As Long)
    SendMessage hwnd, WM_CLOSE, 0, ByVal 0
End Sub

' --- Retrieve window handle of a notified message --- '
Public Function ControlGetNotifiedhWnd(ByVal lParam As Long) As Long
    Dim HeaderNotify As NMHDR
    CopyMemory HeaderNotify, ByVal lParam, Len(HeaderNotify)
    ControlGetNotifiedhWnd = HeaderNotify.hwndFrom
End Function

' --- Retrieve type of a notified message --- '
Public Function ControlGetNotifiedMsg(ByVal lParam As Long) As Long
    Dim HeaderNotify As NMHDR
    CopyMemory HeaderNotify, ByVal lParam, Len(HeaderNotify)
    ControlGetNotifiedMsg = HeaderNotify.code
End Function

' --- Get control top --- '
Public Function ControlTop(ByVal hwnd As Long) As Long
    Dim ReturnValue As Long
    Dim CRct As RECT
    GetWindowRect hwnd, CRct
    If ControlIsVisible(hwnd) = 0 Then
        ReturnValue = 0
    Else
        ReturnValue = CRct.top
    End If
    ControlTop = ReturnValue
End Function

' --- Get control left --- '
Public Function ControlLeft(ByVal hwnd As Long) As Long
    Dim ReturnValue As Long
    Dim CRct As RECT
    GetWindowRect hwnd, CRct
    If ControlIsVisible(hwnd) = 0 Then
        ReturnValue = 0
    Else
        ReturnValue = CRct.left
    End If
    ControlLeft = ReturnValue
End Function

' --- Get width of client part of a control --- '
Public Function ControlClientWidth(ByVal hwnd As Long) As Long
    Dim ReturnValue As Long
    Dim CRct As RECT
    GetClientRect hwnd, CRct
    If ControlIsVisible(hwnd) = 0 Then
        ReturnValue = 0
    Else
        ReturnValue = CRct.Right - CRct.left
    End If
    ControlClientWidth = ReturnValue
End Function

' --- Get height of client part of a control --- '
Public Function ControlClientHeight(ByVal hwnd As Long) As Long
    Dim ReturnValue As Long
    Dim CRct As RECT
    GetClientRect hwnd, CRct
    If ControlIsVisible(hwnd) = 0 Then
        ReturnValue = 0
    Else
        ReturnValue = CRct.bottom - CRct.top
    End If
    ControlClientHeight = ReturnValue
End Function

' --- Retrieve visible state of a control --- '
Public Function ControlIsVisible(ByVal hwnd As Long) As Long
    ControlIsVisible = IsWindowVisible(hwnd)
End Function

' --- Draw a line --- '
Public Sub GDIDrawLine(ByVal hwnd As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal LineColor As Long)
    Dim LinePT As POINTAPI
    Dim hPen As Long
    Dim OldhPen As Long
    Dim LineHDC As Long
    LineHDC = GetDC(hwnd)
    hPen = CreatePen(PS_SOLID, 0, LineColor)
    MoveToEx LineHDC, X1, Y1, LinePT
    OldhPen = SelectObject(LineHDC, hPen)
    LineTo LineHDC, X2, Y2
    SelectObject LineHDC, OldhPen
    DeleteObject hPen
    ReleaseDC hwnd, LineHDC
End Sub

' --- Create a back DC for double buffering purposes --- '
Public Function GDICreateBackDC(BackStruct As BACKDCSTRUCT) As Long
    Dim GridRect As RECT
    Dim WinRect As RECT
    Dim BitmapInfos As BITMAPINFOHEADER
    Dim DIBBits As Long
    Dim i As Long
    Dim SysBackCol As Long
    Dim BackDC As Long
    Dim BackhBitmap As Long
    Dim OldObject As Long
    Dim hBrush As Long
    BackDC = CreateCompatibleDC(0)
    BackStruct.hDC = BackDC
    If BackDC <> 0 Then
        GetClientRect BackStruct.hwnd, WinRect
        GridRect.left = 0
        GridRect.top = 0
        GridRect.Right = WinRect.Right - WinRect.left
        GridRect.bottom = WinRect.bottom - WinRect.top
        BitmapInfos.biSize = Len(BitmapInfos)
        BitmapInfos.biWidth = GridRect.Right
        BitmapInfos.biHeight = GridRect.bottom
        BitmapInfos.biPlanes = 1
        BitmapInfos.biBitCount = 32
        BitmapInfos.biCompression = BI_RGB
        BitmapInfos.biSizeImage = 0
        BitmapInfos.biXPelsPerMeter = 0
        BitmapInfos.biYPelsPerMeter = 0
        BitmapInfos.biClrUsed = 0
        BitmapInfos.biClrImportant = 0
        BackhBitmap = CreateDIBSection(BackDC, BitmapInfos, DIB_RGB_COLORS, DIBBits, 0, 0)
        BackStruct.Bitmap = BackhBitmap
        If BackhBitmap <> 0 Then
            OldObject = SelectObject(BackDC, BackhBitmap)
            BackStruct.OldObject = OldObject
            hBrush = GDICreateColorBrush(BackStruct.Color)
            FillRect BackDC, GridRect, hBrush
        End If
    End If
    GDICreateBackDC = BackDC
End Function

' --- Destroy a back DC for double buffering --- '
Public Sub GDIDestroyBackDC(BackStruct As BACKDCSTRUCT)
    If BackStruct.hDC <> 0 Then
        SelectObject BackStruct.hDC, BackStruct.OldObject
        DeleteObject BackStruct.Bitmap
        DeleteDC BackStruct.hDC
    End If
End Sub

' --- Display a back DC --- '
Public Function GDIBlitBackDC(Dimensions As RECT, BackStruct As BACKDCSTRUCT) As Long
    Dim DesthDC As Long
    DesthDC = GetDC(BackStruct.hwnd)
    GDIBlitBackDC = BitBlt(DesthDC, Dimensions.left, Dimensions.top, Dimensions.Right, Dimensions.bottom, BackStruct.hDC, 0, 0, SRCCOPY)
    ReleaseDC BackStruct.hwnd, DesthDC
End Function

' --- Create a colored brush --- '
Public Function GDICreateColorBrush(ByVal Color As Long) As Long
    Dim SubEditBrush As LOGBRUSH
    SubEditBrush.lbStyle = BS_SOLID
    SubEditBrush.lbHatch = 0
    SubEditBrush.lbColor = Color
    GDICreateColorBrush = CreateBrushIndirect(SubEditBrush)
End Function

' --- Set the value of page scrolling in a scrollbar --- '
Public Function ScrollBarSetPageRange(ByVal hwnd As Long, ByVal ScrollBarType As Long, ByVal PageValue As Long) As Long
    Dim ScrollInf As SCROLLINFO
    ScrollInf.cbSize = Len(ScrollInf)
    ScrollInf.fMask = SIF_PAGE
    ScrollInf.nPage = PageValue
    ScrollBarSetPageRange = SetScrollInfo(hwnd, ScrollBarType, ScrollInf, 1)
End Function

' --- Set the minimun and maximum values of a scrollbar --- '
Public Function ScrollBarSetMinMaxRange(ByVal hwnd As Long, ByVal ScrollBarType As Long, ByVal nMin As Long, ByVal nMax As Long) As Long
    If nMax = nMin Then nMax = nMin + 1
    ScrollBarSetMinMaxRange = SetScrollRange(hwnd, ScrollBarType, nMin, nMax, 1)
End Function

' --- Resize a control --- '
Public Function ControlResize(ByVal hControl As Long, ByVal CtlLeft As Long, ByVal CtlTop As Long, ByVal CtlWidth As Long, ByVal CtlHeight As Long) As Long
    ControlBound GetParent(hControl), CtlLeft, CtlTop, CtlWidth, CtlHeight
    ControlResize = MoveWindow(hControl, CtlLeft, CtlTop, CtlWidth, CtlHeight, True)
End Function

' --- Create a dumpbox control --- '
Public Function CreateDumpBox(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 hFont As Long, ByVal MaxX As Long, ByVal MaxY As Long, ByVal PageValueX As Long, ByVal PageValueY As Long, ByVal WinProc As Long, ByVal ExtraStyle As Long, ByVal ExtraExStyle As Long) As Long
    Dim ReturnValue As Long
    ControlBound hParent, LLeft, LTop, LWidth, LHeight
    ReturnValue = CreateWindowEx(ExtraExStyle, "VB2CppDumpBoxClass", "", 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, SetWindowLong(ReturnValue, GWL_WNDPROC, WinProc)
    ControlSetFont ReturnValue, hFont
    CreateDumpBox = ReturnValue
    ScrollBarSetPageRange ReturnValue, SB_HORZ, PageValueX
    ScrollBarSetPageRange ReturnValue, SB_VERT, PageValueY
    If MaxX = 0 Then MaxX = 1
    If MaxY = 0 Then MaxY = 1
    ScrollBarSetMinMaxRange ReturnValue, SB_HORZ, 0, MaxX
    ScrollBarSetMinMaxRange ReturnValue, SB_VERT, 0, MaxY
End Function

' --- Resize a dumpbox --- '
Public Sub DumpBoxResize(ByVal hwnd As Long, ByVal left As Long, ByVal top As Long, ByVal Width As Long, ByVal Height As Long)
    ControlResize hwnd, left, top, Width, Height
End Sub

' --- Scroll down a dumpbox --- '
Public Function DumpBoxScrollDown(ByVal hwnd As Long, ByVal Lines As Long, ByVal Factor As Long, ByVal Integral As Long) As Long
    Dim DumpRect As RECT
    Dim ReturnValue As Long
    DumpRect.left = 0
    DumpRect.top = 0
    DumpRect.Right = ControlClientWidth(hwnd)
    DumpRect.bottom = DumpBoxGetVisibleLines(hwnd, Factor, Integral) + 1
    ReturnValue = 0
    If DumpRect.bottom <> 0 Then
        DumpRect.bottom = DumpRect.bottom * Factor
        ReturnValue = ScrollWindow(hwnd, 0, -(Factor * Lines), 0, DumpRect)
    End If
    DumpBoxScrollDown = ReturnValue
End Function

' --- Scroll up a dumpbox --- '
Public Function DumpBoxScrollUp(ByVal hwnd As Long, ByVal Lines As Long, ByVal Factor As Long, ByVal Integral As Long) As Long
    Dim DumpRect As RECT
    Dim DumpRectClip As RECT
    Dim DumpBottom As Long
    Dim ReturnValue As Long
    DumpRect.left = 0
    DumpRect.top = 0
    DumpRectClip.left = 0
    DumpRectClip.top = 0
    DumpRect.Right = ControlClientWidth(hwnd)
    DumpRectClip.Right = DumpRect.Right
    DumpRect.bottom = DumpBoxGetVisibleLines(hwnd, Factor, Integral)
    ReturnValue = 0
    If DumpRect.bottom <> 0 Then
        DumpRect.bottom = DumpRect.bottom * Factor
        DumpRectClip.bottom = DumpRect.bottom + Factor
        If ControlClientHeight(hwnd) < DumpRectClip.bottom Then DumpRectClip.bottom = DumpRect.bottom
        ReturnValue = ScrollWindow(hwnd, 0, (Factor * Lines), 0, DumpRectClip)
    End If
    DumpBoxScrollUp = ReturnValue
End Function

' --- Retrieve the number of lines of a dumpbox --- '
Public Function DumpBoxGetVisibleLines(ByVal hwnd As Long, ByVal Factor As Long, ByVal Intregral As Long) As Long
    DumpBoxGetVisibleLines = ControlClientHeight(hwnd) \ Factor
    If Intregral = 1 Then If (ControlClientHeight(hwnd) Mod Factor) <> 0 Then DumpBoxGetVisibleLines = DumpBoxGetVisibleLines - 1
End Function

' --- Retrieve the number of columns of a dumpbox --- '
Public Function DumpBoxGetVisibleColumns(ByVal hwnd As Long, ByVal Factor As Long, ByVal Intregral As Long) As Long
    DumpBoxGetVisibleColumns = ControlClientWidth(hwnd) \ Factor
    If Intregral = 1 Then If (ControlClientWidth(hwnd) Mod Factor) <> 0 Then DumpBoxGetVisibleColumns = DumpBoxGetVisibleColumns - 1
End Function

' --- Default class hook for dumpbox controls --- '
Private Function DumpBoxClassProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim ReturnScrollValue As Long
    Select Case uMsg
        Case WM_CLOSE
            DestroyWindow hwnd