mctoolbar.ctl

VB写的一个IDE开发环境,支持脚本运行,内置了一个简单的编译器,可以直接生成EXE.. 推荐下载!

    m_Appearance = PropBag.ReadProperty("Appearance", m_def_Appearance)
    m_BackColor = PropBag.ReadProperty("BackColor", m_def_BackColor)
    m_BorderStyle = PropBag.ReadProperty("BorderStyle", m_def_BorderStyle)
    m_Enabled = PropBag.ReadProperty("Enabled", m_def_Enabled)
    m_ForeColor = PropBag.ReadProperty("ForeColor", m_def_ForeColor)
    m_Button_Count = PropBag.ReadProperty("Button_Count", m_def_Button_Count)
    m_Button_Index = PropBag.ReadProperty("Button_Index", m_def_Button_Index)
    m_ButtonsWidth = PropBag.ReadProperty("ButtonsWidth", m_def_ButtonsWidth)
    m_ButtonsHeight = PropBag.ReadProperty("ButtonsHeight", m_def_ButtonsHeight)
    m_ButtonsPerRow = PropBag.ReadProperty("ButtonsPerRow", m_def_ButtonsPerRow)
    m_HoverColor = PropBag.ReadProperty("HoverColor", m_def_HoverColor)
    m_TooTipStyle = PropBag.ReadProperty("TooTipStyle", m_def_TooTipStyle)
    m_ToolTipBackCol = PropBag.ReadProperty("ToolTipBackCol", m_def_ToolTipBackCol)
    m_ToolTipForeCol = PropBag.ReadProperty("ToolTipForeCol", m_def_ToolTipForeCol)
    m_BackGradient = PropBag.ReadProperty("BackGradient", m_def_BackGradient)
    m_BackGradientCol = PropBag.ReadProperty("BackGradientCol", m_def_BackGradientCol)
    m_ButtonsStyle = PropBag.ReadProperty("ButtonsStyle", m_def_ButtonsStyle)
    m_BorderColor = PropBag.ReadProperty("BorderColor", m_def_BorderColor)
    m_HoverIconShadow = PropBag.ReadProperty("HoverIconShadow", m_def_HoverIconShadow)
    m_ButtonsSeperatorWidth = PropBag.ReadProperty("ButtonsSeperatorWidth", m_def_ButtonsSeperatorWidth)
    m_ShowSeperator = PropBag.ReadProperty("ShowSeperator", m_def_ShowSeperator)

    Set m_Font = PropBag.ReadProperty("Font", Ambient.Font)
    Set m_BackGround = PropBag.ReadProperty("BackGround", Nothing)
    
    Dim X  As Long
    ReDim m_ButtonItem(m_Button_Count - 1)
    For X = 0 To m_Button_Count - 1
        m_ButtonItem(X).TB_Caption = PropBag.ReadProperty("ButtonCaption" & X, m_def_ButtonCaption)
        Set m_ButtonItem(X).TB_Icon = PropBag.ReadProperty("ButtonIcon" & X, Nothing)
        m_ButtonItem(X).TB_ToolTipText = PropBag.ReadProperty("ButtonToolTipText" & X, vbNullString)
        m_ButtonItem(X).TB_ToolTipIcon = PropBag.ReadProperty("ButtonToolTipIcon" & X, 0)
        m_ButtonItem(X).TB_Enabled = PropBag.ReadProperty("ButtonEnabled" & X, m_def_ButtonEnabled)
        m_ButtonItem(X).TB_Pressed = PropBag.ReadProperty("ButtonPressed" & X, m_def_ButtonPressed)
        m_ButtonItem(X).TB_IconAllignment = PropBag.ReadProperty("ButtonIconAllignment" & X, m_def_ButtonIconAllignment)
        m_ButtonItem(X).TB_Type = PropBag.ReadProperty("Button_Type" & X, 0)
    Next X
    
    'debug.Print "Completed reading properties!"
    
    If Ambient.UserMode Then m_Button_Index = -1 Else m_Button_Index = 0
    InitializeSubClassing
    RedrawControl

End Sub

Private Sub UserControl_Resize()
    m_BackDrawn = False
    RedrawControl
End Sub

Private Sub UserControl_Terminate()
On Error GoTo Catch
    'Stop all subclassing
    Call Subclass_Stop(hwnd)
    Call Subclass_StopAll
    FreeLibrary m_hMode
Catch:
End Sub

'Write property values to storage
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)

    Call PropBag.WriteProperty("Appearance", m_Appearance, m_def_Appearance)
    Call PropBag.WriteProperty("BackColor", m_BackColor, m_def_BackColor)
    Call PropBag.WriteProperty("BorderStyle", m_BorderStyle, m_def_BorderStyle)
    Call PropBag.WriteProperty("Enabled", m_Enabled, m_def_Enabled)
    Call PropBag.WriteProperty("Font", m_Font, Ambient.Font)
    Call PropBag.WriteProperty("ForeColor", m_ForeColor, m_def_ForeColor)
    Call PropBag.WriteProperty("Button_Count", m_Button_Count, m_def_Button_Count)
    Call PropBag.WriteProperty("Button_Index", m_Button_Index, m_def_Button_Index)
    Call PropBag.WriteProperty("BackGround", m_BackGround, Nothing)
    Call PropBag.WriteProperty("ButtonsWidth", m_ButtonsWidth, m_def_ButtonsWidth)
    Call PropBag.WriteProperty("ButtonsHeight", m_ButtonsHeight, m_def_ButtonsHeight)
    Call PropBag.WriteProperty("ButtonsPerRow", m_ButtonsPerRow, m_def_ButtonsPerRow)
    Call PropBag.WriteProperty("HoverColor", m_HoverColor, m_def_HoverColor)
    Call PropBag.WriteProperty("TooTipStyle", m_TooTipStyle, m_def_TooTipStyle)
    Call PropBag.WriteProperty("ToolTipBackCol", m_ToolTipBackCol, m_def_ToolTipBackCol)
    Call PropBag.WriteProperty("ToolTipForeCol", m_ToolTipForeCol, m_def_ToolTipForeCol)
    Call PropBag.WriteProperty("BackGradient", m_BackGradient, m_def_BackGradient)
    Call PropBag.WriteProperty("BackGradientCol", m_BackGradientCol, m_def_BackGradientCol)
    Call PropBag.WriteProperty("ButtonsStyle", m_ButtonsStyle, m_def_ButtonsStyle)
    Call PropBag.WriteProperty("BorderColor", m_BorderColor, m_def_BorderColor)
    Call PropBag.WriteProperty("HoverIconShadow", m_HoverIconShadow, m_def_HoverIconShadow)
    Call PropBag.WriteProperty("ButtonsSeperatorWidth", m_ButtonsSeperatorWidth, m_def_ButtonsSeperatorWidth)
    Call PropBag.WriteProperty("ShowSeperator", m_ShowSeperator, m_def_ShowSeperator)

    Dim X As Long
    For X = 0 To m_Button_Count - 1
        Call PropBag.WriteProperty("ButtonCaption" & X, m_ButtonItem(X).TB_Caption, m_def_ButtonCaption)
        Call PropBag.WriteProperty("ButtonIcon" & X, m_ButtonItem(X).TB_Icon, Nothing)
        Call PropBag.WriteProperty("ButtonToolTipText" & X, m_ButtonItem(X).TB_ToolTipText, vbNullString)
        Call PropBag.WriteProperty("ButtonToolTipIcon" & X, m_ButtonItem(X).TB_ToolTipIcon, 0)
        Call PropBag.WriteProperty("ButtonEnabled" & X, m_ButtonItem(X).TB_Enabled, m_def_ButtonEnabled)
        Call PropBag.WriteProperty("ButtonPressed" & X, m_ButtonItem(X).TB_Pressed, m_def_ButtonPressed)
        Call PropBag.WriteProperty("ButtonIconAllignment" & X, m_ButtonItem(X).TB_IconAllignment, m_def_ButtonIconAllignment)
        Call PropBag.WriteProperty("Button_Type" & X, m_ButtonItem(X).TB_Type, 0)
    Next X
    
End Sub

Private Sub InitializeSubClassing()
On Error GoTo Handle
    
    ' Subclass in runtime
    If Ambient.UserMode Then
    
    bTrack = True
    bTrackUser32 = IsFunctionExported("TrackMouseEvent", "User32")
  
    If Not bTrackUser32 Then
      If Not IsFunctionExported("_TrackMouseEvent", "Comctl32") Then
        bTrack = False
      End If
    End If
    
    If Not bTrack Then Exit Sub
    
        With UserControl
            
            ' Start subclassing our calendar
            Call Subclass_Start(.hwnd)
            
            ' Adding the messages we need to track
            Call Subclass_AddMsg(.hwnd, WM_MOUSEMOVE, MSG_AFTER)
            Call Subclass_AddMsg(.hwnd, WM_MOUSELEAVE, MSG_AFTER)
            Call Subclass_AddMsg(.hwnd, WM_TIMER, MSG_AFTER)
            
        End With
    
    End If
    
Handle:
End Sub


'------------------------------------------------------------------------------------------------------------------------------------------
' Procedure : SplitToLines
' Auther    : Jim Jose
' Input     : Object, Text to split an parameters
' OutPut    : Splitted text array
' Purpose   : Split a string into lines by length!
'------------------------------------------------------------------------------------------------------------------------------------------

Private Function SplitToLines(ByVal sText As String, _
                                ByVal lLength As Long, _
                                Optional ByVal bFilterLines As Boolean = True) As String()
 Dim mArray() As String
 Dim mChar As String
 Dim mLine As String
 Dim lnCount As Long
 Dim xMax As String
 Dim mPos As Long
 Dim X As Long
 Dim lDone As Long
 Dim xStart As Long
    
    
    If bFilterLines Then sText = Replace(sText, vbNewLine, vbNullString)
    xMax = Len(sText)
    If TextWidth(sText) < lLength Then
        mLine = sText
        xStart = xMax - 1
    End If
    
    For X = xStart + 1 To xMax
    
        mChar = Mid(sText, X, 1)

        If IsDelim(mChar) Then mPos = X - (lDone + 1)
        If TextWidth(mLine & mChar) >= lLength Or X = xMax Then
            If mPos = 0 Then mPos = X - (lDone + 1)
            ReDim Preserve mArray(lnCount)
            mArray(lnCount) = RTrim(LTrim(Mid(mLine, 1, mPos)))
            mLine = Mid(mLine, mPos + 1, Len(mLine) - mPos)
            lDone = lDone + mPos: mPos = 0
            lnCount = lnCount + 1
        End If
        
        mLine = mLine & mChar
        
    Next X

    mArray(lnCount - 1) = mArray(lnCount - 1) & mChar
Complete:
    SplitToLines = mArray
    
End Function


'------------------------------------------------------------------------------------------------------------------------------------------
' Procedure : IsDelim
' Auther    : Rde
' Input     : Char
' OutPut    : IsDelim?
' Purpose   : Check if the input char is a Delimiter or not!
'------------------------------------------------------------------------------------------------------------------------------------------

Private Function IsDelim(Char As String) As Boolean
    Select Case Asc(Char) ' Upper/Lowercase letters,Underscore Not delimiters
    Case 65 To 90, 95, 97 To 122
        IsDelim = False
    Case Else: IsDelim = True ' Another Character Is delimiter
    End Select
End Function


'------------------------------------------------------------------------------------------
' Procedure  : IsThere
' Auther     : Jim Jose
' Input      : None
' OutPut     : None
' Purpose    : To check if the Picture is loaded
'------------------------------------------------------------------------------------------

Private Function IsThere(vPicture As StdPicture) As Boolean
On Error GoTo Handle
     IsThere = Not vPicture Is Nothing
Handle:
End Function


'------------------------------------------------------------------------------------------------------------------------------------------
' Procedure : IsNT
' Auther    : Dana Seaman
' Input     : None
' OutPut    : NT?
' Purpose   : Check for the NT Platform
'------------------------------------------------------------------------------------------------------------------------------------------

Private Function IsNT() As Boolean

  Dim udtVer     As OSVERSIONINFO
  On Error Resume Next
    udtVer.dwOSVersionInfoSize = Len(udtVer)
    If GetVersionEx(udtVer) Then
      m_bIsNT = udtVer.dwPlatformId = VER_PLATFORM_WIN32_NT
    End If
  On Error GoTo 0
   
End Function

' -------------------------------------------------------------------------------------
' Procedure : BlendColor
' Type      : Property
' DateTime  : 03/02/2005
' Author    : Gary Noble [ Modified by CodeFixer4! ]
' Purpose   : Blends Two Colours Together
' Returns   : Long
' -------------------------------------------------------------------------------------

Private Function BlendColor(ByVal oColorFrom As OLE_COLOR, _
                               ByVal oColorTo As OLE_COLOR, _
                               Optional ByVal Alpha As Long = 128) As Long
Dim lCFrom As Long
Dim lCTo   As Long
    lCFrom = TranslateColor(oColorFrom)
    lCTo = TranslateColor(oColorTo)
    BlendColor = RGB((((lCFrom And &HFF) * Alpha) / 255) + (((lCTo And &HFF) * (255 - Alpha)) / 255), ((((lCFrom And &HFF00&) \ &H100&) * Alpha) / 255) + ((((lCTo And &HFF00&) \ &H100&) * (255 - Alpha)) / 255), ((((lCFrom And &HFF0000) \ &H10000) * Alpha) / 255) + ((((lCTo And &HFF0000) \ &H10000) * (255 - Alpha)) / 255))

End Function

' -------------------------------------------------------------------------------------
' Procedure : TranslateColor
' Type      : Function
' DateTime  : 03/02/2005
' Author    : Roger
' Purpose   : Convert Automation color to Windows color
' Returns   : Long
' -------------------------------------------------------------------------------------

Private Function TranslateColor(ByVal oClr As OLE_COLOR, _
                               Optional hPal As Long = 0) As Long

    OleTranslateColor oClr, hPal, TranslateColor

End Function


'[Important. If not included, tooltips don't change when you try to set the toltip text]
Private Sub RemoveToolTip()
   Dim lR As Long
   If m_ToolTipHwnd <> 0 Then
      lR = SendMessage(m_ToolTipInfo.lhWnd, TTM_DELTOOLW, 0, m_ToolTipInfo)
      DestroyWindow m_ToolTipHwnd
      m_ToolTipHwnd = 0
   End If
End Sub

'-------------------------------------------------------------------------------------------------------------------------
' Procedure : CreateToolTip
' Auther    : Fred.cpp
' Modified  : Jim Jose
' Upgraded  : Dana Seaman, for unicode support
' Purpose   : Simple and efficient tooltip generation with baloon style
'-------------------------------------------------------------------------------------------------------------------------

Private Sub CreateToolTip()
Dim lpRect As RECT
Dim lWinStyle As Long

    'Remove previous ToolTip
    RemoveToolTip
    
    If m_Button_Index = -1 Then Exit Sub
    If m_ButtonItem(m_Button_Index).TB_ToolTipText = vbNullString Then Exit Sub
    'debug.Print "Creating new Tooltip!"

    ''create baloon style if desired
    If m_TooTipStyle = Tip_Normal Then
        lWinStyle = TTS_ALWAYSTIP Or TTS_NOPREFIX
    Else
        lWinStyle = TTS_ALWAYSTIP Or TTS_NOPREFIX Or TTS_BALLOON
    End If
        
    m_ToolTipHwnd = CreateWindowEx(0&, _
                TOOLTIPS_CLASSA, _
                vbNullString, _
                lWinStyle, _
                CW_USEDEFAULT, _
                CW_USEDEFAULT, _
                CW_USEDEFAULT, _
                CW_USEDEFAULT, _
                hwnd, _
                0&, _
                App.hInstance, _
                0&)
                
    ''make our tooltip window a topmost window
    SetWindowPos m_ToolTipHwnd, _
        HWND_TOPMOST, _
        0&, _
        0&, _
        0&, _
        0&, _
        SWP_NOACTIVATE Or SWP_NOSIZE Or SWP_NOMOVE
    
    ''get the rect of the parent control
    GetClientRect hwnd, lpRect
    
    ''now set our tooltip info structure
    With m_ToolTipInfo
        .lSize = Len(m_ToolTipInfo)
        .lFlags = TTF_SUBCLASS
        .lhWnd = hwnd
        .lID = 0
        .hInstance = App.hInstance