pagbitmaps.pag

很美的窗口控件,让你的系统界面接近WINDOWS界面...不信你

    lstMenus.Visible = True
    
    If lIdx < lstMenus.ListCount Then
        lstMenus.ListIndex = lIdx
    Else
        lstMenus.ListIndex = lstMenus.ListCount - 1
    End If
    lstMenus.TopIndex = lTop
    cobMenus.Clear
    For Each oCtl In m_oControl.frContainerMenus
        If Left(oCtl.Caption, 1) <> "-" Then
            cobMenus.AddItem pvGetCtlName(oCtl) & " (" & oCtl.Caption & ")"
        End If
    Next
'    If lstMenus.ListIndex >= 0 Then
'        cobMenus.Text = Split(lstMenus.Text, vbTab)(2)
'    End If
    chkDisabled.Value = IIf(m_oControl.SelectDisabled, vbChecked, vbUnchecked)
    chkSystemFont.Value = IIf(m_oControl.UseSystemFont, vbChecked, vbUnchecked)
    cobSize.Text = m_oControl.BitmapSize
    m_bInSet = False
    labNum = m_cBmps.Count & " icon(s)"
End Sub

Private Function pvGetCtlName(ByVal oCtl As Control) As String
    On Error Resume Next
    If oCtl.Index < 0 Then
        pvGetCtlName = oCtl.Name
    Else
        pvGetCtlName = oCtl.Name & ":" & oCtl.Index
    End If
End Function

Private Function pvUpload() As Boolean
    Dim vElem As Variant
    
    If m_lLoaded > 0 And Modified Then
        vElem = m_cBmps(m_lLoaded)
        m_cBmps.Remove m_lLoaded
        Set vElem(0) = imgBmp.Picture
        vElem(1) = Val("&H" & Mid(cobMaskColor.Text, 2))
        vElem(2) = "#" & Split(cobMenus.Text)(0)
        On Error Resume Next
        If m_lLoaded > m_cBmps.Count Then
            m_cBmps.Add vElem, vElem(2)
        Else
            m_cBmps.Add vElem, vElem(2), m_lLoaded
        End If
    End If
    m_oControl.SelectDisabled = (chkDisabled.Value = vbChecked)
    m_oControl.UseSystemFont = (chkSystemFont.Value = vbChecked)
    m_oControl.BitmapSize = Val(cobSize.Text)
    If Modified Then
        pvFillControls
        Modified = False
    End If
End Function

Private Sub pvCenterIcons()
    imgBmp.Move (picBmp.ScaleWidth - imgBmp.Width) \ 2, (picBmp.ScaleHeight - imgBmp.Height) \ 2
'    picBmp.Visible = False
'    picBmp.Visible = True
End Sub

Property Get Modified() As Boolean
    Modified = m_bModified
End Property

Property Let Modified(ByVal bValue As Boolean)
    m_bChanged = m_bChanged Or bValue
    m_bModified = bValue
    Changed = m_bChanged
End Property

'==============================================================================
' Control events
'==============================================================================

Private Sub chkDisabled_Click()
    If Not m_bInSet Then Modified = True
End Sub

Private Sub chkSystemFont_Click()
    If Not m_bInSet Then Modified = True
End Sub

Private Sub cmdAdd_Click()
    Dim vElem           As Variant
    Dim vSplit          As Variant
    
    If lstMenus.ListIndex >= 0 Then
        vSplit = Split(lstMenus.List(lstMenus.ListIndex), vbTab)
        If vSplit(0) = "" Then
            pvUpload
            ReDim vElem(0 To 2)
            Set vElem(0) = Nothing
            vElem(1) = &HFF00FF
            vElem(2) = "#" & vSplit(2)
            m_cBmps.Add vElem, vElem(2)
            pvFillControls
            lstMenus_Click
            Modified = True
        End If
    End If
End Sub

Private Sub cmdOpen_Click()
    On Error GoTo EH_Cancel
    comDlg.ShowOpen
    Set imgBmp = Nothing
    Set imgBmp.Picture = LoadPicture(comDlg.FileName)
    With New cMemDC
        .PaintPicture imgBmp.Picture
        cobMaskColor.Text = "#" & Hex(.GetPixel(0, .Height - 1))
    End With
    pvCenterIcons
    If Not m_bInSet Then Modified = True
EH_Cancel:
End Sub

Private Sub cmdRemove_Click()
    Dim vSplit          As Variant
    
    If lstMenus.ListIndex >= 0 Then
        vSplit = Split(lstMenus.List(lstMenus.ListIndex), vbTab)
        If vSplit(0) <> "" Then
            m_cBmps.Remove "#" & vSplit(2)
            m_lLoaded = 0
        End If
        pvFillControls
        m_lLoaded = 0
        lstMenus_Click
        Modified = True
        Changed = True
    End If
End Sub

Private Sub cobMaskColor_Change()
    If Not m_bInSet Then Modified = True
End Sub

Private Sub cobMaskColor_Click()
    If Not m_bInSet Then Modified = True
End Sub

Private Sub cobMenus_Change()
    If Not m_bInSet Then Modified = True
End Sub

Private Sub cobMenus_Click()
    If Not m_bInSet Then Modified = True
End Sub

Private Sub cobSize_Change()
    If Not m_bInSet Then Modified = True
End Sub

Private Sub cobSize_Click()
    If Not m_bInSet Then Modified = True
End Sub

Private Sub cmdClear_Click()
    Do While m_cBmps.Count > 0
        m_cBmps.Remove 1
    Loop
    m_lLoaded = 0
    pvFillControls
    lstMenus_Click
    Modified = True
End Sub

Private Sub lstMenus_Click()
    Dim vElem As Variant
        
    If m_bInSet Then
        Exit Sub
    End If
    pvUpload
    If lstMenus.ListIndex >= 0 Then
        m_lLoaded = lstMenus.itemData(lstMenus.ListIndex)
    Else
        m_lLoaded = 0
    End If
    If m_lLoaded > 0 Then
        m_bInSet = True
        fraControls.Visible = True
        vElem = m_cBmps(m_lLoaded)
        cobMenus.Text = Mid(vElem(2), 2)
        Set imgBmp.Picture = Nothing
        Set imgBmp.Picture = vElem(0)
        pvCenterIcons
        cobMaskColor.Text = "#" & Hex(vElem(1))
        m_bInSet = False
    Else
        fraControls.Visible = False
    End If
End Sub

Private Sub PropertyPage_Initialize()
    Dim aTabStop(0 To 1)    As Long
    
    cobMaskColor.AddItem "#FF00FF - Magenta"
    cobMaskColor.AddItem "#C0C0C0 - Grey"
    cobSize.AddItem "16"
    cobSize.AddItem "20"
    cobSize.AddItem "24"
    cobSize.AddItem "28"
    cobSize.AddItem "32"
    aTabStop(0) = 10
    aTabStop(1) = 120
    SendMessage lstMenus.hwnd, LB_SETTABSTOPS, 2, aTabStop(0)
End Sub

Private Sub PropertyPage_SelectionChanged()
    '--- this is the MOST bizarre way to handle it but VB freaks me out!!!
    '--- this event is raised upon EVERY mouse click on the property page
    '--- so when you are humbly selecting items in the listbox VB is alerting
    '--- that you actually changed the selected controls on the form which
    '--- is obviously not the case
    If Not m_oControl Is SelectedControls(0) Then
        m_bChanged = False
        m_lLoaded = 0
        Set m_oControl = SelectedControls(0)
        Set m_cBmps = m_oControl.frBmps
        pvFillControls
        lstMenus_Click
    Else
        '--- why is not VB remembering that values were changed
        '--- is completely beyond me!!
        Changed = m_bChanged
    End If
End Sub

Private Sub PropertyPage_ApplyChanges()
    pvUpload
    Set m_oControl.frBmps = m_cBmps
    Set m_oControl = Nothing
    '--- i never knew i had to manually clear Changed property!!!
    Changed = False
End Sub

Private Sub imgBmp_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    On Error Resume Next
    m_bDrag = True
    m_sX = X: m_sY = Y
End Sub

Private Sub imgBmp_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    On Error Resume Next
    If m_bDrag Then
        With imgBmp
            .Move .Left + (X - m_sX), .Top + (Y - m_sY)
        End With
    End If
End Sub

Private Sub imgBmp_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    On Error Resume Next
    imgBmp_MouseMove Button, Shift, X, Y
    With imgBmp
        If .Width < picBmp.ScaleWidth Then
            .Left = (picBmp.ScaleWidth - .Width) \ 2
        Else
            If .Left < picBmp.ScaleWidth - .Width Then
                .Left = picBmp.ScaleWidth - .Width
            End If
            If .Left > 0 Then
                .Left = 0
            End If
        End If
        If .Height < picBmp.ScaleHeight Then
            .Top = (picBmp.ScaleHeight - .Height) \ 2
        Else
            If .Top < picBmp.ScaleHeight - .Height Then
                .Top = picBmp.ScaleHeight - .Height
            End If
            If .Top > 0 Then
                .Top = 0
            End If
        End If
    End With
    m_bDrag = False
End Sub