├── .gitignore ├── cIME.cls ├── cLayoutBand.cls ├── cLayoutCell.cls ├── cLayoutVertical.cls ├── cQRDecode.cls ├── cQREncode.cls ├── cThemeWin7.cls ├── cUndoRedo.cls ├── cfPopUp.cls ├── cwAccordeon.cls ├── cwAccordeonEntry.cls ├── cwBrowser.cls ├── cwButton.cls ├── cwDirList.cls ├── cwDropDown.cls ├── cwDropDownList.cls ├── cwFileList.cls ├── cwFormButtons.cls ├── cwFrame.cls ├── cwGlowButton.cls ├── cwGrid.cls ├── cwHScrollBar.cls ├── cwImage.cls ├── cwLabel.cls ├── cwLabeledTextBox.cls ├── cwMDIMock.cls ├── cwMenu.cls ├── cwMenuBar.cls ├── cwMenuBarItem.cls ├── cwMenuItem.cls ├── cwProgressBar.cls ├── cwResizer.cls ├── cwRibbon.cls ├── cwRibbonEntry.cls ├── cwScoringLabel.cls ├── cwScrollBar.cls ├── cwStatusBar.cls ├── cwTextBox.cls ├── cwToolBar.cls ├── cwToolBarItem.cls ├── cwTree.cls ├── cwUpDown.cls ├── cwVList.cls ├── cwVListOld.cls ├── cwVScrollBar.cls ├── modWidgets.bas ├── vbWidgets.dll └── vbWidgets.vbp /.gitignore: -------------------------------------------------------------------------------- 1 | *.exp 2 | *.lib 3 | *.vbw 4 | /*.dll 5 | /*.bak 6 | -------------------------------------------------------------------------------- /cIME.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "cIME" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Option Explicit 15 | 16 | Event HandleIMEPositioning(FocusedWidget As cWidgetBase, AllowIME As Boolean) 17 | Event HandleIMEChar(FocusedWidget As cWidgetBase, ByVal IMEKeyCode As Integer, IMEWChar As String) 18 | 19 | Private Type POINTAPI 20 | x As Long 21 | y As Long 22 | End Type 23 | 24 | Private Type RECT 25 | Left As Long 26 | Top As Long 27 | Right As Long 28 | Bottom As Long 29 | End Type 30 | 31 | Private Type COMPOSITIONFORM 32 | dwStyle As Long 33 | ptCurrentPos As POINTAPI 34 | rcArea As RECT 35 | End Type 36 | 37 | Private Declare Function ImmAssociateContextEx Lib "imm32" (ByVal hWnd As Long, ByVal hIMC As Long, ByVal dwFlags As Long) As Long 38 | Private Declare Function ImmGetContext Lib "imm32" (ByVal hWnd As Long) As Long 39 | Private Declare Function ImmReleaseContext Lib "imm32" (ByVal hWnd As Long, ByVal hIMC As Long) As Long 40 | Private Declare Function ImmSetOpenStatus Lib "imm32" (ByVal hIMC As Long, ByVal B As Long) As Long 41 | Private Declare Function ImmGetOpenStatus Lib "imm32" (ByVal hIMC As Long) As Long 42 | Private Declare Function ImmSetCompositionWindow Lib "imm32" (ByVal hIMC As Long, lpCompositionForm As COMPOSITIONFORM) As Long 43 | Private Declare Function ImmGetCompositionStringW Lib "imm32" (ByVal hIMC As Long, ByVal Flags As Long, ByVal pStr As Long, ByVal SLen As Long) As Long 44 | Private Declare Function ImmGetDefaultIMEWnd Lib "imm32" (ByVal hWnd As Long) As Long 45 | 46 | Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal dx As Long, ByVal dy As Long, ByVal Flags As Long) As Long 47 | 48 | Private hWnd As Long, WithEvents SC As cSubClass, WithEvents tmrFoc As cTimer 49 | Attribute SC.VB_VarHelpID = -1 50 | Attribute tmrFoc.VB_VarHelpID = -1 51 | 52 | Public Sub BindToForm(Form As cWidgetForm) 53 | hWnd = Form.hWnd 54 | Set SC = New_c.SubClass 55 | SC.Hook hWnd 56 | Set tmrFoc = New_c.Timer(30, True, "") 57 | End Sub 58 | 59 | Public Sub SwitchOpenStatus(ByVal bOpen As Boolean) 60 | Dim hIMC As Long 61 | hIMC = ImmGetContext(hWnd): If hIMC = 0 Then Exit Sub 62 | If ImmGetOpenStatus(hIMC) <> IIf(bOpen, 1, 0) Then ImmSetOpenStatus hIMC, IIf(bOpen, 1, 0) 63 | ImmReleaseContext hWnd, hIMC 64 | End Sub 65 | 66 | Public Sub SetPosition(ByVal x As Long, ByVal y As Long) 67 | Const CFS_POINT = 2, CFS_FORCE_POSITION = &H20 68 | Dim hIMC As Long, CF As COMPOSITIONFORM 69 | hIMC = ImmGetContext(hWnd): If hIMC = 0 Then Exit Sub 70 | CF.dwStyle = CFS_FORCE_POSITION 71 | CF.ptCurrentPos.x = x 72 | CF.ptCurrentPos.y = y 73 | ImmSetCompositionWindow hIMC, CF 74 | ImmReleaseContext hWnd, hIMC 75 | End Sub 76 | 77 | Public Function GetCompositionString() As String 78 | Const GCS_COMPSTR = 8 79 | Dim hIMC As Long, SLen As Long 80 | hIMC = ImmGetContext(hWnd): If hIMC = 0 Then Exit Function 81 | SLen = ImmGetCompositionStringW(hIMC, GCS_COMPSTR, 0, 0) \ 2 82 | GetCompositionString = Space$(SLen) 83 | ImmGetCompositionStringW hIMC, GCS_COMPSTR, StrPtr(GetCompositionString), LenB(GetCompositionString) 84 | ImmReleaseContext hWnd, hIMC 85 | End Function 86 | 87 | Private Sub SC_WindowProc(Result As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) 88 | Const WM_IME_SETCONTEXT = 641, WM_IME_STARTCOMPOSITION = 269, WM_IME_CHAR = 646 89 | On Error GoTo 1 90 | 91 | Select Case Msg 92 | Case WM_IME_SETCONTEXT 93 | SwitchOpenStatus wParam 94 | 95 | Case WM_IME_STARTCOMPOSITION 96 | HandleIMEPos 97 | 98 | Case WM_IME_CHAR 99 | Dim WFoc As cWidgetBase, KeyCode As Integer 100 | Set WFoc = FocusedWidget: KeyCode = CInt("&H" & Hex(wParam And &HFFFF&)) 101 | If Not WFoc Is Nothing Then If WFoc.Key = tmrFoc.Tag Then RaiseEvent HandleIMEChar(WFoc, KeyCode, ChrW(KeyCode)) 102 | Exit Sub 'handled ourselves - so we skip the default message-handler at the end of this function. 103 | End Select 104 | 105 | 1: Result = SC.CallWindowProc(Msg, wParam, lParam) 106 | End Sub 107 | 108 | Private Sub tmrFoc_Timer() 109 | HandleIMEPos 110 | End Sub 111 | 112 | Private Function FocusedWidget() As cWidgetBase 113 | If Cairo.WidgetForms.Exists(hWnd) Then Set FocusedWidget = Cairo.WidgetForms(hWnd).WidgetRoot.ActiveWidget 114 | End Function 115 | 116 | Private Sub HandleIMEPos() 117 | Dim WFoc As cWidgetBase, AllowIME As Boolean 118 | On Error GoTo 1 119 | 120 | Set WFoc = FocusedWidget 121 | If WFoc Is Nothing Then 122 | tmrFoc.Tag = "" 123 | Else 124 | RaiseEvent HandleIMEPositioning(WFoc, AllowIME) 125 | If AllowIME Then tmrFoc.Tag = WFoc.Key 126 | End If 127 | 128 | 1: SwitchOpenStatus AllowIME 129 | End Sub 130 | 131 | Private Sub Class_Terminate() 132 | Set tmrFoc = Nothing 133 | Set SC = Nothing 134 | SwitchOpenStatus False 135 | End Sub 136 | 137 | -------------------------------------------------------------------------------- /cLayoutBand.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "cLayoutBand" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = False 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Option Explicit 15 | 16 | Private mParent As cWidgetForm, mCells As New Collection, mBandIndex As Long 17 | 18 | Friend Sub Init(Parent As cWidgetForm, CellWidths(), ByVal BandIndex As Long) 19 | Dim NewCell As cLayoutCell, i As Long 20 | Set mParent = Parent 21 | mBandIndex = BandIndex 22 | Set mCells = Nothing 23 | For i = 0 To UBound(CellWidths) 24 | Set NewCell = New cLayoutCell: NewCell.Init mParent, CellWidths(i), mBandIndex, mCells.Count 25 | mCells.Add NewCell 26 | Next 27 | End Sub 28 | 29 | Public Function CellCount() As Long 30 | CellCount = mCells.Count 31 | End Function 32 | 33 | Public Function Cell(ByVal IndexZeroBased As Long) As cLayoutCell 34 | Set Cell = mCells(IndexZeroBased + 1) 35 | End Function 36 | 37 | Public Sub ResizeWith(ByVal xOffs As Single, yOffs As Single, ByVal Width As Single) 38 | Dim Cell As cLayoutCell, AbsWidth As Single, PercSum As Single, PercFac As Single, y As Single, yMax As Single 39 | 40 | For Each Cell In mCells 41 | If Cell.Width > 1 Then AbsWidth = AbsWidth + Cell.Width Else PercSum = PercSum + Cell.Width 42 | Next 43 | 44 | Width = Width - AbsWidth 45 | If Width > 0 And PercSum > 0 Then PercFac = Width / IIf(CellCount = 1, 1, PercSum) Else PercFac = 1 46 | For Each Cell In mCells 47 | y = yOffs 48 | Cell.ResizeWith xOffs, y, Cell.Width * IIf(Cell.Width > 1, 1, PercFac) 49 | If y > yMax Then yMax = y 50 | Next 51 | yOffs = yMax 52 | End Sub 53 | -------------------------------------------------------------------------------- /cLayoutCell.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "cLayoutCell" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = False 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Option Explicit 15 | 16 | Public MarginLeft, MarginTop, MarginRight, MarginBottom, MarginBetweenWidgets 17 | 18 | Private mParent As cWidgetForm, mWidth!, mBandIndex&, mColIndex&, mWidgets As New Collection, mGroup As cwFrame 19 | 20 | Friend Sub Init(Parent As cWidgetForm, ByVal Width As Single, ByVal BandIndex As Long, ByVal ColIndex As Long) 21 | Set mParent = Parent 22 | mWidth = Width 23 | mBandIndex = BandIndex 24 | mColIndex = ColIndex 25 | MarginLeft = 5: MarginTop = 5: MarginRight = 5: MarginBottom = 5: MarginBetweenWidgets = 5 26 | End Sub 27 | 28 | Public Property Get Width() As Single 29 | Width = mWidth 30 | End Property 31 | 32 | Public Sub ResizeWith(xOffs As Single, yOffs As Single, ByVal Width As Single) 33 | Dim W As cWidgetBase, dx As Single, dy As Single, MaxLabelWidth As Single 34 | 35 | For Each W In mWidgets 36 | If TypeOf W.object Is cwLabeledTextBox Then 37 | If W.object.CaptionWidth > MaxLabelWidth Then MaxLabelWidth = W.object.CaptionWidth 38 | End If 39 | Next 40 | MaxLabelWidth = MaxLabelWidth + 5 41 | 42 | dx = Width - MarginLeft - MarginRight: If dx < 1 Then dx = 1 43 | yOffs = yOffs + MarginTop 44 | For Each W In mWidgets 45 | If TypeOf W.object Is cwGrid Then dy = W.Height Else dy = 24 46 | If TypeOf W.object Is cwLabeledTextBox Then W.object.LabelWidthPercent = MaxLabelWidth / dx 47 | If TypeOf W.object Is cwFrame Then dy = ResizeInGroup(W, MarginTop + 5, dx) 48 | If TypeOf W.object Is cwImage Then dy = W.object.CanvasHeight * dx / W.object.CanvasWidth 49 | W.Move xOffs + MarginLeft, yOffs, dx, dy 50 | yOffs = yOffs + dy + MarginBetweenWidgets 51 | Next 52 | yOffs = yOffs + MarginBottom 53 | xOffs = xOffs + Width 54 | End Sub 55 | 56 | Private Function ResizeInGroup(WG As cWidgetBase, ByVal yOffs As Single, ByVal Width As Single) As Single 57 | Dim WO As Object, W As cWidgetBase, xOffs As Single, dx As Single, dy As Single, MaxLabelWidth As Single 58 | 59 | For Each WO In WG.Widgets 60 | If TypeOf WO Is cwLabeledTextBox Then 61 | If WO.CaptionWidth > MaxLabelWidth Then MaxLabelWidth = WO.CaptionWidth 62 | End If 63 | Next 64 | MaxLabelWidth = MaxLabelWidth + 5 65 | If WG.Tag = "V" Then 66 | For Each WO In WG.Widgets: Set W = WO.Widget 67 | If TypeOf WO Is cwGrid Then dy = W.Height Else dy = 24 68 | If TypeOf WO Is cwLabeledTextBox Then WO.LabelWidthPercent = MaxLabelWidth / (Width - MarginLeft - MarginRight) 69 | 70 | W.Move MarginLeft, yOffs, Width - MarginLeft - MarginRight, dy 71 | yOffs = yOffs + dy + MarginBetweenWidgets 72 | Next 73 | ElseIf WG.Widgets.Count Then 74 | dy = WG.Widgets(1).Widget.Height: If dy < 24 Then dy = 24 75 | dx = Int((Width - MarginLeft - MarginRight - (WG.Widgets.Count - 1) * MarginBetweenWidgets) / WG.Widgets.Count) 76 | xOffs = MarginLeft 77 | For Each WO In WG.Widgets: Set W = WO.Widget 78 | W.Move xOffs, yOffs, dx, dy: xOffs = xOffs + dx + MarginBetweenWidgets 79 | Next 80 | yOffs = yOffs + dy + MarginBetweenWidgets 81 | End If 82 | ResizeInGroup = yOffs + MarginBottom + 5 83 | End Function 84 | 85 | Public Function BeginGroupVertical(ByVal Caption As String) As cWidgetBase 86 | Set mGroup = mParent.Widgets.Add(New cwFrame, GetKey) 87 | mGroup.Caption = Caption 88 | mGroup.Widget.Tag = "V" 89 | mWidgets.Add mGroup.Widget 90 | Set BeginGroupVertical = mGroup.Widget 91 | End Function 92 | Public Function BeginGroupHorizontal(ByVal Caption As String) As cWidgetBase 93 | Set mGroup = mParent.Widgets.Add(New cwFrame, GetKey) 94 | mGroup.Caption = Caption 95 | mGroup.Widget.Tag = "H" 96 | mWidgets.Add mGroup.Widget 97 | Set BeginGroupHorizontal = mGroup.Widget 98 | End Function 99 | Public Sub EndGroup() 100 | Set mGroup = Nothing 101 | End Sub 102 | 103 | Public Function AddLabeledTextBox(ByVal Caption As String, Optional ByVal Alignment As AlignmentConstants = vbRightJustify) As cwLabeledTextBox 104 | Set AddLabeledTextBox = mParent.Widgets.Add(New cwLabeledTextBox, GetKey) 105 | AddLabeledTextBox.Caption = Caption 106 | AddLabeledTextBox.Alignment = Alignment 107 | mWidgets.Add AddLabeledTextBox.Widget 108 | End Function 109 | 110 | Public Function AddButton(ByVal Caption As String) As cwButton 111 | Set AddButton = mParent.Widgets.Add(New cwButton, GetKey) 112 | AddButton.Caption = Caption 113 | mWidgets.Add AddButton.Widget 114 | End Function 115 | 116 | Public Function AddCheckBox(ByVal Caption As String, Optional ByVal Value As Long) As cwButton 117 | Set AddCheckBox = mParent.Widgets.Add(New cwButton, GetKey) 118 | AddCheckBox.ButtonStyle = CheckBox 119 | AddCheckBox.Caption = Caption 120 | AddCheckBox.Value = Value 121 | mWidgets.Add AddCheckBox.Widget 122 | End Function 123 | 124 | Public Function AddOptionBox(ByVal Caption As String, Optional ByVal Value As Boolean) As cwButton 125 | Set AddOptionBox = IIf(mGroup Is Nothing, mParent, mGroup).Widgets.Add(New cwButton, GetKey) 126 | AddOptionBox.ButtonStyle = OptionBox 127 | AddOptionBox.Caption = Caption 128 | AddOptionBox.Value = Value 129 | AddOptionBox.OptionGroupKey = "VLayout_OptGrp_" & mBandIndex & "_" & mColIndex 130 | If mGroup Is Nothing Then mWidgets.Add AddOptionBox.Widget 131 | End Function 132 | 133 | Public Function AddDataGrid(ByVal Caption As String, ByVal DataSource As cDataSource, Optional ByVal DGHeightPxl As Single = 280) As cwGrid 134 | Set AddDataGrid = IIf(mGroup Is Nothing, mParent, mGroup).Widgets.Add(New cwGrid, GetKey, , , 1, DGHeightPxl) 135 | Set AddDataGrid.DataSource = DataSource 136 | AddDataGrid.Widget.Tag = Caption 137 | If DataSource.Col Is Nothing Then 138 | If DataSource.Rs.Fields(0).PrimaryKey = True Then AddDataGrid.ColumnWidth(0) = 0 139 | Else 140 | 'AddDataGrid.ColumnWidth(1) = 0 'hide the Value-Column (only show Key) 141 | End If 142 | If DataSource.RecordCount Then DataSource.MoveFirst 143 | If mGroup Is Nothing Then mWidgets.Add AddDataGrid.Widget 144 | End Function 145 | 146 | Public Function AddImageBox(ByVal Caption As String, ByVal ImageKey As String, Optional ByVal Width& = 256, Optional ByVal Height& = 256) As cwImage 147 | Set AddImageBox = IIf(mGroup Is Nothing, mParent, mGroup).Widgets.Add(New cwImage, GetKey) 148 | AddImageBox.Widget.Tag = Caption 149 | AddImageBox.Widget.ImageKey = ImageKey 150 | AddImageBox.SetCanvasSize Width, Height 151 | If mGroup Is Nothing Then mWidgets.Add AddImageBox.Widget 152 | End Function 153 | 154 | Private Function GetKey() As String 155 | Static ID As Long 156 | GetKey = "Band " & mBandIndex & ", Col " & mColIndex & ", " & ID 157 | ID = ID + 1 158 | End Function 159 | 160 | -------------------------------------------------------------------------------- /cLayoutVertical.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "cLayoutVertical" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Option Explicit 15 | 16 | Private Const enPrefix As String = "", enSuffix As String = "" 17 | 18 | Public SpeechSupport As Boolean, MarginLeft, MarginTop, MarginRight, MarginBottom 19 | 20 | Private WithEvents mParent As cWidgetForm, WithEvents tmrSpeech As cTimer 21 | Attribute mParent.VB_VarHelpID = -1 22 | Attribute tmrSpeech.VB_VarHelpID = -1 23 | Private mBands As New Collection, mAutoAdjustFormHeight As Boolean, mMinWidth As Long 24 | 25 | Public Sub AttachTo(ByVal Parent As cWidgetForm, Optional ByVal AutoAdjustFormHeight As Boolean, Optional ByVal OtherVoice As Object) 26 | Set mParent = Parent 27 | If Not OtherVoice Is Nothing Then Set Voice = OtherVoice 28 | mAutoAdjustFormHeight = AutoAdjustFormHeight 29 | mMinWidth = mParent.Width 30 | MarginLeft = 5: MarginTop = 5: MarginRight = 5: MarginBottom = 5 31 | Set tmrSpeech = New_c.Timer(500) 32 | End Sub 33 | 34 | Public Function BandCount() As Long 35 | BandCount = mBands.Count 36 | End Function 37 | 38 | Public Function Band(ByVal IndexZeroBased As Long) As cLayoutBand 39 | Set Band = mBands(IndexZeroBased + 1) 40 | End Function 41 | 42 | Public Function AddBandWithCells(ParamArray CellWidths()) As cLayoutBand 43 | If mParent Is Nothing Then Exit Function 44 | Dim TmpCellWidths(): TmpCellWidths = CellWidths 'copy the Param-Array 45 | If UBound(TmpCellWidths) = -1 Then ReDim TmpCellWidths(0 To 0): TmpCellWidths(0) = 1 46 | Set AddBandWithCells = New cLayoutBand 47 | AddBandWithCells.Init mParent, TmpCellWidths, mBands.Count 48 | mBands.Add AddBandWithCells 49 | End Function 50 | 51 | Public Sub Message(Msg, Optional ByVal LangID As Long) 52 | If SpeechSupport Then Speak IIf(LangID, "" & Msg & "", Msg) Else VBA.MsgBox Msg, vbInformation 53 | End Sub 54 | 55 | Public Sub Resize(Optional ByVal NewWidth As Long, Optional ByVal NewHeight As Long) 56 | If mParent Is Nothing Then Exit Sub 57 | Dim Band As cLayoutBand, yOffs As Single 58 | If NewWidth = 0 Then NewWidth = mParent.ScaleWidth 59 | If NewHeight = 0 Then NewHeight = mParent.ScaleHeight 60 | 61 | mParent.Locked = True 62 | yOffs = MarginTop 63 | For Each Band In mBands 64 | Band.ResizeWith MarginLeft, yOffs, NewWidth / mParent.WidgetRoot.Zoom - MarginLeft - MarginRight 65 | Next 66 | If mAutoAdjustFormHeight Then 67 | NewHeight = yOffs * mParent.WidgetRoot.Zoom + mParent.Height - mParent.ScaleHeight 68 | mParent.SetMinMaxDimensions mMinWidth, NewHeight 69 | If mParent.Height < NewHeight Then mParent.Move mParent.Left, mParent.Top, NewWidth, NewHeight 70 | End If 71 | mParent.Locked = False 72 | End Sub 73 | 74 | Private Sub mParent_BubblingEvent(Sender As Object, EventName As String, P1 As Variant, P2 As Variant, P3 As Variant, P4 As Variant, P5 As Variant, P6 As Variant, P7 As Variant) 75 | If SpeechSupport = False Then Exit Sub 76 | On Error Resume Next 77 | 78 | Select Case EventName 79 | Case "W_GotFocus" 80 | SpeakDelayed GetControlInfo(Sender) 81 | Case "Change" 82 | If TypeOf Sender Is cwLabeledTextBox Then SpeakDelayed enPrefix & ", change: " & enSuffix & Sender.Text 83 | Case "SelChanged" 84 | If TypeOf Sender Is cwLabeledTextBox Then SpeakDelayed enPrefix & ", position-change: " & enSuffix & Mid$(Sender.Text, Sender.SelStart + 1, IIf(Sender.SelLength, Sender.SelLength, 100)) 85 | Case "Click" 86 | If TypeOf Sender Is cwButton Then If Sender.ButtonStyle > 1 Then SpeakDelayed enPrefix & ", change: " & IIf(Sender.ButtonStyle < 4, Sender.Value, IIf(Sender.Value, "true", "false")) & enSuffix 87 | Case "DataSourceAddNew" 88 | If TypeOf Sender Is cwGrid Then Sender.Widget.ToolTip = "- after add-new " 89 | Case "DataSourceDelete" 90 | If TypeOf Sender Is cwGrid Then Sender.Widget.ToolTip = "- after delete " 91 | Case "DataSourcePositionChanged" 92 | If TypeOf Sender Is cwGrid Then SpeakDelayed enPrefix & ", grid-position change, " & Sender.Widget.ToolTip & ": " & GetRowInfo(Sender.DataSource): Sender.Widget.ToolTip = "" 93 | End Select 94 | End Sub 95 | 96 | Private Function GetControlInfo(Sender As Object) As String 97 | Dim Name As String 98 | On Error Resume Next 99 | Name = Sender.Caption 100 | If Len(Name) = 0 Then Name = Sender.Widget.Tag 101 | If Len(Name) = 0 Then Name = Sender.Widget.Key 102 | Name = Replace(Name, "&", "") 103 | If TypeOf Sender Is cwButton Then 104 | Select Case Sender.ButtonStyle 105 | Case 0: GetControlInfo = enPrefix & "Buttton" & enSuffix & Name 'Button deliberately written this way (correctly written it sounded terrible on my machine) 106 | Case 1: GetControlInfo = enPrefix & "ToolButtton" & enSuffix & Name 'ToolButtton deliberately written this way (correctly written it sounded not nice on my machine) 107 | Case 2, 3: GetControlInfo = enPrefix & "CheckBox" & enSuffix & Name & enPrefix & "value: " & Sender.Value & enSuffix 108 | Case 4, 5: GetControlInfo = enPrefix & "OptionBox" & enSuffix & Name & enPrefix & "value: " & IIf(Sender.Value, "true", "false") & enSuffix 109 | End Select 110 | ElseIf TypeOf Sender Is cwGrid Then 111 | GetControlInfo = enPrefix & "Grid" & enSuffix & Name & enPrefix & ", " & GetRowInfo(Sender.DataSource) 112 | ElseIf TypeOf Sender Is cwTextBox Then 113 | GetControlInfo = enPrefix & "TextBox" & enSuffix & Name & enPrefix & IIf(Len(Sender.Text), "contains: " & enSuffix & Sender.Text, enSuffix) 114 | Else 115 | GetControlInfo = enPrefix & Mid$(TypeName(Sender), 3) & enSuffix & Name 116 | End If 117 | End Function 118 | 119 | Private Function GetRowInfo(DS As cDataSource, Optional ByVal i As Long) As String 120 | If DS Is Nothing Then Exit Function 121 | If DS.AbsolutePosition < 1 And DS.RecordCount > 0 Then Exit Function 122 | If DS.RecordCount = 0 Then 123 | GetRowInfo = "no records in grid" & enSuffix 124 | Else 125 | With New_c.StringBuilder 126 | .Append enSuffix 127 | For i = 0 To DS.FieldCount - 1 128 | .Append DS.FieldName(i) & ":" 129 | Select Case VarType(DS.FieldValue(i)) 130 | Case vbEmpty: .Append "Null:" 131 | Case vbByte Or vbArray: .Append "Byte-Array:" 132 | Case Else: .Append DS.FieldValue(i) & ":" 133 | End Select 134 | Next 135 | GetRowInfo = .ToString 136 | End With 137 | End If 138 | End Function 139 | 140 | Private Sub SpeakDelayed(ByVal Text As String) 141 | Speak "" 142 | tmrSpeech.Enabled = False 143 | tmrSpeech.Enabled = True 144 | tmrSpeech.Tag = Text 145 | End Sub 146 | 147 | Private Sub mParent_ResizeWithDimensions(ByVal NewWidth As Long, ByVal NewHeight As Long) 148 | Resize NewWidth, NewHeight 149 | End Sub 150 | 151 | Private Sub tmrSpeech_Timer() 152 | tmrSpeech.Enabled = False 153 | Speak tmrSpeech.Tag 154 | End Sub 155 | -------------------------------------------------------------------------------- /cQRDecode.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "cQRDecode" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Option Explicit 15 | 16 | 'a simple Binding for the nice Quirc-project of Daniel Beer (https://github.com/dlbeer/quirc) - 17 | 'the lib comes under a liberal license, which also allows commercial usage... 18 | 'I've compiled it into the latest release of vb_cairo_sqlite.dll in a VB-friendly StdCall-version 19 | 'Aside from vb_cairo_sqlite, this Class has no other (Code)Module-dependencies (Olaf Schmidt, Jan. 2015) 20 | 21 | Private Const QUIRC_MAX_BITMAP& = 3917 22 | Private Const QUIRC_MAX_PAYLOAD& = 8896 23 | 24 | Private Type tQUIRC_POINT 25 | x As Long 26 | y As Long 27 | End Type 28 | 29 | Private Type tQUIRC_CODE 30 | Corners(0 To 3) As tQUIRC_POINT ' The four corners of the QR-code, from top left, clockwise 31 | 32 | ' The number of cells across in the QR-code. The cell bitmap is a bitmask giving the actual values of cells. 33 | ' If the cell at (x, y) is black, then the following bit is set: CellBitmap(i * 8) AND (1 * 2 ^ (i AND 7)) 34 | 35 | Size As Long ' <- where i = (y * size) + x 36 | CellBitmap(0 To QUIRC_MAX_BITMAP - 1) As Byte 37 | End Type 38 | 39 | Private Type tQUIRC_DATA 40 | Version As Long 41 | EccLevel As eQUIRC_ECC_LEVEL 42 | Mask As Long 43 | DataType As QUIRC_DATA_TYPE 'the highest-valued data type found in the QR code. 44 | Data(0 To QUIRC_MAX_PAYLOAD - 1) As Byte 45 | DataLen As Long 46 | End Type 47 | 48 | Private Enum eQUIRC_DECODE_ERROR 49 | QUIRC_SUCCESS 50 | QUIRC_ERROR_INVALID_GRID_SIZE 51 | QUIRC_ERROR_INVALID_VERSION 52 | QUIRC_ERROR_FORMAT_ECC 53 | QUIRC_ERROR_DATA_ECC 54 | QUIRC_ERROR_UNKNOWN_DATA_TYPE 55 | QUIRC_ERROR_DATA_OVERFLOW 56 | QUIRC_ERROR_DATA_UNDERFLOW 57 | End Enum 58 | 59 | Public Enum eQUIRC_ECC_LEVEL 60 | QUIRC_ECC_LEVEL_M 61 | QUIRC_ECC_LEVEL_L 62 | QUIRC_ECC_LEVEL_H 63 | QUIRC_ECC_LEVEL_Q 64 | End Enum 65 | 66 | Public Enum QUIRC_DATA_TYPE 67 | QUIRC_DATA_TYPE_NUMERIC = 1 68 | QUIRC_DATA_TYPE_ALPHA = 2 69 | QUIRC_DATA_TYPE_BYTE = 4 70 | QUIRC_DATA_TYPE_KANJI = 8 71 | End Enum 72 | 73 | ' Retrieve an initialized QR-code recognizer. 74 | Private Declare Function quirc_new Lib "vb_cairo_sqlite" () As Long 75 | 76 | ' Resize the QR-code recognizer. The size of an image must be specified before codes can be analyzed. 77 | ' This function returns 0 on success, or -1 if sufficient memory could not be allocated. 78 | Private Declare Function quirc_resize Lib "vb_cairo_sqlite" (ByVal hQ As Long, ByVal Width As Long, ByVal Height As Long) As Long 79 | 80 | ' quirc_begin() must first be called to obtain access to a buffer into which the input image should be placed. 81 | ' Optionally, the current width and height may be returned. 82 | Private Declare Function quirc_begin Lib "vb_cairo_sqlite" (ByVal hQ As Long, Optional Width As Long, Optional Height As Long) As Long 83 | 84 | ' After filling the buffer, quirc_end() should be called to process the image for QR-code recognition. 85 | ' The locations and content of each code may be obtained using accessor functions described below. 86 | Private Declare Sub quirc_end Lib "vb_cairo_sqlite" (ByVal hQ As Long) 87 | 88 | ' Return the number of QR-codes identified in the last processed image. 89 | Private Declare Function quirc_count Lib "vb_cairo_sqlite" (ByVal hQ As Long) As Long 90 | 91 | ' Extract the QR-code specified by the given index. 92 | Private Declare Sub quirc_extract Lib "vb_cairo_sqlite" (ByVal hQ As Long, ByVal Index As Long, Code As tQUIRC_CODE) 93 | 94 | ' Decode a QR-code, returning the payload data. 95 | Private Declare Function quirc_decode Lib "vb_cairo_sqlite" (Code As tQUIRC_CODE, Data As tQUIRC_DATA) As eQUIRC_DECODE_ERROR 96 | 97 | ' Destroy a QR-code recognizer. 98 | Private Declare Sub quirc_destroy Lib "vb_cairo_sqlite" (ByVal hQ As Long) 99 | 100 | 'Class-internal Helper-Vars 101 | Private mResultsCount&, mResultCodes() As tQUIRC_CODE, mResults() As tQUIRC_DATA, mResultErrors$() 102 | 103 | Public Sub DecodeFromSurface(Src As cCairoSurface) 104 | Dim i As Long, x&, y&, hQ As Long, pImg As Long, SrfPxl() As Byte, QRPxl() As Byte 105 | mResultsCount = 0 106 | If Src Is Nothing Then Exit Sub 107 | 108 | With Src.CreateSimilar.CreateContext 'creata a temporary Surface from the Source 109 | .SetSourceColor vbBlack 110 | .Paint 'pre-fill the Tmp-Surface with Black 111 | 112 | .Operator = CAIRO_OPERATOR_HSL_LUMINOSITY 'grayscale-conversion operator 113 | .Paint , Src.CreateSurfacePattern 'draw from the Source-Surface 114 | 115 | 'now that we have greyscaled Surface-Content - we start to copy over into an 8BPP-ByteArray 116 | ReDim QRPxl(0 To Src.Width - 1, 0 To Src.Height - 1) 117 | If .Surface.BindToArray(SrfPxl) Then 118 | For y = 1 To UBound(SrfPxl, 2) - 1 119 | i = 1 120 | For x = 4 To UBound(SrfPxl, 1) - 4 Step 4 121 | If SrfPxl(x, y) < 128 Then QRPxl(i, y) = 1 'a QRInput-Arr needs a '1' for black - and a '0' for white 122 | i = i + 1 123 | Next x 124 | Next y 125 | .Surface.ReleaseArray SrfPxl 126 | Else 127 | Err.Raise vbObjectError, , "couldn't create GreyScale-Data from Surface" 128 | End If 129 | End With 130 | 131 | 'our 8BPP QRPxlArr is prepared, so we can start the analysis on it now (incorporating the quirc-lib) 132 | hQ = quirc_new() 133 | 134 | If hQ = 0 Then Err.Raise vbObjectError, , "can't create quirc-handle" 135 | 136 | If quirc_resize(hQ, Src.Width, Src.Height) < 0 Then 137 | quirc_destroy hQ 138 | Err.Raise vbObjectError, , "can't allocate memory for the quirc-internal image" 139 | End If 140 | 141 | pImg = quirc_begin(hQ, 0, 0) 'prepare for image-analysis 142 | New_c.MemCopy pImg, VarPtr(QRPxl(0, 0)), Src.Width * Src.Height 'copy 8BPP-GreyData over 143 | quirc_end hQ 'perform image-analysis-process (and end it internally) 144 | 145 | 146 | mResultsCount = quirc_count(hQ) 'get the amount of QR-Areas we've found on that image 147 | 148 | If mResultsCount Then 'store Results in Class-internal Result-Arrays 149 | ReDim mResultCodes(0 To mResultsCount - 1) 150 | ReDim mResults(0 To mResultsCount - 1) 151 | ReDim mResultErrors(0 To mResultsCount - 1) 152 | 153 | For i = 0 To UBound(mResults) 154 | quirc_extract hQ, i, mResultCodes(i) 155 | mResultErrors(i) = GetErrorString(quirc_decode(mResultCodes(i), mResults(i))) 156 | Next i 157 | End If 158 | 159 | quirc_destroy hQ 160 | End Sub 161 | 162 | 'index-like access into the Results (since there's possibly more than one single QR-Code per Image) 163 | Public Property Get QRResultsCount() As Long 164 | QRResultsCount = mResultsCount 165 | End Property 166 | Public Property Get QRVersion(ByVal IndexZeroBased As Long) As Long 167 | QRVersion = mResults(IndexZeroBased).Version 168 | End Property 169 | Public Property Get QREccLevel(ByVal IndexZeroBased As Long) As String 170 | QREccLevel = Choose(mResults(IndexZeroBased).EccLevel + 1, "M", "L", "H", "Q") 171 | End Property 172 | Public Property Get QRMask(ByVal IndexZeroBased As Long) As Long 173 | QRMask = mResults(IndexZeroBased).Mask 174 | End Property 175 | Public Property Get QRDataType(ByVal IndexZeroBased As Long) As QUIRC_DATA_TYPE 176 | QRDataType = mResults(IndexZeroBased).DataType 177 | End Property 178 | Public Property Get QRData(ByVal IndexZeroBased As Long) As Byte() 179 | If QRDataLen(IndexZeroBased) <= 0 Or QRDataLen(IndexZeroBased) > QUIRC_MAX_PAYLOAD Then QRData = vbNullString: Exit Property 180 | With New_c.Stream 181 | .WriteFromPtr VarPtr(mResults(IndexZeroBased).Data(0)), QRDataLen(IndexZeroBased) 182 | .SetPosition 0 183 | .ReadToByteArr QRData 184 | End With 185 | End Property 186 | Public Property Get QRDataLen(ByVal IndexZeroBased As Long) As Long 187 | If mResultsCount Then QRDataLen = mResults(IndexZeroBased).DataLen 188 | End Property 189 | Public Property Get QRErrString(ByVal IndexZeroBased As Long) As String 190 | QRErrString = mResultErrors(IndexZeroBased) 191 | End Property 192 | 193 | 194 | 'just a small helper, to translate the Err_Enum into Err_Strings 195 | Private Function GetErrorString(ByVal E As eQUIRC_DECODE_ERROR) As String 196 | Select Case E 197 | Case QUIRC_ERROR_INVALID_GRID_SIZE: GetErrorString = "Invalid grid size" 198 | Case QUIRC_ERROR_INVALID_VERSION: GetErrorString = "Invalid version" 199 | Case QUIRC_ERROR_FORMAT_ECC: GetErrorString = "Format data ECC failure" 200 | Case QUIRC_ERROR_DATA_ECC: GetErrorString = "ECC failure" 201 | Case QUIRC_ERROR_UNKNOWN_DATA_TYPE: GetErrorString = "Unknown data type" 202 | Case QUIRC_ERROR_DATA_OVERFLOW: GetErrorString = "Data overflow" 203 | Case QUIRC_ERROR_DATA_UNDERFLOW: GetErrorString = "Data underflow" 204 | End Select 205 | End Function 206 | 207 | 208 | -------------------------------------------------------------------------------- /cQREncode.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "cQREncode" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Option Explicit 15 | 16 | 'a simple Binding for the nice libqrencode-project of Kentaro Fukuchi (http://fukuchi.org/works/qrencode/) - 17 | 'the lib comes under LGPL-license which allows also commercial usage ... 18 | 'I've compiled it into the latest release of vb_cairo_sqlite.dll in a VB-friendly StdCall-version 19 | 'Aside from vb_cairo_sqlite, this Class has no other (Code)Module-dependencies (Olaf Schmidt, Jan. 2015) 20 | 21 | Public Enum QRencodeMode 22 | QR_MODE_NUM = 0 'Numeric mode 23 | QR_MODE_AN 'Alphabet-numeric mode 24 | QR_MODE_8 '8-bit data mode 25 | QR_MODE_KANJI 'Kanji (shift-jis) mode 26 | QR_MODE_STRUCTURE 'Internal use only 27 | QR_MODE_ECI 'ECI mode 28 | QR_MODE_FNC1FIRST 'FNC1, first position 29 | QR_MODE_FNC1SECOND 'FNC1, second position 30 | End Enum 31 | 32 | Public Enum QRecLevel 'Error-Correction-Level 33 | QR_ECLEVEL_L = 0 'lowest 34 | QR_ECLEVEL_M 35 | QR_ECLEVEL_Q 36 | QR_ECLEVEL_H 'highest 37 | End Enum 38 | 39 | Private Type QRcode 40 | Version As Long 41 | Width As Long 'Width describes the squared Width (and Height) of the returned symbol 42 | pResult As Long 'pointer to a data-array with a ByteLength of Width ^ 2 43 | ' each Byte in the above result contains the following Info in its 8 Bits 44 | ' * MSB 76543210 LSB 45 | ' * |||||||`- 1=black/0=white 46 | ' * ||||||`-- data and ecc code area 47 | ' * |||||`--- format information 48 | ' * ||||`---- version information 49 | ' * |||`----- timing pattern 50 | ' * ||`------ alignment pattern 51 | ' * |`------- finder pattern and separator 52 | ' * `-------- non-data modules (format, timing, etc.) 53 | End Type 54 | 55 | Private Declare Function QRcode_encodeData Lib "vb_cairo_sqlite" (ByVal LenData As Long, ByVal pData As Long, ByVal Version As Long, ByVal EcLevel As QRecLevel) As Long 56 | Private Declare Function QRcode_encodeDataMQR Lib "vb_cairo_sqlite" (ByVal LenData As Long, ByVal pData As Long, ByVal Version As Long, ByVal EcLevel As QRecLevel) As Long 57 | Private Declare Sub QRcode_free Lib "vb_cairo_sqlite" (ByVal hQR As Long) 58 | 59 | Public Function QREncode(Data() As Byte, Optional Version_1to40 As Long, _ 60 | Optional ByVal EcLevel As QRecLevel = QR_ECLEVEL_M, _ 61 | Optional ByVal PixelSize As Long = 4, _ 62 | Optional ByVal SrfType As SurfaceCreateEnum = ImageSurface) As cCairoSurface 63 | 64 | Dim hQR As Long, LenData As Long, QR As QRcode, Result() As Byte 65 | On Error Resume Next 66 | LenData = UBound(Data) - LBound(Data) + 1 67 | On Error GoTo 0 68 | If LenData = 0 Then Set QREncode = Cairo.CreateSurface(1, 1, SrfType): Exit Function 69 | 70 | If Version_1to40 < 0 Then Version_1to40 = 0 Else If Version_1to40 > 40 Then Version_1to40 = 40 71 | hQR = QRcode_encodeData(LenData, VarPtr(Data(LBound(Data))), Version_1to40, EcLevel) 72 | If hQR Then New_c.MemCopy VarPtr(QR), hQR, LenB(QR) Else Exit Function 73 | 74 | ReDim Result(0 To QR.Width - 1, 0 To QR.Width - 1) 75 | New_c.MemCopy VarPtr(Result(0, 0)), QR.pResult, QR.Width ^ 2 76 | QRcode_free hQR 77 | 78 | Version_1to40 = QR.Version 'report the resulting Version back to the caller in our ByRef-Param 79 | Set QREncode = RenderResultToSurface(Result, PixelSize, SrfType) 80 | End Function 81 | 82 | Public Function QREncodeMQR(Data() As Byte, Optional ByVal Version_1to4 As Long = 4, _ 83 | Optional ByVal EcLevel As QRecLevel = QR_ECLEVEL_M, _ 84 | Optional ByVal PixelSize As Long = 4, _ 85 | Optional ByVal SrfType As SurfaceCreateEnum = ImageSurface) As cCairoSurface 86 | 87 | Dim hQR As Long, LenData As Long, QR As QRcode, Result() As Byte 88 | On Error Resume Next 89 | LenData = UBound(Data) - LBound(Data) + 1 90 | On Error GoTo 0 91 | If LenData = 0 Then Set QREncodeMQR = Cairo.CreateSurface(1, 1, SrfType): Exit Function 92 | 'other than in normal QREncoding above, for MicroQR the Version is not "auto-expanded" - 93 | 'one has to provide the Version in the right size (for the amount of Data to be taken up) oneself 94 | If Version_1to4 < 1 Then Version_1to4 = 1 Else If Version_1to4 > 4 Then Version_1to4 = 4 95 | hQR = QRcode_encodeDataMQR(LenData, VarPtr(Data(LBound(Data))), Version_1to4, EcLevel) 96 | If hQR Then New_c.MemCopy VarPtr(QR), hQR, LenB(QR) Else Exit Function 97 | 98 | ReDim Result(0 To QR.Width - 1, 0 To QR.Width - 1) 99 | New_c.MemCopy VarPtr(Result(0, 0)), QR.pResult, QR.Width ^ 2 100 | QRcode_free hQR 101 | 102 | Set QREncodeMQR = RenderResultToSurface(Result, PixelSize, SrfType) 103 | End Function 104 | 105 | Private Function RenderResultToSurface(Result() As Byte, ByVal PixelSize&, _ 106 | Optional ByVal SrfType As SurfaceCreateEnum = ImageSurface) As cCairoSurface 107 | Dim x As Long, y As Long, Width As Long 108 | Width = UBound(Result) + 1 109 | If PixelSize < 1 Then PixelSize = 1 Else If PixelSize > 15 Then PixelSize = 15 110 | Set RenderResultToSurface = Cairo.CreateSurface(PixelSize * Width, PixelSize * Width, SrfType) 111 | With RenderResultToSurface.CreateContext 112 | .SetSourceColor vbWhite: .Paint 'ensure white BackGround 113 | 114 | .ScaleDrawings PixelSize, PixelSize 'scale the output appropriately 115 | 116 | .SetSourceColor vbBlack 'since white background was ensured above... 117 | For y = 0 To Width - 1: For x = 0 To Width - 1 118 | If Result(x, y) And 1 Then .Rectangle x, y, 1, 1 '...only black rects are drawn now 119 | Next x, y 120 | .Fill 'fill the black rectangles 121 | End With 122 | End Function 123 | 124 | 125 | 126 | -------------------------------------------------------------------------------- /cUndoRedo.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "cUndoRedo" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Option Explicit 'a generic Undo/Redo History-List... 15 | 16 | Private States As cCollection, Idx As Long 17 | 18 | Private Sub Class_Initialize() 19 | Set States = New_c.Collection 20 | End Sub 21 | 22 | Public Sub Clear() 23 | Set States = New_c.Collection 24 | Idx = 0 25 | End Sub 26 | 27 | Public Sub SaveState(State) 28 | Dim i As Long 29 | 'delete all states up to the last UndoIdx, before adding the new state on Top 30 | For i = 1 To Idx - 1: States.Remove 1: Next i 31 | 32 | States.Add State, , 1 'add state on top of the States-Collection 33 | Idx = 1 'last added state is alwys on top 34 | End Sub 35 | 36 | Public Property Get PreviousState() 37 | If States.Count = 0 Or Idx >= States.Count Then Exit Property Else Idx = Idx + 1 38 | Assign PreviousState, States(Idx) 39 | End Property 40 | 41 | Public Property Get NextState() 42 | If States.Count = 0 Or Idx <= 1 Then Exit Property Else Idx = Idx - 1 43 | Assign NextState, States(Idx) 44 | End Property 45 | 46 | Private Sub Assign(LHS, RHS) 47 | If IsObject(RHS) Then Set LHS = RHS Else LHS = RHS 48 | End Sub 49 | 50 | Public Property Get UndoEnabled() As Boolean 51 | UndoEnabled = (States.Count > 1 And Idx < States.Count) 52 | End Property 53 | 54 | Public Property Get RedoEnabled() As Boolean 55 | RedoEnabled = (Idx > 1) 56 | End Property 57 | 58 | -------------------------------------------------------------------------------- /cfPopUp.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "cfPopUp" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Option Explicit 15 | 16 | Event MouseClickOutside() 17 | Event AppDeactivate() 18 | Event CheckForAdditionalCloseConditions() 19 | Event InitialMouseUp(ByVal Button As Integer) 20 | 21 | Public WithEvents Form As cWidgetForm 22 | Attribute Form.VB_VarHelpID = -1 23 | Private WithEvents tmrPopUp As cTimer 24 | Attribute tmrPopUp.VB_VarHelpID = -1 25 | 26 | Private mMouseDown As Boolean, mInitialMouseDownKey As Long 27 | 28 | Public Sub Load(Widget As Object, ByVal ScreenX As Long, ByVal ScreenY As Long, ByVal WidthPxl As Long, ByVal HeightPxl As Long, Optional ByVal Zoom As Single = 1, Optional ByVal WithDropShadow As Boolean = True) 29 | Unload 30 | If Widget Is Nothing Then Exit Sub 31 | 32 | If TypeOf Widget Is cwMenu Then 33 | If Not TypeOf Widget.InitiatorWidget.object Is cwMenu Then 34 | If Not fActivePopUp Is Nothing Then If Not fActivePopUp Is Me Then fActivePopUp.Unload 35 | Set fActivePopUp = Me 36 | End If 37 | Else 38 | If Not fActivePopUp Is Nothing Then If Not fActivePopUp Is Me Then fActivePopUp.Unload 39 | Set fActivePopUp = Me 40 | End If 41 | 42 | If Widget.Widget.Root Is Nothing Then 43 | Set Form = Cairo.WidgetForms.CreateChild(0, True, False, False, WithDropShadow) 44 | Else 45 | Set Form = Cairo.WidgetForms.CreateChild(Widget.Widget.Root.DialogFormHwnd, True, False, False, WithDropShadow) 46 | End If 47 | Form.WidgetRoot.Zoom = Zoom 48 | Form.Widgets.Add Widget, "CurPopupWidget", 0, 0, WidthPxl / Zoom, HeightPxl / Zoom 49 | Form.Move ScreenX, ScreenY, WidthPxl, HeightPxl 50 | mInitialMouseDownKey = Form.WidgetRoot.MouseKeyDown 51 | mMouseDown = True 52 | 53 | Set tmrPopUp = New_c.Timer(20, True) 54 | End Sub 55 | 56 | Public Sub Show() 57 | If Not Form Is Nothing Then Form.Show 58 | End Sub 59 | 60 | Public Sub Unload() 61 | On Error Resume Next 62 | Set tmrPopUp = Nothing 63 | If fActivePopUp Is Me Then Set fActivePopUp = Nothing 64 | 65 | If Not Form Is Nothing Then 66 | If Not Form.Widgets Is Nothing Then Form.Widgets.RemoveAll 67 | If Form.hWnd Then Form.Unload 68 | End If 69 | Set Form = Nothing 70 | If Err Then Err.Clear 71 | End Sub 72 | 73 | Private Sub Form_ActivateApp(ByVal Activated As Boolean, ByVal OtherThreadID As Long) 74 | If Not Activated Then 75 | On Error Resume Next 76 | RaiseEvent AppDeactivate 77 | If Err Then Err.Clear 78 | End If 79 | End Sub 80 | 81 | Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) 82 | mMouseDown = True 83 | End Sub 84 | 85 | Private Sub Form_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single) 86 | If mMouseDown And mInitialMouseDownKey > 0 Then 87 | RaiseEvent InitialMouseUp(mInitialMouseDownKey) 88 | mInitialMouseDownKey = 0 89 | End If 90 | mMouseDown = False 91 | End Sub 92 | 93 | Private Sub tmrPopUp_Timer() 94 | If Form Is Nothing Then Exit Sub 95 | If Form.WidgetRoot Is Nothing Then Exit Sub 96 | If Form.hWnd = 0 Then Exit Sub 97 | On Error Resume Next 98 | With Form.WidgetRoot 99 | If mMouseDown And .MouseKeyDown = 0 Then mMouseDown = False 100 | If (Not mMouseDown) And .MouseKeyDown Then 101 | If .GetWindowUnderCursor <> .hWnd Then RaiseEvent MouseClickOutside 102 | End If 103 | End With 104 | RaiseEvent CheckForAdditionalCloseConditions 105 | If Err Then Err.Clear 106 | End Sub 107 | 108 | Private Sub Class_Terminate() 109 | Unload 110 | End Sub 111 | -------------------------------------------------------------------------------- /cwAccordeon.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "cwAccordeon" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Option Explicit 15 | 16 | Event SelectionChanged(ActiveEntry As cwAccordeonEntry) 17 | 18 | Private Alpha As Single, dx As Single, dy As Single 19 | Private mCaption As String, mCurrentEntryIndex As Long 20 | Private mCaptionHeight As Single, mAccEntryHeight As Single 21 | 22 | Private WithEvents W As cWidgetBase 23 | Attribute W.VB_VarHelpID = -1 24 | 25 | Private Sub Class_Initialize() 26 | Set W = Cairo.WidgetBase 27 | W.SetClientAreaOffsets 1, 1, 1, 1 28 | W.FontBold = True 29 | W.FontItalic = True 30 | W.ForwardFocus = True 31 | 32 | mCurrentEntryIndex = -1 33 | mCaptionHeight = 28 34 | mAccEntryHeight = 25 35 | End Sub 36 | Public Property Get Widget() As cWidgetBase 37 | Set Widget = W 38 | End Property 39 | Public Property Get Widgets() As cWidgets 40 | Set Widgets = W.Widgets 41 | End Property 42 | 43 | Public Property Get Caption() As String 44 | Caption = mCaption 45 | End Property 46 | Public Property Let Caption(ByVal NewValue As String) 47 | mCaption = NewValue 48 | W.Refresh 49 | End Property 50 | 51 | Public Sub AddEntry(Caption As String, IconResourceKey As String, AssociatedWidget As Object) 52 | Dim Key As String, NewAccordeonEntry As New cwAccordeonEntry 53 | NewAccordeonEntry.Caption = Caption 54 | NewAccordeonEntry.Widget.ImageKey = IconResourceKey 55 | 56 | Key = Widgets.Count \ 2 & "_AccEntry" 57 | Widgets.Add NewAccordeonEntry, Key, 0, 0, W.Width, mAccEntryHeight 58 | Widgets.Add AssociatedWidget, Key & "Assoc", 0, 0, W.Width, mAccEntryHeight, False 59 | 60 | AdjustEntries 61 | End Sub 62 | 63 | Private Sub AdjustEntries() 64 | Dim i As Long, y As Single, yy As Single, WEntry As cWidgetBase 65 | If Widgets.Count = 0 Then Exit Sub 66 | W.LockRefresh = True 67 | y = mCaptionHeight 68 | For i = 0 To mCurrentEntryIndex 69 | 'the cwAccordeon-Entry 70 | Set WEntry = Widgets(2 * i + 1).Widget 71 | WEntry.Move -1, y, W.Width, mAccEntryHeight 72 | y = y + mAccEntryHeight 73 | 74 | 'the associated Widget 75 | Set WEntry = Widgets(2 * i + 2).Widget 76 | If i < mCurrentEntryIndex Then WEntry.Visible = False 77 | Next i 78 | 79 | yy = W.ScaleHeight - (Widgets.Count \ 2 - mCurrentEntryIndex - 1) * mAccEntryHeight 80 | If Not WEntry Is Nothing Then 81 | WEntry.Move -1, y - 1, W.Width, yy - y + 2 82 | WEntry.Visible = True 83 | ' WEntry.SetFocus 84 | End If 85 | 86 | y = yy 87 | For i = mCurrentEntryIndex + 1 To Widgets.Count \ 2 - 1 88 | 'the cwAccordeon-Entry 89 | Set WEntry = Widgets(2 * i + 1).Widget 90 | WEntry.Move 0, y + 1, W.Width, mAccEntryHeight 91 | y = y + mAccEntryHeight 92 | 93 | 'the associated Widget 94 | Set WEntry = Widgets(2 * i + 2).Widget 95 | WEntry.Visible = False 96 | Next i 97 | W.LockRefresh = False 98 | End Sub 99 | 100 | Public Property Get EntriesCount() As Long 101 | EntriesCount = Widgets.Count \ 2 102 | End Property 103 | 104 | Public Function EntryByIndex(ByVal EntryIndexZeroBased As Long) As cwAccordeonEntry 105 | If EntryIndexZeroBased < 0 Or EntryIndexZeroBased >= EntriesCount Then Exit Function 106 | Set EntryByIndex = Widgets(EntryIndexZeroBased * 2 + 1) 107 | End Function 108 | 109 | Public Property Get CurrentEntry() As cwAccordeonEntry 110 | If EntriesCount = 0 Then Exit Property 111 | Set CurrentEntry = Widgets(CurrentEntryIndex * 2 + 1) 112 | End Property 113 | 114 | Public Property Get CurrentEntryIndex() As Long 115 | CurrentEntryIndex = mCurrentEntryIndex 116 | End Property 117 | Public Property Let CurrentEntryIndex(ByVal NewValue As Long) 118 | If NewValue < -1 Or NewValue >= EntriesCount Then Exit Property 119 | If mCurrentEntryIndex = NewValue Then Exit Property 120 | mCurrentEntryIndex = NewValue 121 | 122 | RaiseEvent SelectionChanged(CurrentEntry) 123 | AdjustEntries 124 | End Property 125 | 126 | Private Sub W_BubblingEvent(Sender As Object, EventName As String, P1 As Variant, P2 As Variant, P3 As Variant, P4 As Variant, P5 As Variant, P6 As Variant, P7 As Variant) 127 | Static FocusChange As Boolean 128 | If Sender Is Nothing Then Exit Sub 129 | If TypeOf Sender Is cwAccordeonEntry Then 130 | Select Case EventName 131 | Case "W_LostFocus" 132 | If Not CurrentEntry Is Sender Then FocusChange = True 133 | Case "W_Click" 134 | CurrentEntryIndex = Split(Sender.Widget.Key, "_")(0) 135 | Case "W_KeyPress" 136 | If P1 = vbKeySpace Then CurrentEntryIndex = Split(Sender.Widget.Key, "_")(0) 137 | End Select 138 | 139 | ElseIf Not CurrentEntry Is Nothing Then 140 | If Sender Is CurrentEntry.AssociatedWidget Then 141 | If EventName = "W_KeyDown" Then 142 | If Not (P1 = vbKeyTab And P2 = vbShiftMask) Then Exit Sub 143 | If FocusChange Then FocusChange = False: Exit Sub 144 | If CurrentEntryIndex <= 0 Then W.SetFocus Else EntryByIndex(CurrentEntryIndex - 1).Widget.SetFocus 145 | End If 146 | End If 147 | End If 148 | End Sub 149 | 150 | Private Sub W_Resize() 151 | AdjustEntries 152 | End Sub 153 | 154 | Private Sub W_Paint(CC As cCairoContext, ByVal xAbs As Single, ByVal yAbs As Single, ByVal dx_Aligned As Single, ByVal dy_Aligned As Single, UserObj As Object) 155 | dx = dx_Aligned 156 | dy = dy_Aligned 157 | Alpha = W.AlphaInherited 158 | Draw CC 159 | End Sub 160 | 161 | Private Sub Draw(CC As cCairoContext) 162 | Dim i As Long, Pat As cCairoPattern, dyy As Single, TextShadowColor As Long 163 | 'this If-Block ensures the fill of the TopArea, in case no Entry was selected (EntryIndex = -1) 164 | If mCurrentEntryIndex < 0 And EntriesCount > 0 Then 165 | CC.SetLineWidth 0 166 | CC.SetSourceColor W.BackColor, Alpha, 1.15 167 | dyy = W.ScaleHeight - (EntriesCount - mCurrentEntryIndex - 1) * mAccEntryHeight + 1 168 | CC.Rectangle -1, mCaptionHeight, dx + 2, dyy - mCaptionHeight, True 169 | CC.Fill 170 | 171 | CC.SetLineWidth 1, True 172 | CC.DrawLine 0, dyy, dx, dyy, True 173 | CC.SetSourceColor W.BorderColor, Alpha 174 | CC.Stroke 175 | End If 176 | 177 | 'the Caption-Background 178 | Set Pat = Cairo.CreateLinearPattern(0, 1, 0, mCaptionHeight + 1) 179 | CC.SetLineWidth 0 180 | Pat.AddColorStop 0, W.BackColor, Alpha, 1.3 181 | Pat.AddColorStop 0.03, W.BackColor, Alpha, 0.97 182 | Pat.AddColorStop 1, W.BackColor, Alpha, 1.08 183 | CC.Rectangle 1, 1, dx - 2, mCaptionHeight, True 184 | CC.Fill , Pat 185 | CC.SetLineWidth 1, True 186 | CC.DrawLine 0, mCaptionHeight, dx, mCaptionHeight, True 187 | CC.SetSourceColor W.BorderColor, Alpha * 0.9 188 | CC.Stroke 189 | 190 | 'a blurred TextShadow for the Caption 191 | CC.Save 192 | W.SelectFontSettingsInto CC 193 | TextShadowColor = W.ShadeColor(W.SelectionColor, 0.7) 194 | CC.TranslateDrawings 1.4, 1.5 195 | CC.TranslateDrawings 0.5, 0.5 196 | CC.DrawText 1, -2, dx - 2, mCaptionHeight + 4, mCaption, False, vbLeftJustify, 3, True, dtNormal, Alpha, True 197 | 198 | CC.SetLineJoin CAIRO_LINE_JOIN_ROUND 199 | CC.SetLineCap CAIRO_LINE_CAP_ROUND 200 | For i = 0 To 1 'this loop re-renders always on the same path (ensured by the True-Param in the .Stroke) 201 | CC.SetLineWidth 5 - 3 * i 'but with decreasing linewidth 202 | CC.SetSourceColor TextShadowColor, 0.11 + i * 0.05 'and slightly increasing Opacity 203 | CC.Stroke True 204 | Next i 205 | CC.SetLineWidth 1 206 | CC.SetSourceColor TextShadowColor, 0.2 207 | CC.Stroke 208 | CC.Restore 209 | 210 | 'now the Caption on top of its Shadow 211 | W.SelectFontSettingsInto CC, W.ShadeColor(W.FocusColor, 0.95) 212 | CC.DrawText 1, -2, dx - 2, mCaptionHeight + 4, mCaption, False, vbLeftJustify, 3, True, dtNormal, Alpha 213 | 214 | 'themed default-Border around our Widget 215 | CC.SetLineWidth 1, True 216 | Cairo.Theme.DrawTo CC, W, thmTypeBorder, 0, 0, 0, dx, dy 217 | End Sub 218 | 219 | 220 | 221 | -------------------------------------------------------------------------------- /cwAccordeonEntry.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "cwAccordeonEntry" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Option Explicit 15 | 16 | Private Alpha As Single, dx As Single, dy As Single 17 | Private mCaption As String 18 | 19 | Private WithEvents W As cWidgetBase 20 | Attribute W.VB_VarHelpID = -1 21 | 22 | Private Sub Class_Initialize() 23 | Set W = Cairo.WidgetBase 24 | End Sub 25 | Public Property Get Widget() As cWidgetBase 26 | Set Widget = W 27 | End Property 28 | Public Property Get Widgets() As cWidgets 29 | Set Widgets = W.Widgets 30 | End Property 31 | 32 | Public Property Get Caption() As String 33 | Caption = mCaption 34 | End Property 35 | Public Property Let Caption(ByVal NewValue As String) 36 | Dim AccKey$, Pos& 37 | If mCaption = NewValue Then Exit Property 38 | mCaption = NewValue 39 | W.Refresh 40 | Pos = InStr(Replace(mCaption, "&&", "--"), "&") 41 | If Pos Then AccKey = Mid$(Replace(mCaption, "&&", "--"), Pos + 1, 1) 42 | 43 | If Len(AccKey) Then W.AccessKeys = AccKey 44 | End Property 45 | 46 | Public Property Get IsOpen() As Boolean 47 | IsOpen = W.Parent.Object.CurrentEntryIndex = CLng(Split(W.Key, "_")(0)) 48 | End Property 49 | 50 | Public Property Get AssociatedWidget() As Object 51 | With W.Parent.Widgets 'the associated Widget is always one IndexPosition "below us" 52 | Set AssociatedWidget = .Item(.GetOneBasedChildIndexByKey(W.Key) + 1) 53 | End With 54 | End Property 55 | 56 | Private Sub W_GotFocus() 57 | If IsOpen Then AssociatedWidget.Widget.SetFocus 58 | End Sub 59 | 60 | Private Sub W_MouseEnter(ByVal MouseLeaveWidget As cWidgetBase) 61 | W.Refresh 62 | End Sub 63 | Private Sub W_MouseLeave(ByVal MouseEnterWidget As cWidgetBase) 64 | W.Refresh 65 | End Sub 66 | 67 | Private Sub W_AccessKeyPress(KeyAscii As Integer) 68 | If InStr(1, W.AccessKeys, Chr$(KeyAscii), vbTextCompare) Then 69 | W.SetFocus 70 | W.RaiseBubblingEvent Me, "W_Click" 71 | End If 72 | End Sub 73 | 74 | Private Sub W_Paint(CC As cCairoContext, ByVal xAbs As Single, ByVal yAbs As Single, ByVal dx_Aligned As Single, ByVal dy_Aligned As Single, UserObj As Object) 75 | dx = dx_Aligned 76 | dy = dy_Aligned 77 | Alpha = W.AlphaInherited 78 | Draw CC 79 | End Sub 80 | 81 | Private Sub Draw(CC As cCairoContext) 82 | Dim Pat As cCairoPattern, Color As Long, CaptExt As Double 83 | Dim IconKeys() As String, IconKey As String 84 | 85 | Color = W.ShadeColor(W.BackColor, 0.98) 'default color is the greyish one 86 | If IsOpen Then Color = W.SelectionColor 87 | If W.MouseOver Then Color = W.HoverColor 88 | 89 | 90 | CC.SetLineWidth 1, True 91 | Set Pat = Cairo.CreateLinearPattern(0, 0, 0, dy) 92 | Pat.AddColorStop 0, &HF0F0F0, Alpha 93 | Pat.AddColorStop 0.03, &HF0F0F0, Alpha 94 | Pat.AddColorStop 0.05, Color, Alpha, 0.98 95 | Pat.AddColorStop 0.1, Color, Alpha, 0.96 96 | Pat.AddColorStop 0.88, Color, Alpha, 1.05 97 | Pat.AddColorStop 1, Color, Alpha, 1.2 98 | CC.Rectangle 0, 0, dx, dy, True 99 | CC.Fill , Pat 100 | CC.SetSourceColor W.BorderColor, Alpha 101 | CC.DrawLine 0, dy - 1, dx, dy - 1, True 102 | CC.Stroke 103 | 104 | 105 | 'the focused area and a dotted rectangle 106 | If W.Focused Then 107 | CaptExt = CC.GetTextExtents(mCaption) 'measure the current Pixel-Len of the caption-text 108 | 109 | CC.RoundedRect dy - 3, 3, CaptExt + 4, dy - 7, 3, True 110 | CC.SetSourceColor W.FocusColor, Alpha * 0.3, 1.1 111 | CC.Fill 112 | Cairo.Theme.DrawTo CC, W, thmTypeDottedRectangle, 0, dy - 3, 3, CaptExt + 4, dy - 7, 2 113 | End If 114 | 115 | 'the Icon (if there was a resource-info given in the W.ImageKey) 116 | If Len(W.ImageKey) Then 117 | IconKeys = Split(W.ImageKey, ",") 118 | IconKey = Trim$(IconKeys(0)) 119 | If IsOpen Then 'we are the currently active (open and expanded) entry 120 | If UBound(IconKeys) > 0 Then IconKey = Trim$(IconKeys(1)) 121 | End If 122 | CC.RenderSurfaceContent IconKey, 3, 3, dy - 7, dy - 7, , Alpha 123 | End If 124 | 125 | 'the Caption-Text 126 | W.SelectFontSettingsInto CC 127 | CC.DrawText dy - 7, 1, dx, dy, mCaption, True, vbLeftJustify, 6, True, dtHasAccelerators, Alpha 128 | End Sub 129 | 130 | 131 | -------------------------------------------------------------------------------- /cwBrowser.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "cwBrowser" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Option Explicit 15 | 16 | 'Private Declare Function EnableWindow Lib "user32" (ByVal hWnd As Long, ByVal fEnable As Long) As Long 17 | 'Private Declare Function IsWindowVisible Lib "user32" (ByVal hWnd As Long) As Long 18 | 'Private Declare Function IsWindowEnabled Lib "user32" (ByVal hWnd As Long) As Long 19 | 'Private Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long 20 | Private Declare Function ScreenToClient Lib "user32" (ByVal hWnd As Long, lpPoint As Any) As Long 21 | 22 | 'all these Events here are mainly re-delegations of the cWebKit-Events 23 | Event SetPageTitle(PageTitle As String) 24 | Event LoadCommited(URL As String) 25 | Event LoadFinished(ByVal BackCount As Long, ByVal ForwardCount As Long) 26 | Event NewWindowRequest(NewWebKitInstance As cWebKit, ByVal OpenAsTab As Boolean) 27 | Event DecideAboutResourceLoadRequest(RequestURL As String, Cancel As Boolean) 28 | Event DecidePolicyForMimeType(MimeTypeLeftPart As String, MimeTypeRightPart As String, RequestURL As String, NavPolicy As vbRichClient5.NavigationPolicyDecision) 29 | Event DecidePolicyForNavigation(NavInfo As cNavigationInfo, RequestURL As String, NavPolicy As vbRichClient5.NavigationPolicyDecision) 30 | Event DecidePolicyForNewWindow(NavInfo As cNavigationInfo, RequestURL As String, NavPolicy As vbRichClient5.NavigationPolicyDecision) 31 | Event ShowAuthenticationDialog(ByVal URL As String, UserName As String, PassWord As String) 32 | Event ShowJSAlertDlg(Message As String) 33 | Event ShowJSConfirmDlg(Message As String, Cancel As Boolean) 34 | Event ShowJSInputDlg(Message As String, DefaultText As String, ReturnText As String) 35 | Event JSEventCallBack(EventName As String, JSONEventObj As cCollection, JSONResult As cCollection) 36 | Event FindFirst() 37 | Event FindNext() 38 | Event FindPrevious() 39 | Event PrintRequest() 40 | 41 | Public WithEvents WebKit As cWebKit 'this is the WebKit-Binding-class 42 | Attribute WebKit.VB_VarHelpID = -1 43 | Private mViewInitialized As Boolean 44 | 45 | '**** cairo-widget implementation-conventions (also use a cw-Prefix for your 'cwMyWidget'-ClassNames) **** 46 | Private WithEvents W As cWidgetBase 47 | Attribute W.VB_VarHelpID = -1 48 | 49 | Private Sub Class_Initialize() 50 | Set W = Cairo.WidgetBase 51 | W.LockRefresh = True 'this normally not done, but this Widget does no drawing in itself, so we inform the Engine, that it can be ignored in the cairo-RenderLoop 52 | End Sub 53 | Public Property Get Widget() As cWidgetBase 54 | Set Widget = W 55 | End Property 56 | Public Property Get Widgets() As cWidgets 57 | Set Widgets = W.Widgets 58 | End Property 59 | '**** end of cairo-widget implementation-conventions **** 60 | 61 | Private Sub Class_Terminate() 62 | Set WebKit = Nothing 63 | End Sub 64 | 65 | Public Sub Navigate2(URL As String, CachePolicy As NavigationCachePolicy, ByVal TimeOutIntervalSec As Double) 66 | WebKit.Navigate2 URL, CachePolicy, TimeOutIntervalSec 67 | End Sub 68 | 69 | Public Sub DelegateFocus() 70 | If Not WebKit Is Nothing Then WebKit.DelegateFocus 71 | End Sub 72 | Public Sub SynchronizeCoords() 73 | Dim xScreen As Single, yScreen As Single, PT(0 To 1) As Long 74 | 75 | If WebKit Is Nothing Or W.Root Is Nothing Then Exit Sub 76 | W.CalculateScreenOffsets xScreen, yScreen 77 | PT(0) = xScreen: PT(1) = yScreen 78 | ScreenToClient W.Root.hWnd, PT(0) 79 | 80 | ' W.Root.Widget.LockRefresh = True 81 | 82 | WebKit.Move PT(0), PT(1), W.ScaleWidthPxl, W.ScaleHeightPxl 83 | DoEvents 84 | ' Debug.Print "cwBrowserMove", IsWindowEnabled(W.hWnd), IsWindowVisible(W.hWnd) 85 | ' W.Root.Widget.LockRefresh = False 86 | End Sub 87 | 88 | Private Sub W_AddedToHierarchy() 89 | InitWebKit 90 | End Sub 91 | 92 | Private Sub InitWebKit() 93 | If mViewInitialized Then Exit Sub 94 | If W.Root Is Nothing Then Exit Sub 95 | 96 | mViewInitialized = True 97 | 98 | If WebKit Is Nothing Then Set WebKit = New_c.WebKit 99 | WebKit.InitializeView W.Root.hWnd, W.Left, W.Top, W.Width, W.Height 100 | 101 | 'Debug.Print "initwebkit", W.hWnd 102 | ' EnableWindow W.hWnd, 1 103 | ' EnableWindow GetParent(W.hWnd), 1 104 | ' WebKit.InitializeView W.hWnd, 0, 0, W.ScaleWidthPxl, W.ScaleHeightPxl 105 | End Sub 106 | 107 | 'the following three Event-Handlers ensure, that the Widget- and the BrowserWindow-Focus is "synced" 108 | Private Sub W_GotFocus() 109 | If WebKit Is Nothing Then Exit Sub 110 | If Not WebKit.Focused Then WebKit.DelegateFocus 111 | End Sub 112 | 113 | Private Sub W_LostFocus() 114 | If WebKit Is Nothing Then Exit Sub 115 | If WebKit.Focused Then W.Root.Widget.SetFocus 116 | End Sub 117 | 118 | Private Sub W_Paint(CC As cCairoContext, ByVal xAbs As Single, ByVal yAbs As Single, ByVal dx_Aligned As Single, ByVal dy_Aligned As Single, UserObj As Object) 119 | SynchronizeCoords 120 | End Sub 121 | 122 | Private Sub WebKit_DecideAboutResourceLoadRequest(RequestURL As String, Cancel As Boolean) 123 | RaiseEvent DecideAboutResourceLoadRequest(RequestURL, Cancel) 124 | 125 | ' If Cancel Then Debug.Print "cancelled Resource-Request: --> ", RequestURL 126 | End Sub 127 | 128 | Private Sub WebKit_DecidePolicyForMimeType(MimeTypeLeftPart As String, MimeTypeRightPart As String, RequestURL As String, NavPolicy As vbRichClient5.NavigationPolicyDecision) 129 | RaiseEvent DecidePolicyForMimeType(MimeTypeLeftPart, MimeTypeRightPart, RequestURL, NavPolicy) 130 | End Sub 131 | 132 | Private Sub WebKit_DecidePolicyForNavigation(NavInfo As cNavigationInfo, RequestURL As String, NavPolicy As vbRichClient5.NavigationPolicyDecision) 133 | RaiseEvent DecidePolicyForNavigation(NavInfo, RequestURL, NavPolicy) 134 | End Sub 135 | 136 | Private Sub WebKit_DecidePolicyForNewWindow(NavInfo As cNavigationInfo, RequestURL As String, NavPolicy As vbRichClient5.NavigationPolicyDecision) 137 | RaiseEvent DecidePolicyForNewWindow(NavInfo, RequestURL, NavPolicy) 138 | End Sub 139 | 140 | Private Sub WebKit_DecideAboutDownload(ByVal URL As String, Cancel As Boolean) 141 | Debug.Print "DecideAboutDownload" 142 | End Sub 143 | Private Sub WebKit_DownloadStart(DownloadObj As cDownload) 144 | Debug.Print "DownloadStart" 145 | End Sub 146 | Private Sub WebKit_DownloadProgress(DownloadObj As cDownload, ByVal Percent As Single, ByVal StatusCode As Long, StatusDescription As String, StatusValue As String) 147 | Debug.Print "DownloadProgress", Percent 148 | End Sub 149 | Private Sub WebKit_DownloadComplete(DownloadObj As cDownload, ByVal ErrNum As Long, ErrString As String) 150 | Debug.Print "DownloadComplete with: ", 151 | If ErrNum = 0 Then 152 | Debug.Print "DataLength: " & DownloadObj.GetContentLen 153 | Else 154 | Debug.Print ErrString 155 | End If 156 | End Sub 157 | 158 | Private Sub WebKit_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single, ByVal xWithScrollOffs As Long, ByVal yWithScrollOffs As Long) 159 | W.MouseDown Button, Shift, x, y 'redelegate mousedown to the Widget 160 | End Sub 161 | 162 | Private Sub WebKit_PrintRequest() 163 | RaiseEvent PrintRequest 164 | End Sub 165 | 166 | Private Sub WebKit_ShowAuthenticationDialog(ByVal URL As String, UserName As String, PassWord As String) 167 | RaiseEvent ShowAuthenticationDialog(URL, UserName, PassWord) 168 | End Sub 169 | 170 | Private Sub WebKit_ShowJSAlertDlg(Message As String) 171 | RaiseEvent ShowJSAlertDlg(Message) 172 | End Sub 173 | 174 | Private Sub WebKit_ShowJSConfirmDlg(Message As String, Cancel As Boolean) 175 | RaiseEvent ShowJSConfirmDlg(Message, Cancel) 176 | End Sub 177 | 178 | Private Sub WebKit_ShowJSInputDlg(Message As String, DefaultText As String, ReturnText As String) 179 | RaiseEvent ShowJSInputDlg(Message, DefaultText, ReturnText) 180 | End Sub 181 | 182 | Private Sub WebKit_UserDragOverDst(Data As cDataObject, ByVal AllowedEffects As vbRichClient5.WidgetDropEffects, Effect As vbRichClient5.WidgetDropEffects, Button As Integer, Shift As Integer, x As Single, y As Single) 183 | Effect = 3 184 | Debug.Print "UserDropOverHandling", Button, Shift, x, y, Effect 185 | End Sub 186 | Private Sub WebKit_UserDragDropDst(Data As cDataObject, ByVal AllowedEffects As vbRichClient5.WidgetDropEffects, Effect As vbRichClient5.WidgetDropEffects, Button As Integer, Shift As Integer, x As Single, y As Single) 187 | Debug.Print "UserDropHandling", Button, Shift, x, y, Effect 188 | End Sub 189 | 190 | Private Sub WebKit_WebViewDragOverDst(Data As cDataObject, ByVal AllowedEffects As vbRichClient5.WebKitDropEffects, Effect As vbRichClient5.WebKitDropEffects, Button As Integer, Shift As Integer, x As Single, y As Single) 191 | Debug.Print "WebKitDropOverHandling", Button, Shift, x, y, Effect 192 | End Sub 193 | Private Sub WebKit_WebViewDragDropDst(Data As cDataObject, ByVal AllowedEffects As vbRichClient5.WebKitDropEffects, Effect As vbRichClient5.WebKitDropEffects, Button As Integer, Shift As Integer, x As Single, y As Single) 194 | Debug.Print "WebKitDropHandling", Button, Shift, x, y, Effect 195 | End Sub 196 | 197 | 198 | Private Sub WebKit_FindFirst() 199 | RaiseEvent FindFirst 200 | End Sub 201 | Private Sub WebKit_FindNext() 202 | RaiseEvent FindNext 203 | End Sub 204 | Private Sub WebKit_FindPrevious() 205 | RaiseEvent FindPrevious 206 | End Sub 207 | 208 | Private Sub WebKit_GotFocus() 209 | If Not W.Focused Then W.SetFocus 210 | End Sub 211 | 212 | 'same thing here - let's sync the Browser-Window, according to our hosting Widgets coordinates 213 | Private Sub W_Resize() 214 | SynchronizeCoords 215 | End Sub 216 | Private Sub W_Moving() 217 | SynchronizeCoords 218 | End Sub 219 | 220 | 'and also the same here... 221 | Private Sub W_Show() 222 | If Not WebKit Is Nothing Then WebKit.Visible = W.Visible 223 | End Sub 224 | Private Sub W_Hide() 225 | If Not WebKit Is Nothing Then WebKit.Visible = False 226 | End Sub 227 | 228 | 229 | 'this Event is called, when the internal "Browser-Tabbing" is reaching its bounds 230 | '(so we have the chance, to hand-over the focus to our "normal", surrounding Widgets) 231 | Private Sub WebKit_FocusWantsExit(ByVal MoveFocusForward As Boolean) 232 | Dim i& 233 | If W.Parent Is Nothing Then Exit Sub 234 | If W.Parent.ChildCount <= 1 Then Exit Sub 235 | 236 | i = W.Parent.Widgets.GetOneBasedChildIndexByKey(W.Key) 237 | 238 | If MoveFocusForward Then 239 | If i = W.Parent.ChildCount Then i = 1 Else i = i + 1 240 | Else 241 | If i = 1 Then i = W.Parent.ChildCount Else i = i - 1 242 | End If 243 | 244 | W.Root.SetFocus W.Parent.Widgets(i).Widget 'hand-over the focus 245 | End Sub 246 | 247 | 248 | Private Sub WebKit_JSEventCallBack(EventName As String, JSONEventObj As cCollection, JSONResult As cCollection) 249 | RaiseEvent JSEventCallBack(EventName, JSONEventObj, JSONResult) 250 | End Sub 251 | 252 | Private Sub WebKit_LoadFinished(ByVal BackCount As Long, ByVal ForwardCount As Long) 253 | RaiseEvent LoadFinished(BackCount, ForwardCount) 254 | End Sub 255 | 256 | Private Sub WebKit_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single, ByVal xWithScrollOffs As Long, ByVal yWithScrollOffs As Long) 257 | If WebKit Is Nothing Then Exit Sub 258 | WebKit.Enabled = Not W.Root.DesignMode 259 | End Sub 260 | 261 | Private Sub WebKit_MouseMoveOverElement(ElmtInfo As cElementInfo, ByVal ModifierFlags As Long) 262 | If Len(ElmtInfo.Title) Then 263 | W.MouseEnter Nothing 264 | W.ToolTip = ElmtInfo.Title 265 | Else 266 | W.MouseLeave Nothing 267 | End If 268 | End Sub 269 | 270 | Private Sub WebKit_RegisteredEventCallBack(ByVal ElementKey As String, ByVal EventName As String) 271 | ' Debug.Print ElementKey, EventName 272 | End Sub 273 | 274 | Private Sub WebKit_SetPageTitle(PageTitle As String) 275 | RaiseEvent SetPageTitle(PageTitle) 276 | End Sub 277 | 278 | Private Sub WebKit_LoadCommited(URL As String) 279 | RaiseEvent LoadCommited(URL) 280 | End Sub 281 | 282 | Private Sub WebKit_NewWindowRequest(NewWebKitInstance As cWebKit, ByVal OpenAsTab As Boolean) 283 | RaiseEvent NewWindowRequest(NewWebKitInstance, OpenAsTab) 284 | End Sub 285 | 286 | -------------------------------------------------------------------------------- /cwDirList.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "cwDirList" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Option Explicit 15 | 16 | Event Change() 17 | Event Click() 18 | Event DblClick() 19 | Event MouseUpClick() 20 | 21 | Public WithEvents Tree As cwTree 'we inherit visually from a preimplemented Widget 22 | Attribute Tree.VB_VarHelpID = -1 23 | 24 | Private WithEvents W As cWidgetBase 25 | Attribute W.VB_VarHelpID = -1 26 | 27 | Public LanScanMode As ServerScanMode 28 | 29 | Private mPath As String, WithEvents mDS As cDataSource 30 | Attribute mDS.VB_VarHelpID = -1 31 | 32 | Private Sub Class_Initialize() 33 | LanScanMode = NormalScan_FromSystemCache ' FastSubNetPings_HostNames ' the enum-Value Normal_WNetEnumResource is also possible, but usually takes (much) longer 34 | 35 | Set Tree = New cwTree 'the Widget-Instance, to inherit from 36 | Tree.DoubleClickExpandsNodes = False '<- since we use the DoubleClick here, to signalize a Path-Change (as in the classic VB-DirListBox) 37 | 38 | Set mDS = New_c.DataSource 39 | mDS.Init New_c.Collection(False, TextCompare, True), "DirTree", , True 40 | 41 | Path = App.Path '<- pre-init with the App.Path 42 | 43 | 'the following is some kind of "visual inheritance", since we use the already existent 'W' 44 | 'from the VList, instead of creating our own, new 'W' per: Set W = Cairo.WidgetBase 45 | Set W = Tree.Widget 46 | End Sub 47 | Public Property Get Widget() As cWidgetBase 48 | Set Widget = W 49 | End Property 50 | Public Property Get Widgets() As cWidgets 51 | Set Widgets = W.Widgets 52 | End Property 53 | 54 | 55 | ''*** Public Widget-Properties **** 56 | 57 | Public Property Get DataSource() As cDataSource 58 | Set DataSource = mDS 59 | End Property 60 | 61 | Public Property Get ListCount() As Long 62 | ListCount = Tree.ListCount 63 | End Property 64 | Public Property Let ListCount(ByVal NewValue As Long) 65 | Tree.ListCount = NewValue 66 | End Property 67 | 68 | Public Property Get ListIndex() As Long 69 | ListIndex = Tree.ListIndex 70 | End Property 71 | Public Property Let ListIndex(ByVal NewValue As Long) 72 | Tree.ListIndex = NewValue 73 | End Property 74 | 75 | Public Function ValidatePath(ByVal Path As String) As String 76 | If Left$(Path, 4) = "LAN\" Then 77 | ValidatePath = "\\" & Mid$(Path, 5) 'replace our "LAN"-Prefix with the UNC-Path-Prefix 78 | Else 79 | ValidatePath = Path 80 | End If 81 | End Function 82 | 83 | Public Sub ReScan() 84 | Path = mPath 85 | End Sub 86 | 87 | Public Property Get SelectedPath() As String 88 | Dim Key, Value 89 | If mDS Is Nothing Then Exit Property 90 | If Not mDS.TreeElementInfoByVisibleIndex(ListIndex, Key, Value) Then Exit Property 91 | 92 | SelectedPath = ValidatePath(mDS.TreeNodeFullPath(Value)) 93 | End Sub 94 | 95 | Public Property Get Path() As String 96 | Path = mPath & "\" 97 | End Property 98 | Public Property Let Path(ByVal NewValue As String) 99 | Dim i As Long, Drive, Node As cCollection, IsUNCPath As Boolean, PathArr() As String 100 | 101 | If Len(NewValue) = 0 Then Exit Property 102 | If Not New_c.FSO.FolderExists(NewValue) Then Exit Property 103 | 104 | If mDS.Count = 0 Then 105 | mDS.TreeNodeAdd mDS.TreeRoot, "LAN" 106 | 107 | For Each Drive In New_c.FSO.GetDrives 108 | mDS.TreeRoot.Add New_c.Collection(False, TextCompare, True), Drive 109 | Next 110 | End If 111 | 112 | mPath = IIf(Right$(NewValue, 1) = "\", Left$(NewValue, Len(NewValue) - 1), NewValue) 'strip the trailing "\" 113 | 114 | IsUNCPath = (Left$(mPath, 2) = "\\") 115 | PathArr = Split(IIf(IsUNCPath, Mid$(mPath, 3), mPath), "\") 116 | If IsUNCPath Then 117 | Set Node = mDS.TreeRoot.ItemByIndex(0) 118 | If Not Node Is Nothing Then mDS.TreeNodeExpand Node 119 | Else 120 | Set Node = mDS.TreeRoot 121 | End If 122 | 123 | For i = 0 To UBound(PathArr) 124 | If Not Node.Exists(PathArr(i)) Then mDS.TreeNodeAdd Node, PathArr(i) 125 | Set Node = Node.Item(PathArr(i)) 'here we switch from ParentNode to ChidNode 126 | If i < UBound(PathArr) Then mDS.TreeNodeExpand Node '... and expand the new ChidNode (triggers mDS_TreeStateChanged, which ensures Filling in the gaps from the FileSystem) 127 | Next i 128 | 129 | Set Tree.DataSource = mDS 130 | Tree.ListIndex = mDS.TreeNodeGetVisibleIndex(Node) 131 | ' Debug.Print "PathSet", Tree.ListIndex, mDS.AbsolutePosition, mDS.TreeNodeGetVisibleIndex(Node) 132 | RaiseEvent Change 133 | If Not W Is Nothing Then W.RaiseBubblingEvent Me, "Change" 134 | End Property 135 | 136 | 137 | '******************* Event-Sinks ****************** 138 | 139 | Private Sub mDS_TreeStateChanged(ByVal Node As vbRichClient5.cCollection, ByVal Reason As vbRichClient5.TreeChangeReason) 140 | Dim i As Long, DirList As cDirList, Path As String, Share 141 | 'Static Shares As cSortedDictionary 142 | If Reason = NodeExpanded Then 143 | 144 | Path = ValidatePath(mDS.TreeNodeFullPath(Node)) 145 | 146 | 'check for LAN-stuff 147 | If Path = "LAN" Then 148 | ExpandLanNode 149 | Exit Sub 150 | End If 151 | 152 | If InStrRev(Path, "\") = 2 Then 'a child directly below the LAN-Node, so it's not (yet) an UNC-Path (only the ServerName or IP) 153 | Node.RemoveAll 154 | ' If Shares Is Nothing Then Set Shares = New_c.SortedDictionary(TextCompare) 155 | ' If Not Shares.Exists(Path) Then Shares.Add Path, New_c.SMBScan.GetShares(Path) 156 | ' For Each Share In Shares(Path) 157 | For Each Share In New_c.SMBScan.GetShares(Path) 158 | mDS.TreeNodeAdd Node, Share, , True 159 | Next Share 160 | mDS.TreeRefresh 161 | Exit Sub 162 | End If 163 | 164 | 'it's a valid Path, so we proceed here now 165 | On Error Resume Next 166 | Set DirList = New_c.FSO.GetDirList(Path) 167 | If Err Or DirList.SubDirsCount = 0 Then 168 | Err.Clear 169 | mDS.TreeNodeCollapse Node, , True 170 | Else 171 | Node.RemoveAll 172 | For i = 0 To DirList.SubDirsCount - 1 173 | mDS.TreeNodeAdd Node, DirList.SubDirName(i), , True 174 | Next i 175 | mDS.TreeRefresh 176 | End If 177 | End If 178 | End Sub 179 | 180 | Private Sub Tree_OwnerDrawItem(ByVal Index As Long, CC As vbRichClient5.cCairoContext, ByVal dx As Single, ByVal dy As Single, ByVal Alpha As Single) 181 | 'define your Base-Offsets for indentation in the consts below 182 | Const BaseOffsX As Long = 17, Indent As Long = 16, ArrowSize As Long = 8, IconSize As Long = 16 183 | 184 | 'all the Vars defined below, will get filled in the call that follows (ByRef) 185 | Dim Key, Value, Expanded As Boolean, Level As Long '<- 186 | If Not mDS.TreeElementInfoByVisibleIndex(Index, Key, Value, Expanded, Level) Then Exit Sub 187 | 188 | 'Ok ... drawing-time 189 | Dim x As Long, Path As String, DirList As cDirList, Expandable As Boolean 190 | x = BaseOffsX + (Level + 1) * Indent 191 | 192 | If TypeOf Value Is cCollection Then 'we have a Node-Entry 193 | 194 | Path = ValidatePath(mDS.TreeNodeFullPath(Value)) 'for all deeper nested Levels, we call TreeNodeFullPath (and validate the result) 195 | 196 | If Left$(Path, 2) = "\\" Or Path = "LAN" Then 197 | Expandable = True 198 | End If 199 | On Error Resume Next 200 | Expandable = New_c.FSO.DirectoryHasSubDirs(Path, True) 201 | On Error GoTo 0 202 | 203 | Tree.DrawArrow CC, Index, x - IconSize - ArrowSize * 1.5, ArrowSize, Expanded, Expandable 'any Node gets a small Triangle drawn, using a Helper-Function in cwTree 204 | CC.RenderSurfaceContent New_c.FSO.GetFileIconSurface(Path, IIf(Level, True, False), IconSmall, IconNormal), x - IconSize - 1, (dy - IconSize) \ 2, IconSize, IconSize 205 | 206 | End If 207 | 208 | CC.DrawText x, 0, dx - x, dy, CStr(Key), True, vbLeftJustify, 3, True 209 | End Sub 210 | 211 | Private Sub Tree_DblClick() 212 | RaiseEvent DblClick 213 | W.RaiseBubblingEvent Me, "DblClick" 214 | End Sub 215 | 216 | Private Sub Tree_MouseUpClick() 217 | RaiseEvent MouseUpClick 218 | W.RaiseBubblingEvent Me, "MouseUpClick" 219 | End Sub 220 | 221 | Private Sub Tree_Click() 222 | RaiseEvent Click 223 | If Not W Is Nothing Then W.RaiseBubblingEvent Me, "Click" 224 | End Sub 225 | 226 | Private Sub ExpandLanNode() 227 | Dim Node As cCollection, SMB As cSMBScan, Servers As Collection, Server 228 | Set Node = mDS.TreeRoot.ItemByIndex(0) 229 | 230 | Set SMB = New_c.SMBScan 231 | If Not W.Root Is Nothing Then W.Root.MousePointer = IDC_WAIT 232 | Set Servers = SMB.GetServers(LanScanMode) 233 | If Not W.Root Is Nothing Then W.Root.MousePointer = IDC_ARROW 234 | 235 | For Each Server In Servers 236 | If Not Node.Exists(Server) Then mDS.TreeNodeAdd Node, Server 237 | Next Server 238 | 239 | mDS.TreeNodeExpand Node 240 | End Sub 241 | -------------------------------------------------------------------------------- /cwDropDown.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "cwDropDown" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Option Explicit 15 | 16 | Event PopupEscapeKeyPressed(DestroyPopup As Boolean) 17 | Event PopupReturnKeyPressed(DestroyPopup As Boolean) 18 | Event PopupWidgetRequest(WidgetInstance As Object, WidthPxl As Single, HeightPxl As Single) 19 | Event PopupDestroyed() 20 | 21 | Private WithEvents fPopUp As cfPopUp 'this PopupForm-HelperClass is hosted here in the vbWidgets.dll-Project 22 | Attribute fPopUp.VB_VarHelpID = -1 23 | Public WithEvents Btn As cwButton 'we inherit visually from a preimplemented Widget (in this case a cwButton in CheckButton-Mode) 24 | Attribute Btn.VB_VarHelpID = -1 25 | Private WithEvents W As cWidgetBase 26 | Attribute W.VB_VarHelpID = -1 27 | 28 | Private mScreenX As Single, mScreenY As Single, mWindowUnderStartPos As Long 29 | Private mPopupWidget As Object 30 | 31 | Private Sub Class_Initialize() 32 | Set Btn = New cwButton 33 | Btn.ButtonStyle = CheckButton 34 | Btn.HAlignment = vbLeftJustify 35 | Btn.ImageSize = 16 36 | Set W = Btn.Widget '<- in our visual inheritance-scenario, we don't create a new Cairo.WidgetBase, but use the one from Btn.Widget instead 37 | W.ImplementsWheelMessages = True 38 | 39 | W.RuntimePropertiesCommaSeparated = "Text" 40 | End Sub 41 | 42 | Public Property Get Widget() As cWidgetBase 43 | Set Widget = W 44 | End Property 45 | Public Property Get Widgets() As cWidgets 46 | Set Widgets = W.Widgets 47 | End Property 48 | 49 | Public Property Get Caption() As String 50 | Caption = Btn.Caption 51 | End Property 52 | Public Property Let Caption(ByVal NewValue As String) 53 | Btn.Caption = NewValue 54 | End Property 55 | 56 | Public Property Get DrawFocusRect() As Boolean 57 | DrawFocusRect = Btn.DrawFocusRect 58 | End Property 59 | Public Property Let DrawFocusRect(ByVal RHS As Boolean) 60 | Btn.DrawFocusRect = RHS 61 | End Property 62 | 63 | Public Property Get PopupWidget() As Object 64 | Set PopupWidget = mPopupWidget 65 | End Property 66 | 67 | Public Property Get Text() As String 68 | Text = Btn.Caption 69 | End Property 70 | 71 | Public Sub DestroyPopup() 72 | If Not fPopUp Is Nothing Then fPopUp.Unload 73 | Set fPopUp = Nothing 74 | Set mPopupWidget = Nothing 75 | If Not Btn Is Nothing Then Btn.Value = 0 76 | RaiseEvent PopupDestroyed 77 | W.RaiseBubblingEvent Me, "PopupDestroyed" 78 | End Sub 79 | 80 | '------ Event-checks, which ensure fPopUp-Deactivation under certain conditions ----- 81 | Private Sub fPopUp_AppDeactivate() 82 | Btn.Value = 0 83 | End Sub 84 | Private Sub fPopUp_MouseClickOutside() 85 | If Not W.MouseOver Then Btn.Value = 0 86 | End Sub 87 | Private Sub fPopUp_CheckForAdditionalCloseConditions() 88 | If mWindowUnderStartPos <> W.Root.WindowFromPoint(mScreenX, mScreenY) Then Btn.Value = 0 89 | End Sub 90 | Private Sub W_ContainerResize() 91 | Btn.Value = 0 92 | End Sub 93 | Private Sub W_LostFocus() 94 | Btn.Value = 0 95 | End Sub 96 | '---------------- End of fPopUp-Deactivation-Checks ------------------ 97 | 98 | 're-delegation-messages into the currently "popped-up" Widget 99 | Private Sub W_KeyDown(KeyCode As Integer, Shift As Integer) 100 | Dim DestroyPopup As Boolean 101 | If mPopupWidget Is Nothing Then Exit Sub 102 | 103 | If KeyCode = vbKeyEscape Then 104 | DestroyPopup = True '<- set the default in this case to "destroy" 105 | RaiseEvent PopupEscapeKeyPressed(DestroyPopup) 106 | W.RaiseBubblingEvent Me, "PopupEscapeKeyPressed", DestroyPopup 107 | ElseIf KeyCode = vbKeyReturn Then 108 | RaiseEvent PopupReturnKeyPressed(DestroyPopup) 109 | W.RaiseBubblingEvent Me, "PopupReturnKeyPressed", DestroyPopup 110 | End If 111 | 112 | If DestroyPopup Then 113 | Btn.Value = 0 114 | Else 115 | If Not mPopupWidget Is Nothing Then mPopupWidget.Widget.KeyDown KeyCode, Shift 116 | End If 117 | End Sub 118 | Private Sub W_KeyPress(KeyAscii As Integer) 119 | If Not mPopupWidget Is Nothing Then mPopupWidget.Widget.KeyPress KeyAscii 120 | End Sub 121 | Private Sub W_KeyUp(KeyCode As Integer, Shift As Integer) 122 | If Not mPopupWidget Is Nothing Then mPopupWidget.Widget.KeyUp KeyCode, Shift 123 | End Sub 124 | Private Sub W_MouseWheel(ByVal MouseKeys As Long, ByVal Rotation As Long, ByVal LineOffset As Long, ByVal xAbs As Single, ByVal yAbs As Single) 125 | If mPopupWidget Is Nothing Then Exit Sub 126 | mPopupWidget.Widget.MouseEnter Nothing 127 | mPopupWidget.Widget.MouseWheel MouseKeys, Rotation, xAbs, yAbs 128 | End Sub 129 | 130 | 131 | Private Sub Btn_Click() 132 | Dim PopUpOffsX As Single, PopUpOffsY As Single, WidthPxl As Single, HeightPxl As Single 133 | If Btn.Value = 1 Then 'Check-Button is checked (down) 134 | 135 | W.CalculateScreenDimensions WidthPxl, HeightPxl 'get the PixelSize of the Widget for the current Screen 136 | RaiseEvent PopupWidgetRequest(mPopupWidget, WidthPxl, HeightPxl) 137 | If mPopupWidget Is Nothing Then 'apparently nobody filled something into the Byref-Params, so we try again with the Bubbling-Event 138 | W.RaiseBubblingEvent Me, "PopupWidgetRequest", mPopupWidget, WidthPxl, HeightPxl 139 | End If 140 | If mPopupWidget Is Nothing Then Btn.Value = 0: Exit Sub 'still nobody provided something, so we exit here 141 | 142 | W.CalculateScreenOffsets mScreenX, mScreenY 143 | mWindowUnderStartPos = W.Root.WindowFromPoint(mScreenX, mScreenY) 144 | 145 | W.CalculateScreenPopupOffsets WidthPxl, HeightPxl, PopUpOffsX, PopUpOffsY 146 | 147 | Set fPopUp = New cfPopUp 148 | fPopUp.Load mPopupWidget, PopUpOffsX, PopUpOffsY, WidthPxl, HeightPxl, W.Zoom, True 149 | fPopUp.Show 150 | Else 151 | DestroyPopup 152 | End If 153 | End Sub 154 | 155 | Private Sub W_MouseDown(Button As Integer, Shift As Integer, ByVal x As Single, ByVal y As Single) 156 | W.MouseUp Button, Shift, x, y 157 | End Sub 158 | 159 | Private Sub W_Paint(CC As cCairoContext, ByVal xAbs As Single, ByVal yAbs As Single, ByVal dx_Aligned As Single, ByVal dy_Aligned As Single, UserObj As Object) 160 | Dim ArrowSize As Single, LeftOffs As Single, RightOffs As Single 161 | ArrowSize = 8 162 | RightOffs = 2.5 * ArrowSize 163 | LeftOffs = dx_Aligned - RightOffs 164 | 165 | Cairo.Theme.DrawTo CC, W, thmTypeSeparatorLine, 0, LeftOffs, 3, 1, dy_Aligned - 4 166 | Cairo.Theme.DrawTo CC, W, thmTypeArrow, 0, LeftOffs + (RightOffs - ArrowSize) / 2, (dy_Aligned - ArrowSize) / 2, ArrowSize, ArrowSize, , thmDirectionDown 167 | End Sub 168 | 169 | Private Sub Class_Terminate() 170 | If Not fPopUp Is Nothing Then fPopUp.Unload 171 | End Sub 172 | 173 | -------------------------------------------------------------------------------- /cwDropDownList.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "cwDropDownList" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Option Explicit 15 | 16 | Event Click() 17 | 18 | 'DataSource-Implementation-Vars 19 | Private WithEvents mDS As cDataSource, mDataSourceKey As String, mDataField As String 20 | Attribute mDS.VB_VarHelpID = -1 21 | 22 | Public WithEvents DropDown As cwDropDown 23 | Attribute DropDown.VB_VarHelpID = -1 24 | Public WithEvents VList As cwVList 25 | Attribute VList.VB_VarHelpID = -1 26 | 27 | Private WithEvents W As cWidgetBase 28 | Attribute W.VB_VarHelpID = -1 29 | 30 | Private Sub Class_Initialize() 31 | Set DropDown = New cwDropDown 32 | Set VList = New cwVList 33 | Set W = DropDown.Widget 34 | DrawFocusRect = True 35 | End Sub 36 | 37 | Public Property Get Widget() As cWidgetBase 38 | Set Widget = W 39 | End Property 40 | Public Property Get Widgets() As cWidgets 41 | Set Widgets = W.Widgets 42 | End Property 43 | 44 | Public Property Get DrawFocusRect() As Boolean 45 | DrawFocusRect = DropDown.DrawFocusRect 46 | End Property 47 | Public Property Let DrawFocusRect(ByVal RHS As Boolean) 48 | DropDown.DrawFocusRect = RHS 49 | End Property 50 | 51 | '***************** Start of typical-DataSource-related Procedures *************** 52 | Public Function SetDataSource(CollectionOrRecordset As Object, Key As String, Optional DataField As String) As cDataSource 53 | If Len(DataField) Then mDataField = DataField 54 | Set SetDataSource = New_c.DataSource 55 | SetDataSource.Init CollectionOrRecordset, Key, Cairo.DataSourceDispatcher 56 | Set DataSource = SetDataSource 57 | End Function 58 | 59 | Public Property Get DataSourceKey() As String 60 | DataSourceKey = mDataSourceKey 61 | End Property 62 | Public Property Let DataSourceKey(ByVal NewValue As String) 63 | mDataSourceKey = NewValue 64 | On Error Resume Next 65 | Set DataSource = Cairo.DataSources(mDataSourceKey) 66 | On Error GoTo 0 67 | End Property 68 | 69 | Public Property Get DataSource() As cDataSource 70 | Set DataSource = mDS 71 | End Property 72 | Public Property Set DataSource(DS As cDataSource) 73 | DropDown.Caption = "" 74 | VList.ListCount = 0 75 | Set mDS = DS 76 | If mDS Is Nothing Then Exit Property 77 | mDataSourceKey = mDS.Key 78 | VList.ListCount = mDS.RecordCount 79 | If mDS.RecordCount Then mDS.MoveFirst: mDS.MovePrevious 80 | End Property 81 | 82 | Public Property Get DataField() As String 83 | DataField = mDataField 84 | End Property 85 | Public Property Let DataField(ByVal NewValue As String) 86 | mDataField = NewValue 87 | End Property 88 | Private Property Get FieldIndex() As Long 89 | Dim i As Long 90 | If mDS Is Nothing Then Exit Property 91 | For i = 0 To mDS.FieldCount - 1 92 | If StrComp(mDS.FieldName(i), mDataField, vbTextCompare) = 0 Then FieldIndex = i: Exit For 93 | Next i 94 | End Property 95 | 96 | Private Sub mDS_Move(ByVal NewRowIdxZeroBased As Long) 97 | If VList.ListIndex <> NewRowIdxZeroBased Then VList.ListIndex = NewRowIdxZeroBased 98 | End Sub 99 | Private Sub mDS_NewDataContentArrived() 100 | VList.ListCount = mDS.RecordCount 101 | End Sub 102 | '***************** End of typical-DataSource-related Procedures *************** 103 | 104 | Public Property Get Text() As String 105 | Text = DropDown.Text 106 | End Property 107 | 108 | Public Property Get ListIndex() As Long 109 | ListIndex = VList.ListIndex 110 | End Property 111 | Public Property Let ListIndex(ByVal NewValue As Long) 112 | VList.ListIndex = NewValue 113 | End Property 114 | 115 | Public Property Get ListCount() As Long 116 | If mDS Is Nothing Then Exit Sub 117 | ListCount = mDS.Count 118 | End Property 119 | 120 | Private Sub DropDown_PopupWidgetRequest(WidgetInstance As Object, WidthPxl As Single, HeightPxl As Single) 121 | Set WidgetInstance = VList 122 | W.Tag = VList.ListIndex 123 | If VList.ListCount Then HeightPxl = (VList.ListCount * VList.RowHeight + 4) * W.Zoom 124 | If HeightPxl = 0 Or HeightPxl > 200 * W.Zoom Then HeightPxl = 200 * W.Zoom 125 | End Sub 126 | Private Sub DropDown_PopupEscapeKeyPressed(DestroyPopup As Boolean) 127 | VList.ListIndex = W.Tag 128 | End Sub 129 | Private Sub DropDown_PopupReturnKeyPressed(DestroyPopup As Boolean) 130 | DropDown.DestroyPopup 131 | End Sub 132 | 133 | Private Sub VList_Click() 134 | Dim DoRaise As Boolean 135 | If mDS Is Nothing Then Exit Sub 136 | 137 | If mDS.RecordCount > 0 Then 138 | If VList.ListIndex = -1 And mDS.AbsolutePosition > 0 Then 139 | mDS.MoveFirst 140 | mDS.MovePrevious 'ensure BOF-Position 141 | DoRaise = True 142 | ElseIf VList.ListIndex <> -1 And mDS.AbsolutePosition <> VList.ListIndex + 1 Then 143 | mDS.AbsolutePosition = VList.ListIndex + 1 144 | DoRaise = True 145 | End If 146 | End If 147 | If mDS.AbsolutePosition > 0 Then DropDown.Caption = mDS.FieldValue(FieldIndex) Else DropDown.Caption = "" 148 | If DoRaise Then 149 | RaiseEvent Click 150 | W.RaiseBubblingEvent Me, "Click" 151 | End If 152 | End Sub 153 | Private Sub VList_MouseUpClick() 154 | DropDown.DestroyPopup 155 | End Sub 156 | Private Sub VList_OwnerDrawItem(ByVal Index As Long, CC As vbRichClient5.cCairoContext, ByVal dx As Single, ByVal dy As Single, ByVal Alpha As Single) 157 | If mDS Is Nothing Then Exit Sub 158 | If Index >= mDS.RecordCount Then Exit Sub 159 | CC.DrawText 2, 0, dx - 2, dy, CStr(mDS.ValueMatrix(Index, FieldIndex)), True, vbLeftJustify, 3, True 160 | End Sub 161 | 162 | Private Sub W_KeyDown(KeyCode As Integer, Shift As Integer) 163 | If DropDown.Btn.Value Then Exit Sub 'early exit in case the DropDown is shown (to avoid double-KeyHandling here) 164 | Select Case KeyCode 165 | Case vbKeyLeft, vbKeyUp: If ListIndex > 0 Then ListIndex = ListIndex - 1 166 | Case vbKeyRight, vbKeyDown: If ListIndex < ListCount - 1 Then ListIndex = ListIndex + 1 167 | End Select 168 | End Sub 169 | 170 | Private Sub W_MouseWheel(ByVal MouseKeys As Long, ByVal Rotation As Long, ByVal LineOffset As Long, ByVal xAbs As Single, ByVal yAbs As Single) 171 | If DropDown.PopupWidget Is Nothing And VList.ListCount > 0 And W.Enabled Then 172 | Dim NewIndex: NewIndex = VList.ListIndex + LineOffset 173 | If NewIndex < 0 Then NewIndex = 0 Else If NewIndex >= VList.ListCount Then NewIndex = VList.ListCount - 1 174 | VList.ListIndex = NewIndex 175 | End If 176 | End Sub 177 | -------------------------------------------------------------------------------- /cwFileList.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "cwFileList" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Option Explicit 15 | 16 | Event Click() 17 | Event MouseUpClick() 18 | Event MouseMoveOnListItem(ByVal HoverIndex As Long, ByVal RelX As Single, ByVal RelY As Single) 19 | 20 | Public WithEvents VList As cwVList 'we inherit visually from a preimplemented Widget 21 | Attribute VList.VB_VarHelpID = -1 22 | 23 | Private mDirList As cDirList 24 | Private mPattern As String, mSortMode As DirListSortMode 25 | Private mHidden As Boolean, mSystem As Boolean, mLastKeyCode As Integer, mLastIndex As Integer 26 | 27 | Private WithEvents W As cWidgetBase 28 | Attribute W.VB_VarHelpID = -1 29 | 30 | Private Sub Class_Initialize() 31 | Set mDirList = New_c.FSO.GetDirList(App.Path, dlSortByNameLogically, mPattern, mHidden, mSystem) 32 | 33 | Set VList = New cwVList 'the Widget-Instance, to inherit from 34 | VList.RowHeight = 19 35 | VList.ListCount = mDirList.FilesCount 36 | 37 | 'the following is some kind of "visual inheritance", since we use the already existent 'W' 38 | 'from the VList, instead of creating our own, new 'W' per: Set W = Cairo.WidgetBase 39 | Set W = VList.Widget 40 | End Sub 41 | Public Property Get Widget() As cWidgetBase 42 | Set Widget = W 43 | End Property 44 | Public Property Get Widgets() As cWidgets 45 | Set Widgets = W.Widgets 46 | End Property 47 | 48 | '*** Public Properties **** 49 | Public Property Get DirList() As cDirList 50 | Set DirList = mDirList 51 | End Property 52 | 53 | Public Property Get Path() As String 54 | Path = mDirList.Path 55 | End Property 56 | Public Property Let Path(ByVal NewValue As String) 57 | mLastKeyCode = 0: mLastIndex = 0 58 | If Right$(NewValue, 1) <> "\" Then NewValue = NewValue & "\" 59 | Set mDirList = New_c.FSO.GetDirList(NewValue, mSortMode, mPattern, mHidden, mSystem) 60 | VList.ListCount = mDirList.FilesCount 61 | W.Refresh 62 | End Property 63 | 64 | Public Property Get Pattern() As String 65 | Pattern = mPattern 66 | End Property 67 | Public Property Let Pattern(ByVal NewValue As String) 68 | If mPattern = NewValue Then Exit Property Else mPattern = NewValue: ReScan 69 | End Property 70 | 71 | Public Property Get SortMode() As DirListSortMode 72 | SortMode = mSortMode 73 | End Property 74 | Public Property Let SortMode(ByVal NewValue As DirListSortMode) 75 | If mSortMode = NewValue Then Exit Property Else mSortMode = NewValue: ReScan 76 | End Property 77 | 78 | Public Property Get Hidden() As Boolean 79 | Hidden = mHidden 80 | End Property 81 | Public Property Let Hidden(ByVal NewValue As Boolean) 82 | If mHidden = NewValue Then Exit Property Else mHidden = NewValue: ReScan 83 | End Property 84 | 85 | Public Property Get System() As Boolean 86 | System = mSystem 87 | End Property 88 | Public Property Let System(ByVal NewValue As Boolean) 89 | If mSystem = NewValue Then Exit Property Else mSystem = NewValue: ReScan 90 | End Property 91 | 92 | Public Sub ReScan() 93 | Path = mDirList.Path 94 | End Sub 95 | 96 | Public Property Get ListCount() As Long 97 | ListCount = VList.ListCount 98 | End Property 99 | Public Property Let ListCount(ByVal NewValue As Long) 100 | VList.ListCount = NewValue 101 | End Property 102 | 103 | Public Property Get ListIndex() As Long 104 | ListIndex = VList.ListIndex 105 | End Property 106 | Public Property Let ListIndex(ByVal NewValue As Long) 107 | VList.ListIndex = NewValue 108 | End Property 109 | 110 | Public Property Get FileName() As String 111 | If VList.ListIndex < 0 Then Exit Property 112 | FileName = mDirList.FileName(VList.ListIndex) 113 | End Property 114 | 115 | Public Property Get PathAndFileName() As String 116 | If VList.ListIndex < 0 Then Exit Property 117 | PathAndFileName = mDirList.Path & mDirList.FileName(VList.ListIndex) 118 | End Property 119 | 120 | Private Sub VList_Click() 121 | RaiseEvent Click 122 | W.RaiseBubblingEvent Me, "Click" 123 | End Sub 124 | 125 | Private Sub VList_MouseMoveOnListItem(ByVal HoverIndex As Long, ByVal RelX As Single, ByVal RelY As Single) 126 | RaiseEvent MouseMoveOnListItem(HoverIndex, RelX, RelY) 127 | End Sub 128 | 129 | Private Sub VList_MouseUpClick() 130 | RaiseEvent MouseUpClick 131 | W.RaiseBubblingEvent Me, "MouseUpClick" 132 | End Sub 133 | 134 | Private Sub VList_OwnerDrawItem(ByVal Index As Long, CC As cCairoContext, ByVal dx As Single, ByVal dy As Single, ByVal Alpha As Single) 135 | Dim Srf As cCairoSurface, FntSize As Double, FntOffs As Single, IcoOffs As Single 136 | Const IcoSize As Single = 16 137 | If Index >= mDirList.FilesCount Then Exit Sub 138 | 139 | FntSize = CC.GetFontHeight 140 | FntOffs = Int((dy - FntSize) / 2) 141 | IcoOffs = Int((dy - IcoSize) / 2) 142 | 143 | Set Srf = New_c.FSO.GetFileIconSurface(mDirList.Path & mDirList.FileName(Index), False, IconSmall, IconNormal) 144 | CC.RenderSurfaceContent Srf, 1 + IcoOffs, IcoOffs, IcoSize, IcoSize, CAIRO_FILTER_GAUSSIAN 145 | CC.TextOut 1 + IcoOffs + dy, FntOffs, mDirList.FileName(Index) 146 | End Sub 147 | 148 | Private Sub W_KeyUp(KeyCode As Integer, Shift As Integer) 149 | If KeyCode > 0 And KeyCode <= 40 Then Exit Sub 150 | Dim Index As Long, WChar As String 151 | Index = FindIndex(KeyCode, IIf(mLastKeyCode = KeyCode, mLastIndex + 1, 0), WChar) 152 | If mLastKeyCode = KeyCode And WChar <> ChrW$(KeyCode) Then Index = FindIndex(KeyCode, 0, WChar) 153 | 154 | If Index < mDirList.FilesCount Then 155 | mLastKeyCode = KeyCode 156 | mLastIndex = Index 157 | VList.ClearSelections Index 158 | W.Refresh 159 | End If 160 | End Sub 161 | 162 | Private Function FindIndex(KeyCode As Integer, StartIdx As Long, WChar As String) As Long 163 | For FindIndex = StartIdx To mDirList.FilesCount - 1 164 | WChar = UCase$(Left$(mDirList.FileName(FindIndex), 1)) 165 | If WChar >= ChrW$(KeyCode) Then Exit For 166 | Next 167 | End Function 168 | -------------------------------------------------------------------------------- /cwFormButtons.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "cwFormButtons" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Option Explicit 15 | 16 | Private Alpha As Single, dx As Single, dy As Single 17 | 18 | Private WithEvents W As cWidgetBase 19 | Attribute W.VB_VarHelpID = -1 20 | 21 | Private Sub Class_Initialize() 22 | Set W = Cairo.WidgetBase 23 | W.CanGetFocus = False 24 | W.Move 0, 0, 70, 18 25 | End Sub 26 | Public Property Get Widget() As cWidgetBase 27 | Set Widget = W 28 | End Property 29 | Public Property Get Widgets() As cWidgets 30 | Set Widgets = W.Widgets 31 | End Property 32 | 33 | Private Sub W_Paint(CC As cCairoContext, ByVal xAbs As Single, ByVal yAbs As Single, ByVal dx_Aligned As Single, ByVal dy_Aligned As Single, UserObj As Object) 34 | dx = dx_Aligned 35 | dy = dy_Aligned 36 | Alpha = W.AlphaInherited 37 | Draw CC 38 | End Sub 39 | 40 | Private Sub Draw(CC As cCairoContext) 41 | Dim Pat As cCairoPattern 42 | ' Set Pat = Cairo.CreateLinearPattern(0, 0, 0, dy) 43 | ' Pat.AddColorStop 0, W.BackColor, Alpha, 1.1 44 | ' Pat.AddColorStop 1, W.BackColor, Alpha, 0.9 45 | ' CC.Rectangle 0, 0, dx, dy - 1, True 46 | ' CC.Fill , Pat 47 | ' 48 | ' CC.SetLineWidth 1, True 49 | ' CC.SetLineCap CAIRO_LINE_CAP_SQUARE 50 | ' CC.SetSourceColor W.BorderColor 51 | ' CC.DrawLine 0, dy - 1, dx, dy - 1, True 52 | ' CC.Stroke 53 | 54 | End Sub 55 | 56 | -------------------------------------------------------------------------------- /cwFrame.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "cwFrame" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Option Explicit 15 | 16 | Private dx As Single, dy As Single, Alpha As Single 17 | Private mCaption As String, mCaptionHeight As Single 18 | Private mBorderRadius As Single, mBorderWidth As Single 19 | 20 | Public UserdefinedHovering As Boolean, RoundedTopOnly As Boolean 21 | Public OnActivateMoveToFront As Boolean 22 | 23 | Private WithEvents W As cWidgetBase 24 | Attribute W.VB_VarHelpID = -1 25 | Public Property Get Widget() As cWidgetBase 26 | Set Widget = W 27 | End Property 28 | Public Property Get Widgets() As cWidgets 29 | Set Widgets = W.Widgets 30 | End Property 31 | 32 | Private Sub Class_Initialize() 33 | mBorderRadius = 4 34 | mBorderWidth = 1 35 | Set W = Cairo.WidgetBase 36 | W.SetClientAreaOffsets mBorderWidth, mBorderWidth, mBorderWidth, mBorderWidth 37 | End Sub 38 | 39 | Private Sub W_EnterFocus() 40 | If OnActivateMoveToFront Then 41 | W.MoveToFront 42 | W.Refresh 43 | 'W.SetFocus 44 | End If 45 | End Sub 46 | 47 | Private Sub W_Paint(CC As cCairoContext, ByVal xAbs As Single, ByVal yAbs As Single, ByVal dx_Aligned As Single, ByVal dy_Aligned As Single, UserObj As Object) 48 | Alpha = W.AlphaInherited 49 | dx = dx_Aligned 50 | dy = dy_Aligned 51 | Draw CC 52 | End Sub 53 | 54 | Private Sub Draw(CC As cCairoContext) 55 | Dim Pat As cCairoPattern, BColor As Long, BWHalf As Single, LWAlign As Single, Zoom As Single 56 | Dim TextWidth As Single, FontHeight As Double, yy As Single, dyy As Single 57 | 58 | BWHalf = mBorderWidth / 2 59 | Zoom = W.Zoom 60 | 'first we determine the Caption-Extents (if there is one) 61 | If Len(mCaption) Then 62 | W.SelectFontSettingsInto CC 63 | TextWidth = CC.GetTextExtents(mCaption, FontHeight) 64 | End If 65 | 66 | BColor = W.BorderColor 67 | If W.Active And Me.OnActivateMoveToFront Then BColor = W.FocusColor 68 | If W.Focused Then BColor = W.FocusColor 69 | 70 | 71 | 72 | 'now the Outline, the layout depending on, if we have a caption or not 73 | If Len(mCaption) = 0 Or mCaptionHeight <> 0 Then 'completely "closed" Outline 74 | CC.SetSourceColor BColor, Alpha 75 | CC.SetLineWidth mBorderWidth, True 76 | 77 | If RoundedTopOnly Then 78 | CC.RoundedRect 0, 0, dx, dy, mBorderRadius, True, cmTop 79 | Else 80 | CC.RoundedRect 0, 0, dx, dy, mBorderRadius, True, cmAll 81 | End If 82 | CC.Stroke 83 | 84 | ElseIf Len(mCaption) Then 'leave room for the caption 85 | CC.SetSourceColor BColor, Alpha 86 | 87 | CC.SetLineWidth mBorderWidth, True 88 | yy = CLng(FontHeight * 0.5 * W.Zoom) / W.Zoom 89 | dyy = CLng((dy - yy - 1) * W.Zoom) / W.Zoom 90 | LWAlign = CC.GetLineWidth 91 | 92 | 'Now we draw only the Corners first (without the lines) and then the lines between Corners 93 | If RoundedTopOnly Then 94 | If mBorderRadius > 0 Then CC.RoundedRect 0, yy, dx, dyy, mBorderRadius, True, cmTop, True 95 | 'now the lines between the Corners 96 | DrawAlignedLine CC, dx - LWAlign, yy + mBorderRadius, dx - LWAlign, yy + dyy - LWAlign, Zoom 97 | DrawAlignedLine CC, dx - LWAlign, yy + dyy - LWAlign, 0, yy + dyy - LWAlign, Zoom 98 | DrawAlignedLine CC, 0, yy + dyy - LWAlign, 0, yy + BorderRadius, Zoom 99 | Else 100 | If mBorderRadius > 0 Then CC.RoundedRect 0, yy, dx, dyy, mBorderRadius, True, cmAll, True 101 | 'now the lines between the Corners 102 | DrawAlignedLine CC, dx - LWAlign, yy + mBorderRadius, dx - LWAlign, yy + dyy - mBorderRadius - LWAlign, Zoom 103 | DrawAlignedLine CC, dx - LWAlign - mBorderRadius, yy + dyy - LWAlign, mBorderRadius, yy + dyy - LWAlign, Zoom 104 | DrawAlignedLine CC, 0, yy + dyy - LWAlign - mBorderRadius, 0, yy + BorderRadius, Zoom 105 | End If 106 | DrawAlignedLine CC, mBorderRadius, yy, mBorderRadius + 2, yy, Zoom 107 | DrawAlignedLine CC, 5 + mBorderRadius + TextWidth + 2, yy, dx - mBorderRadius - LWAlign, yy, Zoom 108 | 109 | CC.Stroke 110 | 111 | End If 112 | 113 | If mCaptionHeight = 0 Then 'fill BackGround completely 114 | If W.BackColor <> -1 Then 115 | CC.SetSourceColor W.BackColor, Alpha 116 | CC.SetLineWidth mBorderWidth + mBorderWidth 117 | If Len(Caption) Then 118 | W.SetClientAreaOffsets mBorderWidth, mBorderWidth + yy, mBorderWidth, mBorderWidth 119 | CC.RoundedRect 0, yy, dx, dyy, mBorderRadius, True 120 | Else 121 | W.SetClientAreaOffsets mBorderWidth, mBorderWidth, mBorderWidth, mBorderWidth 122 | CC.RoundedRect 0, 0, dx, dy, mBorderRadius, True 123 | End If 124 | CC.Fill 125 | End If 126 | 127 | CC.TextOut 5 + mBorderRadius, 0, mCaption '<-Cairo-text is always rendered at the BaseLine 128 | 129 | Else 'draw a caption first, followed by the normal BackGround-Fill of the rest 130 | 'the caption-bar 131 | Set Pat = Cairo.CreateLinearPattern(0, 0, 0, mCaptionHeight + mBorderWidth) 132 | Pat.AddColorStop 0, W.ForeColor, Alpha, 1.25 133 | Pat.AddColorStop 0.2, W.ForeColor, Alpha, 0.9 134 | Pat.AddColorStop 0.88, W.ForeColor, Alpha, 1.05 135 | Pat.AddColorStop 1, W.ForeColor, Alpha, 0.7 136 | 137 | CC.RoundedRect BWHalf, BWHalf, dx - mBorderWidth, mCaptionHeight + mBorderWidth, mBorderRadius - 1, True, cmTop 138 | CC.Fill , Pat 139 | 140 | 'now render the caption-string vertically centered 141 | CC.TextOut 6, mBorderWidth + (mCaptionHeight - FontHeight) * 0.5, mCaption '<-Cairo-text is always rendered at the BaseLine 142 | 143 | If W.BackColor <> -1 Then 'and the rest of the filling in BackColor, following the caption 144 | CC.SetSourceColor W.BackColor, Alpha 145 | CC.SetLineWidth mBorderWidth + mBorderWidth 146 | If RoundedTopOnly Then 147 | CC.RoundedRect 0, mCaptionHeight - 0.1, dx, dy - mCaptionHeight + 0.2, mBorderRadius, True, cmNone 148 | Else 149 | CC.RoundedRect 0, mCaptionHeight - 0.1, dx, dy - mCaptionHeight + 0.2, mBorderRadius, True, cmBottom 150 | End If 151 | CC.Fill 152 | End If 153 | End If 154 | End Sub 155 | 156 | Private Sub DrawAlignedLine(CC As cCairoContext, ByVal x1!, ByVal y1!, ByVal x2!, ByVal y2!, ByVal ZoomFac As Single) 157 | x1 = CLng(x1 * ZoomFac) / ZoomFac 158 | y1 = CLng(y1 * ZoomFac) / ZoomFac 159 | x2 = CLng(x2 * ZoomFac) / ZoomFac 160 | y2 = CLng(y2 * ZoomFac) / ZoomFac 161 | 162 | CC.DrawLine x1, y1, x2, y2, True 163 | End Sub 164 | 165 | Public Property Get Caption$() 166 | Caption = mCaption 167 | End Property 168 | Public Property Let Caption(ByVal NewVal$) 169 | mCaption = NewVal 170 | W.Refresh 171 | End Property 172 | 173 | Public Property Get CaptionColor&() 174 | CaptionColor = W.ForeColor 175 | End Property 176 | Public Property Let CaptionColor(ByVal NewVal&) 177 | W.ForeColor = NewVal 178 | End Property 179 | 180 | Public Property Get BorderWidth() As Single 181 | BorderWidth = mBorderWidth 182 | End Property 183 | Public Property Let BorderWidth(ByVal NewVal As Single) 184 | If NewVal > 10 Then NewVal = 10 185 | If NewVal < 0.01 Then NewVal = 0.01 186 | If NewVal = mBorderWidth Then Exit Property 187 | mBorderWidth = NewVal 188 | W.SetClientAreaOffsets mBorderWidth, mBorderWidth + mCaptionHeight, mBorderWidth, mBorderWidth 189 | End Property 190 | 191 | Public Property Get CaptionHeight() As Single 192 | CaptionHeight = mCaptionHeight 193 | End Property 194 | Public Property Let CaptionHeight(ByVal NewVal As Single) 195 | If NewVal > 50 Then NewVal = 50 196 | If NewVal < 0 Then NewVal = 0 197 | If NewVal = mCaptionHeight Then Exit Property 198 | mCaptionHeight = NewVal 199 | W.SetClientAreaOffsets mBorderWidth, mBorderWidth + mCaptionHeight, mBorderWidth, mBorderWidth 200 | End Property 201 | 202 | Public Property Get BorderRadius() As Single 203 | BorderRadius = mBorderRadius 204 | End Property 205 | Public Property Let BorderRadius(ByVal NewVal As Single) 206 | If NewVal > 100 Then NewVal = 100 207 | If NewVal < 0 Then NewVal = 0 208 | If NewVal = mBorderRadius Then Exit Property 209 | mBorderRadius = NewVal 210 | End Property 211 | 212 | -------------------------------------------------------------------------------- /cwGlowButton.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "cwGlowButton" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Option Explicit 15 | 16 | Public BlendInSteps As Long, BlendOutSteps As Long 17 | 18 | '--------- default Widget-conventions for a "cwClass", as usual -------- 19 | Private Alpha As Single, dx As Single, dy As Single 20 | Private ResHeightPerEntry As Long 21 | 22 | Private WithEvents W As cWidgetBase 23 | Attribute W.VB_VarHelpID = -1 24 | Private WithEvents tmrBlend As cTimer, BlAlpha As Double, Pressed As Boolean 25 | Attribute tmrBlend.VB_VarHelpID = -1 26 | Private mCaption As String, mChecked As Boolean 27 | 28 | Private Sub Class_Initialize() 29 | Set W = Cairo.WidgetBase 30 | 31 | BlendInSteps = 15 32 | BlendOutSteps = 30 33 | End Sub 34 | Public Property Get Widget() As cWidgetBase 35 | Set Widget = W 36 | End Property 37 | Public Property Get Widgets() As cWidgets 38 | Set Widgets = W.Widgets 39 | End Property 40 | '--------- end of default Widget-conventions ----------- 41 | 42 | Public Property Get Checked() As Boolean 43 | Checked = mChecked 44 | End Property 45 | Public Property Let Checked(ByVal NewValue As Boolean) 46 | If mChecked = NewValue Then Exit Property 47 | mChecked = NewValue 48 | W.Refresh 49 | End Property 50 | 51 | Public Property Get Caption() As String 52 | Caption = mCaption 53 | End Property 54 | Public Property Let Caption(ByVal NewValue As String) 55 | If mCaption = NewValue Then Exit Property 56 | mCaption = NewValue 57 | W.Refresh 58 | End Property 59 | 60 | Private Sub tmrBlend_Timer() 61 | Select Case tmrBlend.Tag 62 | Case "MouseEnter" 63 | If BlendInSteps Then BlAlpha = BlAlpha + 1 / BlendInSteps Else BlAlpha = 1.1 64 | Case "MouseLeave" 65 | If BlendOutSteps Then BlAlpha = BlAlpha - 1 / BlendOutSteps Else BlAlpha = -0.1 66 | End Select 67 | If BlAlpha < 0 Or BlAlpha > 1 Then Set tmrBlend = Nothing: Exit Sub 68 | W.Refresh 69 | End Sub 70 | 71 | Private Sub W_AddedToHierarchy() 72 | With Cairo.ImageList(W.ImageKey) 73 | ResHeightPerEntry = .Height \ 6 74 | W.Move W.Left, W.Top, .Width, ResHeightPerEntry 75 | End With 76 | End Sub 77 | 78 | Private Sub W_MouseDown(Button As Integer, Shift As Integer, ByVal x As Single, ByVal y As Single) 79 | Pressed = True 80 | W.Refresh 81 | End Sub 82 | Private Sub W_MouseMove(Button As Integer, Shift As Integer, ByVal x As Single, ByVal y As Single) 83 | W.MouseIconImageKey = IIf(W.Enabled, "cur_hand,17,9", "cur_unavailable,8,8") 84 | End Sub 85 | Private Sub W_MouseUp(Button As Integer, Shift As Integer, ByVal x As Single, ByVal y As Single) 86 | Pressed = False 87 | W.Refresh 88 | End Sub 89 | 90 | Private Sub W_MouseEnter(ByVal MouseLeaveWidget As cWidgetBase) 91 | If BlAlpha < 0 Then BlAlpha = 0 92 | If W.Enabled Then Set tmrBlend = New_c.Timer(15, True, "MouseEnter") 93 | End Sub 94 | Private Sub W_MouseLeave(ByVal MouseEnterWidget As cWidgetBase) 95 | If BlAlpha > 1 Then BlAlpha = 1 96 | If W.Enabled Then Set tmrBlend = New_c.Timer(15, True, "MouseLeave") 97 | End Sub 98 | 99 | Private Sub W_Paint(CC As cCairoContext, ByVal xAbs As Single, ByVal yAbs As Single, ByVal dx_Aligned As Single, ByVal dy_Aligned As Single, UserObj As Object) 100 | dx = dx_Aligned 101 | dy = dy_Aligned 102 | Alpha = W.AlphaInherited 103 | Draw CC 104 | End Sub 105 | 106 | Private Sub Draw(CC As cCairoContext) 107 | Dim Pat As cCairoPattern, M As cCairoMatrix, TOffs As Long 108 | 109 | Set Pat = Cairo.CreateSurfacePattern(Cairo.ImageList(W.ImageKey)) 110 | If ResHeightPerEntry = 0 Then ResHeightPerEntry = Pat.Surface.Height \ 6 111 | Set M = Cairo.CreateIdentityMatrix 112 | 113 | If W.Enabled Then 114 | Set Pat.Matrix = M.TranslateCoords(0, ResHeightPerEntry * IIf((Pressed And W.MouseOver) Or mChecked, 2, 0)) 115 | CC.Paint Alpha, Pat 116 | 117 | Set Pat.Matrix = M.TranslateCoords(0, ResHeightPerEntry) 'one additional shift when hovered (this translate adds to the one above) 118 | If BlAlpha > 0 Then CC.Paint Alpha * BlAlpha, Pat 119 | 120 | If W.Focused Then 121 | Set Pat.Matrix = M.TranslateCoords(0, ResHeightPerEntry * IIf((Pressed And W.MouseOver) Or mChecked, 2, 4)) 122 | CC.Paint 1, Pat 123 | End If 124 | Else 'and the disabled state sits at last position 5 (at offset Pat.Surface.Height * 0.8) 125 | 126 | Set Pat.Matrix = M.TranslateCoords(0, ResHeightPerEntry * 4) 127 | CC.Paint Alpha, Pat 128 | End If 129 | 130 | If Len(mCaption) Then 131 | W.SelectFontSettingsInto CC 132 | TOffs = IIf(Pressed Or mChecked, 1, 0) 133 | CC.DrawText -1 + TOffs, 0 + TOffs, dx, dy, mCaption, True, vbCenter, 0, True 134 | End If 135 | End Sub 136 | 137 | -------------------------------------------------------------------------------- /cwGrid.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "cwGrid" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Option Explicit 15 | 16 | Event Click() 17 | Event Validate(ByVal NewRowIdx As Long, ByVal NewColIdx As Long, ByVal OldRowIdx As Long, ByVal OldColIdx As Long, ByVal EditBox As cwTextBox, Cancel As Boolean) 18 | Event HeaderClick(ByVal ColIdx As Long, State As ColumnSortState) 19 | Event DataSourceAddNew() 20 | Event DataSourceDelete() 21 | Event DataSourcePositionChanged() 22 | 23 | Public WithEvents VList As cwVList 'we inherit visually from a preimplemented Widget 24 | Attribute VList.VB_VarHelpID = -1 25 | Private WithEvents W As cWidgetBase, WithEvents mDS As cDataSource, mDataSourceKey As String, WithEvents tmrPosChanged As cTimer 26 | Attribute W.VB_VarHelpID = -1 27 | Attribute mDS.VB_VarHelpID = -1 28 | Attribute tmrPosChanged.VB_VarHelpID = -1 29 | 30 | Private mAllowEdit As Boolean, mAllowAddNew As Boolean, mAllowDelete As Boolean 31 | 32 | Private Sub Class_Initialize() 33 | Set VList = New cwVList 34 | VList.ListCount = 100 35 | VList.HeaderHeight = 24 36 | VList.RowSelectorWidth = 24 37 | VList.RowHeight = 19 38 | VList.ShowHoverBar = False 39 | 40 | Set W = VList.Widget 41 | W.RuntimePropertiesCommaSeparated = "ColumnIndex,ColumnCount,ColumnWidth,RowIndex" 42 | ' W.BackColor = -1 43 | ' W.Alpha = 0.7 44 | End Sub 45 | 46 | Public Property Get Widget() As cWidgetBase 47 | Set Widget = W 48 | End Property 49 | Public Property Get Widgets() As cWidgets 50 | Set Widgets = W.Widgets 51 | End Property 52 | 53 | '*** Public Properties **** 54 | Public Property Get HeaderHeight() As Long 55 | HeaderHeight = VList.HeaderHeight 56 | End Property 57 | Public Property Let HeaderHeight(ByVal NewValue As Long) 58 | VList.HeaderHeight = NewValue 59 | End Property 60 | 61 | Public Property Get MultiSelect() As MultiSelectConstants 62 | MultiSelect = VList.MultiSelect 63 | End Property 64 | Public Property Let MultiSelect(ByVal NewValue As MultiSelectConstants) 65 | VList.MultiSelect = NewValue 66 | End Property 67 | 68 | Public Property Get ColumnIndex() As Long 69 | ColumnIndex = VList.ColumnIndex 70 | End Property 71 | Public Property Let ColumnIndex(ByVal NewValue As Long) 72 | VList.ColumnIndex = NewValue 73 | End Property 74 | 75 | Public Property Get ColumnCount() As Long 76 | ColumnCount = VList.ColumnCount 77 | End Property 78 | Public Property Let ColumnCount(ByVal NewValue As Long) 79 | VList.ColumnCount = NewValue 80 | End Property 81 | 82 | Public Property Get ColumnDefaultWidth() As Integer 83 | ColumnDefaultWidth = VList.ColumnDefaultWidth 84 | End Property 85 | Public Property Let ColumnDefaultWidth(ByVal NewValue As Integer) 86 | VList.ColumnDefaultWidth = NewValue 87 | End Property 88 | 89 | Public Property Get ColumnWidth(ByVal Idx As Long) As Integer 90 | ColumnWidth = VList.ColumnWidth(Idx) 91 | End Property 92 | Public Property Let ColumnWidth(ByVal Idx As Long, ByVal NewValue As Integer) 93 | VList.ColumnWidth(Idx) = NewValue 94 | End Property 95 | 96 | Public Function VisibleCols() As Long 97 | VisibleCols = VList.VisibleCols 98 | End Function 99 | 100 | Public Sub MoveColumnToNewIndex(ByVal CurColIdx As Long, ByVal NewColIdx As Long) 101 | VList.MoveColumnToNewIndex CurColIdx, NewColIdx 102 | End Sub 103 | 104 | Public Property Get RowIndex() As Long 105 | RowIndex = VList.ListIndex 106 | End Property 107 | 108 | Public Property Get AllowColResize() As Boolean 109 | AllowColResize = VList.AllowColResize 110 | End Property 111 | Public Property Let AllowColResize(ByVal NewVal As Boolean) 112 | VList.AllowColResize = NewVal 113 | End Property 114 | 115 | Public Property Get AllowRowResize() As Boolean 116 | AllowRowResize = VList.AllowRowResize 117 | End Property 118 | Public Property Let AllowRowResize(ByVal NewVal As Boolean) 119 | VList.AllowRowResize = NewVal 120 | End Property 121 | 122 | Public Property Get AllowEdit() As Boolean 123 | AllowEdit = mAllowEdit 124 | End Property 125 | Public Property Let AllowEdit(ByVal NewVal As Boolean) 126 | mAllowEdit = NewVal 127 | End Property 128 | 129 | Public Property Get AllowAddNew() As Boolean 130 | AllowAddNew = mAllowAddNew 131 | End Property 132 | Public Property Let AllowAddNew(ByVal NewVal As Boolean) 133 | If mAllowAddNew = NewVal Then Exit Property 134 | mAllowAddNew = NewVal 135 | W.Refresh 136 | End Property 137 | 138 | Public Property Get AllowDelete() As Boolean 139 | AllowDelete = mAllowDelete 140 | End Property 141 | Public Property Let AllowDelete(ByVal NewVal As Boolean) 142 | If mAllowDelete = NewVal Then Exit Property 143 | mAllowDelete = NewVal 144 | End Property 145 | 146 | Public Property Get DataSourceKey() As String 147 | DataSourceKey = mDataSourceKey 148 | End Property 149 | Public Property Let DataSourceKey(ByVal NewValue As String) 150 | mDataSourceKey = NewValue 151 | On Error Resume Next 152 | Set DataSource = Cairo.DataSources(mDataSourceKey) 153 | On Error GoTo 0 154 | End Property 155 | 156 | Public Function SetDataSource(CollectionOrRecordset As Object, Key As String) As cDataSource 157 | Set SetDataSource = New_c.DataSource 158 | SetDataSource.Init CollectionOrRecordset, Key, Cairo.DataSourceDispatcher 159 | Set DataSource = SetDataSource 160 | End Function 161 | Public Property Get DataSource() As cDataSource 162 | Set DataSource = mDS 163 | End Property 164 | Public Property Set DataSource(DS As cDataSource) 165 | Dim i&, Cols&, Rows& 166 | If Not DS Is Nothing Then 167 | Rows = DS.RecordCount 168 | Cols = DS.FieldCount 169 | End If 170 | 171 | W.LockRefresh = True 172 | Set mDS = DS 173 | 174 | ResetSortStates 'clear the last Column-Sort-infos 175 | 176 | VList.ListCount = Rows 177 | VList.ColumnCount = 1 178 | VList.ColumnCount = Cols 179 | 180 | If VList.ListIndex <> -1 Then 181 | VList.ListIndex = -1 'the Rs is at BOF after that (no selection) 182 | Else 183 | VList_Click 184 | End If 185 | W.LockRefresh = False 186 | End Property 187 | 188 | Public Sub ResetSortStates() 189 | VList.ResetSortStates 190 | End Sub 191 | 192 | Private Sub mDS_NewDataContentArrived() 193 | VList.ListCount = mDS.RecordCount 194 | End Sub 195 | Private Sub mDS_FieldChange(ByVal RowIdxZeroBased As Long, ByVal ColIdxZeroBased As Long) 196 | W.Refresh 197 | End Sub 198 | Private Sub mDS_AddNew(ByVal NewRowIdxZeroBased As Long) 199 | VList.Widget.LockRefresh = True 200 | VList.ListCount = VList.ListCount + 1 201 | RaiseEvent DataSourceAddNew 202 | W.RaiseBubblingEvent Me, "DataSourceAddNew" 203 | mDS_Move NewRowIdxZeroBased 204 | VList.Widget.LockRefresh = False 205 | End Sub 206 | Private Sub mDS_Move(ByVal NewRowIdxZeroBased As Long) 207 | If VList.ListIndex = NewRowIdxZeroBased Then Exit Sub 208 | VList.ListIndex = NewRowIdxZeroBased 209 | Set tmrPosChanged = New_c.Timer(10, True) 210 | End Sub 211 | Private Sub mDS_Delete(ByVal NewRowIdxZeroBased As Long) 212 | VList.Widget.LockRefresh = True 213 | VList.ListCount = VList.ListCount - 1 214 | VList.ListIndex = NewRowIdxZeroBased 215 | VList.EnsureVisibleSelection 216 | RaiseEvent DataSourceDelete 217 | W.RaiseBubblingEvent Me, "DataSourceDelete" 218 | Set tmrPosChanged = New_c.Timer(10, True) 219 | VList.Widget.LockRefresh = False 220 | End Sub 221 | 222 | Private Sub tmrPosChanged_Timer() 223 | Set tmrPosChanged = Nothing 224 | RaiseEvent DataSourcePositionChanged 225 | W.RaiseBubblingEvent Me, "DataSourcePositionChanged" 226 | End Sub 227 | 228 | Private Sub VList_Click() 229 | Dim DoRaise As Boolean 230 | If Not mDS Is Nothing Then 231 | If mDS.RecordCount > 0 Then 232 | If VList.ListIndex = -1 And mDS.AbsolutePosition > 0 Then 233 | mDS.MoveFirst 234 | mDS.MovePrevious 'ensure BOF-Position 235 | DoRaise = True 236 | ElseIf VList.ListIndex <> -1 And mDS.AbsolutePosition <> VList.ListIndex + 1 Then 237 | mDS.AbsolutePosition = VList.ListIndex + 1 238 | DoRaise = True 239 | End If 240 | End If 241 | End If 242 | If DoRaise Then 243 | RaiseEvent Click 244 | W.RaiseBubblingEvent Me, "Click" 245 | RaiseEvent DataSourcePositionChanged 246 | W.RaiseBubblingEvent Me, "DataSourcePositionChanged" 247 | End If 248 | End Sub 249 | 250 | Private Sub VList_HeaderClick(ByVal ColIdx As Long, State As ColumnSortState) 251 | RaiseEvent HeaderClick(ColIdx, State) 252 | End Sub 253 | 254 | Private Sub VList_OwnerDrawHeader(CC As cCairoContext, ByVal dx As Single, ByVal dy As Single, ByVal Alpha As Single) 255 | Dim i As Long, StartIdx As Long, xx As Double, ww As Long, State As enmThemeDrawingState 256 | Cairo.Theme.DrawTo CC, W, thmTypeButtonFace, State, -1, -2, dx + 3, dy + 3, 1, thmDirectionDown 257 | Cairo.Theme.DrawTo CC, W, thmTypeShine, State, 0, -1, dx, Int((dy + 2) \ 2) - 1, 0, thmDirectionDown 258 | CC.DrawLine 0, dy, dx, dy, True, 1, W.BorderColor, 0.3 259 | 260 | If mDS Is Nothing Then Exit Sub 261 | 262 | If Not VList.HScrollBar Is Nothing Then 263 | If VList.HScrollBar.Widget.Visible Then StartIdx = VList.HScrollBar.Value 264 | End If 265 | 266 | xx = VList.RowSelectorWidth 267 | For i = StartIdx To StartIdx + VisibleCols - 1 268 | ww = VList.ColumnWidth(i) 269 | If ww > 0 Then 270 | If i = StartIdx + VList.VisibleCols - 1 Then ww = dx - xx 271 | Cairo.Theme.DrawTo CC, W, thmTypeSeparatorLine, 0, xx, 0, 1, dy 272 | CC.DrawText xx, 1, ww, dy, mDS.FieldName(VList.ColMapIndex(i)), True, , 4, True 273 | xx = xx + ww 274 | End If 275 | Next i 276 | End Sub 277 | 278 | Private Sub VList_OwnerDrawRowSelector(CC As cCairoContext, ByVal dx As Single, ByVal dy As Single, ByVal Alpha As Single) 279 | Dim i As Long, yy As Double, State As enmThemeDrawingState 280 | State = thmStatePressed 281 | Cairo.Theme.DrawTo CC, W, thmTypeButtonFace, State, -1, -1, dx + 0.5 * dx, dy + 2, 1, thmDirectionLeft 282 | Cairo.Theme.DrawTo CC, W, thmTypeShine, State, 0, 0, dx + dx, dy, 1, thmDirectionLeft 283 | For i = 0 To VList.VisibleRows - 1 284 | yy = yy + VList.RowHeight 285 | Cairo.Theme.DrawTo CC, W, thmTypeSeparatorLine, 0, -dx, yy, dx + dx, 1 286 | Next i 287 | End Sub 288 | 289 | Private Sub VList_OwnerDrawItem(ByVal Index As Long, CC As cCairoContext, ByVal dx As Single, ByVal dy As Single, ByVal Alpha As Single) 290 | Dim i As Long, StartIdx As Long, V, s As String, xx As Double, ww As Long 291 | If mDS Is Nothing Then Exit Sub 292 | 293 | If VList.HScrollBar.Widget.Visible Then StartIdx = VList.HScrollBar.Value 294 | 295 | W.SelectFontSettingsInto CC 296 | xx = 0 297 | For i = StartIdx To StartIdx + VList.VisibleCols - 1 298 | ww = VList.ColumnWidth(i) 299 | If ww > 0 Then 300 | If i = StartIdx + VList.VisibleCols - 1 Then ww = dx - xx 301 | V = mDS.ValueMatrix(Index, VList.ColMapIndex(i)) 302 | Select Case VarType(V) 303 | Case vbByte Or vbArray: s = "" 304 | Case Else: s = V 305 | End Select 306 | 307 | CC.DrawText xx, 0, ww, dy, s, True, vbLeftJustify, 2, True 308 | xx = xx + ww 309 | End If 310 | Next i 311 | End Sub 312 | 313 | Public Property Get RowColor() As Long 314 | RowColor = VList.RowColor 315 | End Property 316 | Public Property Let RowColor(ByVal NewValue As Long) 317 | VList.RowColor = NewValue 318 | End Property 319 | 320 | Public Property Get AlternateRowColor() As Long 321 | AlternateRowColor = VList.AlternateRowColor 322 | End Property 323 | Public Property Let AlternateRowColor(ByVal NewValue As Long) 324 | VList.AlternateRowColor = NewValue 325 | End Property 326 | 327 | -------------------------------------------------------------------------------- /cwLabel.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "cwLabel" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Option Explicit 15 | 16 | Private mCaption As String 17 | Private mWordWrap As Boolean 18 | Private mAlignment As AlignmentConstants, mInnerSpace As Long, mVAlign As Long 19 | Private mBorderWidth As Single, mBorderRadius As Single 20 | Private mTextShadowOffsetX As Single, mTextShadowOffsetY As Single, mTextShadowColor As Long 21 | 22 | Private dx As Single, dy As Single, Alpha As Single 23 | 24 | '****---- Start of cwImplementation-Conventions ----**** 25 | Private WithEvents W As cWidgetBase 26 | Attribute W.VB_VarHelpID = -1 27 | Public Property Get Widget() As cWidgetBase 28 | Set Widget = W 29 | End Property 30 | Public Property Get Widgets() As cWidgets 31 | Set Widgets = W.Widgets 32 | End Property 33 | 34 | Private Sub Class_Initialize() 35 | Set W = Cairo.WidgetBase '<- this is required in each cwImplementation... 36 | W.CanGetFocus = False 37 | mTextShadowColor = -1 '-1 Color-Values are (as always) treated as "no color" 38 | mAlignment = vbLeftJustify 39 | mVAlign = 1 40 | mInnerSpace = 1 '1 Pixel Offset for the Text-Rendering - independent from (and in addition to) the BorderSize) 41 | mBorderWidth = 1 42 | End Sub 43 | '****---- End of cwImplementation-Conventions ----**** 44 | 45 | 46 | 'OK, let's implement our small Label-Widget, starting with its Caption-Property 47 | Public Property Get Caption() As String 48 | Caption = mCaption 49 | End Property 50 | Public Property Let Caption(ByVal NewValue As String) 51 | Dim AccKey$, Pos& 52 | If mCaption = NewValue Then Exit Property Else mCaption = NewValue 53 | W.Refresh 54 | Pos = InStr(Replace(mCaption, "&&", "--"), "&") 55 | If Pos Then AccKey = Mid$(Replace(mCaption, "&&", "--"), Pos + 1, 1) 56 | 57 | If Len(AccKey) Then W.AccessKeys = AccKey 58 | End Property 59 | 60 | Public Property Get Alignment() As AlignmentConstants 61 | Alignment = mAlignment 62 | End Property 63 | Public Property Let Alignment(ByVal NewValue As AlignmentConstants) 64 | If mAlignment = NewValue Then Exit Property 65 | mAlignment = NewValue 66 | W.Refresh 67 | End Property 68 | 69 | Public Property Get VAlign() As Long 70 | VAlign = mVAlign 71 | End Property 72 | Public Property Let VAlign(ByVal NewValue As Long) 73 | If mVAlign = NewValue Then Exit Property 74 | mVAlign = NewValue 75 | W.Refresh 76 | End Property 77 | 78 | Public Property Get BorderWidth() As Single 79 | BorderWidth = mBorderWidth 80 | End Property 81 | Public Property Let BorderWidth(ByVal NewValue As Single) 82 | If NewValue = mBorderWidth Then Exit Property 83 | mBorderWidth = NewValue 84 | W.SetClientAreaOffsets mBorderWidth, mBorderWidth, mBorderWidth, mBorderWidth 85 | W.Refresh 86 | End Property 87 | 88 | Public Property Get BorderRadius() As Single 89 | BorderRadius = mBorderRadius 90 | End Property 91 | Public Property Let BorderRadius(ByVal NewValue As Single) 92 | If mBorderRadius = NewValue Then Exit Property 93 | mBorderRadius = NewValue 94 | W.Refresh 95 | End Property 96 | 97 | Public Property Get InnerSpace() As Long 98 | InnerSpace = mInnerSpace 99 | End Property 100 | Public Property Let InnerSpace(ByVal NewValue As Long) 101 | If mInnerSpace = NewValue Then Exit Property 102 | mInnerSpace = NewValue 103 | W.Refresh 104 | End Property 105 | 106 | Public Property Get WordWrap() As Boolean 107 | WordWrap = mWordWrap 108 | End Property 109 | Public Property Let WordWrap(ByVal NewValue As Boolean) 110 | If mWordWrap = NewValue Then Exit Property 111 | mWordWrap = NewValue 112 | W.Refresh 113 | End Property 114 | 115 | Public Property Get TextShadowOffsetX() As Single 116 | TextShadowOffsetX = mTextShadowOffsetX 117 | End Property 118 | Public Property Let TextShadowOffsetX(ByVal NewValue As Single) 119 | If mTextShadowOffsetX = NewValue Then Exit Property 120 | mTextShadowOffsetX = NewValue 121 | W.Refresh 122 | End Property 123 | Public Property Get TextShadowOffsetY() As Single 124 | TextShadowOffsetY = mTextShadowOffsetY 125 | End Property 126 | Public Property Let TextShadowOffsetY(ByVal NewValue As Single) 127 | If mTextShadowOffsetY = NewValue Then Exit Property 128 | mTextShadowOffsetY = NewValue 129 | W.Refresh 130 | End Property 131 | Public Property Get TextShadowColor() As Long 132 | TextShadowColor = mTextShadowColor 133 | End Property 134 | Public Property Let TextShadowColor(ByVal NewValue As Long) 135 | If mTextShadowColor = NewValue Then Exit Property 136 | mTextShadowColor = NewValue 137 | W.Refresh 138 | End Property 139 | 140 | Private Sub W_AccessKeyPress(KeyAscii As Integer) 141 | Dim NextIndex As Long 142 | If W.Parent Is Nothing Then Exit Sub 143 | NextIndex = W.Parent.Widgets.GetOneBasedChildIndexByKey(W.Key) + 1 144 | If NextIndex <= W.Parent.Widgets.Count Then W.Parent.Widgets(NextIndex).Widget.SetFocus 145 | End Sub 146 | 147 | Private Sub W_Paint(CC As cCairoContext, ByVal xAbs As Single, ByVal yAbs As Single, ByVal dx_Aligned As Single, ByVal dy_Aligned As Single, UserObj As Object) 148 | Alpha = W.AlphaInherited 149 | dx = dx_Aligned 150 | dy = dy_Aligned 151 | Draw CC 152 | End Sub 153 | 154 | Private Sub Draw(CC As cCairoContext) 155 | Dim i& 156 | 157 | If W.BackColor <> -1 Then 'draw a plain solid background 158 | CC.RoundedRect 0, 0, dx, dy, mBorderRadius 159 | CC.SetSourceColor W.BackColor, Alpha 160 | CC.Fill 161 | End If 162 | 163 | If W.BorderColor <> -1 And mBorderWidth > 0 Then 164 | CC.SetLineWidth mBorderWidth, True 165 | Cairo.Theme.DrawTo CC, W, thmTypeBorder, 0, 0, 0, dx, dy, mBorderRadius 166 | End If 167 | 168 | 'and here the Text-Out 169 | W.SelectFontSettingsInto CC 170 | 171 | If mTextShadowColor <> -1 Then 172 | 'note the last Param, which only ensures "a Path" (no Pixel-Rendering yet) 173 | CC.Save 174 | CC.TranslateDrawings mTextShadowOffsetX, mTextShadowOffsetY 175 | CC.TranslateDrawings 0.5, 0.5 176 | CC.DrawText mBorderWidth, mBorderWidth, dx, dy, mCaption, Not mWordWrap, mAlignment, mInnerSpace, mVAlign, dtHasAccelerators, , True 177 | CC.SetLineJoin CAIRO_LINE_JOIN_ROUND 178 | CC.SetLineCap CAIRO_LINE_CAP_ROUND 179 | 180 | For i = 0 To 1 'this loop re-renders always on the same path (ensured by the True-Param in the .Stroke) 181 | CC.SetLineWidth 4 - 2 * i 'but with decreasing linewidth 182 | CC.SetSourceColor mTextShadowColor, 0.15 + i * 0.05 'and slightly increasing Opacity 183 | CC.Stroke True 184 | Next i 185 | 186 | CC.SetLineWidth 1 187 | CC.SetSourceColor mTextShadowColor, 0.2 188 | CC.Stroke 189 | CC.Restore 190 | End If 191 | 192 | CC.DrawText mBorderWidth, mBorderWidth, dx, dy, mCaption, Not mWordWrap, mAlignment, mInnerSpace, mVAlign, dtHasAccelerators 193 | End Sub 194 | 195 | -------------------------------------------------------------------------------- /cwLabeledTextBox.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "cwLabeledTextBox" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Option Explicit 15 | 16 | Event Change() 17 | Event Validate(Cancel As Boolean) 18 | Event SelChanged(ByVal OldSelStart As Long, ByVal OldSelLength As Long, ByVal OldCaretPosition As Long) 19 | 20 | Private WithEvents W As cWidgetBase, WithEvents TB As cwTextBox 21 | Attribute W.VB_VarHelpID = -1 22 | Attribute TB.VB_VarHelpID = -1 23 | Private mCaption As String, mAlignment As AlignmentConstants, mLabelWidthPercent As Single 24 | 25 | Private Sub Class_Initialize() 26 | Set W = Cairo.WidgetBase '<- this is required in each cwImplementation... 27 | W.ForwardFocus = True 28 | mAlignment = vbRightJustify 29 | mLabelWidthPercent = 0.4 30 | End Sub 31 | 32 | Public Property Get Widget() As cWidgetBase 33 | Set Widget = W 34 | End Property 35 | Public Property Get Widgets() As cWidgets 36 | Set Widgets = W.Widgets 37 | End Property 38 | 39 | Public Property Get CaptionWidth() As Single 40 | Dim CC As cCairoContext 41 | Set CC = W.MeasureContext 42 | W.SelectFontSettingsInto CC 43 | CaptionWidth = CC.GetTextExtents(mCaption) 44 | End Property 45 | 46 | Public Property Get Caption() As String 47 | Caption = mCaption 48 | End Property 49 | Public Property Let Caption(ByVal NewValue As String) 50 | Dim AccKey$, Pos& 51 | If mCaption = NewValue Then Exit Property Else mCaption = NewValue 52 | TB.Widget.Tag = NewValue 53 | W.Refresh 54 | Pos = InStr(Replace(mCaption, "&&", "--"), "&") 55 | If Pos Then AccKey = Mid$(Replace(mCaption, "&&", "--"), Pos + 1, 1) 56 | 57 | If Len(AccKey) Then W.AccessKeys = AccKey 58 | End Property 59 | 60 | Public Property Get Alignment() As AlignmentConstants 61 | Alignment = mAlignment 62 | End Property 63 | Public Property Let Alignment(ByVal NewValue As AlignmentConstants) 64 | If mAlignment = NewValue Then Exit Property Else mAlignment = NewValue 65 | W.Refresh 66 | End Property 67 | 68 | Public Property Get Text() As String 69 | If Not TB Is Nothing Then Text = TB.Text 70 | End Property 71 | Public Property Let Text(ByVal NewValue As String) 72 | If Not TB Is Nothing Then TB.Text = NewValue 73 | End Property 74 | 75 | Public Property Get SelStart() As Long 76 | SelStart = TB.SelStart 77 | End Property 78 | Public Property Let SelStart(ByVal NewValue As Long) 79 | TB.SelStart = NewValue 80 | End Property 81 | 82 | Public Property Get SelLength() As Long 83 | SelLength = TB.SelLength 84 | End Property 85 | Public Property Let SelLength(ByVal NewValue As Long) 86 | TB.SelLength = NewValue 87 | End Property 88 | 89 | Public Property Get LabelWidthPercent() As Single 90 | LabelWidthPercent = mLabelWidthPercent 91 | End Property 92 | Public Property Let LabelWidthPercent(ByVal NewValue As Single) 93 | If mLabelWidthPercent = NewValue Then Exit Property Else mLabelWidthPercent = NewValue 94 | If mLabelWidthPercent < 0.02 Then mLabelWidthPercent = 0.02 95 | If mLabelWidthPercent > 0.98 Then mLabelWidthPercent = 0.98 96 | W.Refresh 97 | End Property 98 | 99 | Public Sub Move(x, y, dx, dy, Optional ByVal LabelWidthPercent As Single) 100 | If LabelWidthPercent > 0 And LabelWidthPercent < 1 Then mLabelWidthPercent = LabelWidthPercent 101 | W.Move x, y, dx, dy 102 | End Sub 103 | 104 | Private Sub TB_Change() 105 | RaiseEvent Change 106 | W.RaiseBubblingEvent Me, "Change" 107 | End Sub 108 | Private Sub TB_Validate(Cancel As Boolean) 109 | RaiseEvent Validate(Cancel) 110 | W.RaiseBubblingEvent Me, "Validate", Cancel 111 | End Sub 112 | Private Sub TB_SelChanged(ByVal OldSelStart As Long, ByVal OldSelLength As Long, ByVal OldCaretPosition As Long) 113 | RaiseEvent SelChanged(OldSelStart, OldSelLength, OldCaretPosition) 114 | W.RaiseBubblingEvent Me, "SelChanged", OldSelStart, OldSelLength, OldCaretPosition 115 | End Sub 116 | 117 | Private Sub W_AccessKeyPress(KeyAscii As Integer) 118 | If TB Is Nothing Then Set TB = Widgets.Add(New cwTextBox, "_" & W.Key) 119 | TB.Widget.SetFocus 120 | TB.SelectAll 121 | End Sub 122 | 123 | Private Sub W_EnterFocus() 124 | If TB Is Nothing Then Set TB = Widgets.Add(New cwTextBox, "_" & W.Key) 125 | TB.SelectAll 126 | End Sub 127 | 128 | Private Sub W_Resize() 129 | If TB Is Nothing Then Set TB = Widgets.Add(New cwTextBox, "_" & W.Key) 130 | TB.Widget.Move W.Width * mLabelWidthPercent, 0, W.Width * (1 - mLabelWidthPercent), W.Height 131 | End Sub 132 | 133 | Private Sub W_Paint(CC As vbRichClient5.cCairoContext, ByVal xAbs As Single, ByVal yAbs As Single, ByVal dx_Aligned As Single, ByVal dy_Aligned As Single, UserObj As Object) 134 | W.SelectFontSettingsInto CC 135 | CC.DrawText 0, 4, dx_Aligned * mLabelWidthPercent - 3, dy_Aligned - 4, mCaption, True, mAlignment, 0, 0, dtHasAccelerators 136 | End Sub 137 | -------------------------------------------------------------------------------- /cwMDIMock.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "cwMDIMock" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Option Explicit 15 | 16 | Private Const mBorderWidth As Long = 5 17 | Private Const mCaptionHeight As Long = 22 18 | Private mCaption As String 19 | 20 | Private dx As Single, dy As Single, Alpha As Single 21 | 22 | Private WithEvents W As cWidgetBase 23 | Attribute W.VB_VarHelpID = -1 24 | 25 | Private Sub Class_Initialize() 26 | Set W = Cairo.WidgetBase 27 | W.ForeColor = &H222222 28 | W.FontSize = 10 29 | W.SetClientAreaOffsets mBorderWidth, mCaptionHeight + mBorderWidth, mBorderWidth, mBorderWidth 30 | End Sub 31 | 32 | 'the following two Public Props are a "required convention", needed in *each* cwWidget-class 33 | Public Property Get Widget() As cWidgetBase 34 | Set Widget = W 35 | End Property 36 | Public Property Get Widgets() As cWidgets 37 | Set Widgets = W.Widgets 38 | End Property 39 | 40 | Public Property Get Caption() As String 41 | Caption = mCaption 42 | End Property 43 | Public Property Let Caption(ByVal NewValue As String) 44 | If mCaption = NewValue Then Exit Property 45 | mCaption = NewValue 46 | W.Refresh 47 | End Property 48 | 49 | Private Sub W_EnterFocus() 50 | W.Refresh 51 | End Sub 52 | Private Sub W_ExitFocus() 53 | W.Refresh 54 | End Sub 55 | 56 | Private Sub W_BubblingEvent(Sender As Object, EventName As String, P1 As Variant, P2 As Variant, P3 As Variant, P4 As Variant, P5 As Variant, P6 As Variant, P7 As Variant) 57 | Dim PRecurse As cWidgetBase 58 | If EventName <> "W_MouseDown" Then Exit Sub 59 | W.MoveToFront: W.Refresh 60 | Set PRecurse = Sender.Widget 61 | Do Until PRecurse Is W 62 | If PRecurse.CanGetFocus Then Exit Do 63 | Set PRecurse = PRecurse.Parent 64 | Loop 65 | If PRecurse Is W Then W.SetFocus 66 | End Sub 67 | 68 | Private Sub W_MouseDown(Button As Integer, Shift As Integer, ByVal x As Single, ByVal y As Single) 69 | W.MoveToFront: W.Refresh 70 | W.Moveable = y < mBorderWidth + mCaptionHeight 71 | End Sub 72 | 73 | Private Sub W_Paint(CC As cCairoContext, ByVal xAbs As Single, ByVal yAbs As Single, ByVal dx_Aligned As Single, ByVal dy_Aligned As Single, UserObj As Object) 74 | dx = dx_Aligned 75 | dy = dy_Aligned 76 | Alpha = W.AlphaInherited 77 | 78 | Draw CC 79 | End Sub 80 | 81 | Private Sub Draw(CC As cCairoContext) 82 | Dim NCColor As Long, Pat As cCairoPattern 83 | 84 | 'nonclient-area drawing (first we determine the NonClient-Color) 85 | NCColor = IIf(W.Active, W.SelectionColor, W.ShadeColor(W.BackColor, 0.95)) 86 | 87 | 'the outline, part 1 (a thin rectangle, to achieve TopLeft-lighting) 88 | CC.SetLineWidth 2 89 | CC.RoundedRect 1, 1, dx - 2, dy - 2, mBorderWidth, True, cmTop 90 | CC.SetSourceColor &HEEEEEE, Alpha * 0.95 91 | CC.Stroke 92 | 93 | 'the outline, part 2 (a thicker one - this is mainly for the NC-colored Borders) 94 | CC.SetLineWidth 3 95 | CC.RoundedRect 2, 2, dx - 3.3, dy - 3.5, mBorderWidth - 1, True, cmTop 96 | CC.SetSourceColor NCColor, Alpha * 0.95, 0.95 97 | CC.Stroke 98 | 99 | 'now the Caption-Gradient 100 | CC.SetLineWidth 0 101 | CC.RoundedRect mBorderWidth - 1, mBorderWidth - 2, dx - 2 * mBorderWidth + 2, mCaptionHeight + 1, mBorderWidth - 2, True, cmTop 102 | Set Pat = Cairo.CreateLinearPattern(0, mBorderWidth - 2, 0, mCaptionHeight + mBorderWidth) 103 | Pat.AddColorStop 0, NCColor, Alpha * 0.95, 0.88 104 | Pat.AddColorStop 1, NCColor, Alpha * 0.95, 1.03 105 | CC.Fill , Pat 106 | 107 | 'the Min/Max/Close-ButtonGroup 108 | CC.SetLineWidth 1 109 | CC.RoundedRect dx - 76, 0, 70, Int(mCaptionHeight * 0.8), mBorderWidth - 0.4, True, cmBottom 110 | Set Pat = Cairo.CreateLinearPattern(0, 0, 0, Int(mCaptionHeight * 0.8) - 2) 111 | Pat.AddColorStop 0, W.BackColor, Alpha * 0.55, 1.2 112 | Pat.AddColorStop 0.6, W.BackColor, Alpha * 0.55, 1.05 113 | Pat.AddColorStop 0.61, W.BackColor, Alpha * 0.55, 0.85 114 | Pat.AddColorStop 1, W.BackColor, Alpha * 0.55, 0.8 115 | CC.Fill True, Pat 116 | CC.SetLineWidth 3 117 | CC.SetSourceColor vbWhite, Alpha * 0.3 118 | CC.Stroke True 119 | CC.SetLineWidth 1 120 | CC.SetSourceColor W.BorderColor, Alpha * 0.7 121 | CC.Stroke 122 | 123 | 'outline, part 3 (the outermost line, a thin one) 124 | NCColor = IIf(W.Active, W.FocusColor, W.BorderColor) 125 | CC.SetLineWidth 1 126 | CC.RoundedRect 0, 0, dx, dy, mBorderWidth + 1, True, cmTop 127 | CC.SetSourceColor NCColor, Alpha * 0.9 128 | CC.Stroke 129 | 130 | 'the "Form"-Icon... 131 | CC.RenderSurfaceContent "MDIIcon", 7, 4, 18, 18, , Alpha * 2 132 | 133 | '... and the "Caption"-Text 134 | If W.Active Then 'draw some light-grey Text-Imprint first 135 | W.SelectFontSettingsInto CC, &HE0E0D0 136 | CC.TextOut 27, 5, mCaption, , Alpha * 2 137 | End If 138 | W.SelectFontSettingsInto CC 139 | CC.TextOut 27, 6, mCaption, , Alpha * 2 140 | 141 | 'Now the clientarea-coloring 142 | CC.SetLineWidth 1, True 143 | CC.Rectangle mBorderWidth - 1, mCaptionHeight + mBorderWidth - 1, dx - 2 * mBorderWidth + 2, dy - mCaptionHeight - 2 * mBorderWidth + 2, True 144 | CC.SetSourceColor W.BackColor, Alpha 145 | CC.Fill True 146 | CC.SetSourceColor W.BorderColor, Alpha * 0.8 147 | CC.Stroke 148 | End Sub 149 | -------------------------------------------------------------------------------- /cwMenuBarItem.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "cwMenuBarItem" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Option Explicit 15 | 16 | Event Click(ByVal CurMenuItemPath As String) 17 | 18 | Private mDataSource As cMenuItem 19 | 20 | Private dx As Single, dy As Single, Alpha As Single 21 | Private WithEvents W As cWidgetBase 22 | Attribute W.VB_VarHelpID = -1 23 | 24 | Private Sub Class_Initialize() 25 | Set W = Cairo.WidgetBase 26 | W.CanGetFocus = False 27 | End Sub 28 | 29 | Public Property Get Widget() As cWidgetBase 30 | Set Widget = W 31 | End Property 32 | Public Property Get Widgets() As cWidgets 33 | Set Widgets = W.Widgets 34 | End Property 35 | 36 | Public Property Get DataSource() As cMenuItem 37 | Set DataSource = mDataSource 38 | End Property 39 | Public Property Set DataSource(NewValue As cMenuItem) 40 | Set mDataSource = NewValue 41 | End Property 42 | 43 | Public Sub ShowPopUp(Optional ByVal WithFocus As Boolean) 44 | Dim MenuBar As cwMenuBar, ShowIt As Boolean 45 | If Not W.Enabled Or W.Parent Is Nothing Then Exit Sub 46 | 47 | Set MenuBar = W.Parent.object 48 | If Not MenuBar.CurPopUp Is Nothing Then 49 | MenuBar.CurPopUp.DestroyPopup 50 | Set MenuBar.CurPopUp = Nothing 51 | End If 52 | Set MenuBar.CurPopUp = New cwMenu 53 | MenuBar.CurPopUp.Widget.FontSize = W.FontSize 54 | MenuBar.CurPopUp.InitAndShow W, mDataSource, PopupBehaviourDropDownLeftAligned, WithFocus 55 | End Sub 56 | 57 | Private Sub W_MouseDown(Button As Integer, Shift As Integer, ByVal x As Single, ByVal y As Single) 58 | If Button = 1 And Not IsOwnPopupVisible Then ShowPopUp 59 | End Sub 60 | Private Sub W_MouseEnter(ByVal MouseLeaveWidget As vbRichClient5.cWidgetBase) 61 | If IsPopupVisible And Not IsOwnPopupVisible Then ShowPopUp 62 | W.Parent.object.CleanupActiveState W 63 | W.Parent.Refresh 64 | End Sub 65 | Private Function IsOwnPopupVisible() As Boolean 66 | Dim MenuBar As cwMenuBar 67 | If IsPopupVisible Then 68 | Set MenuBar = W.Parent.object 69 | If MenuBar.CurPopUp.DataSource Is Nothing Then Exit Function 70 | IsOwnPopupVisible = MenuBar.CurPopUp.DataSource Is mDataSource 71 | End If 72 | End Function 73 | Private Function IsPopupVisible() As Boolean 74 | Dim MenuBar As cwMenuBar 75 | If W.Parent Is Nothing Then Exit Function 76 | Set MenuBar = W.Parent.object 77 | If MenuBar.CurPopUp Is Nothing Then Exit Function 78 | If MenuBar.CurPopUp.fPopUp Is Nothing Then Exit Function 79 | If MenuBar.CurPopUp.fPopUp.Form Is Nothing Then Exit Function 80 | IsPopupVisible = True 81 | End Function 82 | 83 | Private Sub W_MouseLeave(ByVal MouseEnterWidget As vbRichClient5.cWidgetBase) 84 | W.Refresh 85 | W.Parent.Refresh 86 | End Sub 87 | 88 | Private Sub W_AccessKeyPress(KeyAscii As Integer) 89 | If W.Root.IsHidden Then Exit Sub 90 | 91 | If InStr(1, W.AccessKeys, Chr$(KeyAscii), vbTextCompare) Then 92 | W.Parent.object.CleanupActiveState W 93 | W.SetFocus 94 | W.RaiseBubblingEvent Me, "AccessKeyPress", KeyAscii 95 | W.SetFocus 96 | W.Refresh 97 | W.Parent.Refresh 98 | End If 99 | End Sub 100 | 101 | Private Sub W_Paint(CC As cCairoContext, ByVal xAbs As Single, ByVal yAbs As Single, ByVal dx_Aligned As Single, ByVal dy_Aligned As Single, UserObj As Object) 102 | dx = dx_Aligned 103 | dy = dy_Aligned 104 | Alpha = W.AlphaInherited 105 | Draw CC 106 | End Sub 107 | 108 | Public Sub SetAccelerator(ByVal Caption As String) 109 | Dim AccKey$, Pos& 110 | 111 | Pos = InStr(Replace(Caption, "&&", "--"), "&") 112 | If Pos Then AccKey = Mid$(Replace(Caption, "&&", "--"), Pos + 1, 1) 113 | 114 | If Len(AccKey) Then W.AccessKeys = AccKey 115 | End Sub 116 | 117 | Private Sub Draw(CC As cCairoContext) 118 | Dim TxtWidth As Double, FontHeight As Double, Pat As cCairoPattern 119 | 120 | If mDataSource Is Nothing Then Exit Sub 121 | SetAccelerator mDataSource.Caption 122 | 123 | CC.SetLineWidth 1 124 | CC.SelectFont Cairo.Theme.GetIconFontName, W.FontSize, vbBlack 125 | 126 | TxtWidth = CC.GetTextExtents(mDataSource.Caption, FontHeight) 127 | 128 | CC.SelectFont Cairo.Theme.GetIconFontName, W.FontSize, vbWhite 129 | CC.DrawText 0, 1, dx, dy, mDataSource.Caption, True, vbCenter, 2, 1, dtHasAccelerators 130 | 131 | CC.SelectFont Cairo.Theme.GetIconFontName, W.FontSize, IIf(W.Enabled, W.ForeColor, W.ShadeColor(W.DisabledColor, 0.9)) 132 | CC.DrawText 0, 0, dx, dy, mDataSource.Caption, True, vbCenter, 2, 1, dtHasAccelerators 133 | 134 | If W.Enabled And (W.MouseOver Or IsOwnPopupVisible) Then 135 | CC.RoundedRect 0, 0, dx, dy - 1, 2.2, True 136 | CC.SetSourceColor vbBlack 137 | Set Pat = Cairo.CreateLinearPattern(0, 0, 0, dy) 138 | Pat.AddColorStop 0, vbWhite, , 0.85 139 | Pat.AddColorStop 1, vbWhite, , 0.45 140 | CC.Stroke , Pat 141 | CC.DrawLine 2, dy, dx - 3, dy, False, 1, vbBlack, 0.2 142 | End If 143 | End Sub 144 | 145 | -------------------------------------------------------------------------------- /cwMenuItem.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "cwMenuItem" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Option Explicit 15 | 16 | Event ShowSubMenu(Sender As cwMenuItem) 17 | 18 | Private dx As Single, dy As Single, Alpha As Single 19 | Private mCaption As String, mShortcutHint As String, mSubMenuDS As cMenuItem 20 | Private mDeactivatedViaMouseLeave As Boolean 21 | 22 | Private mIsCheckable As Boolean, mChecked As Boolean, mIsOption As Boolean 23 | Private WithEvents tmrSubMenuHover As cTimer 24 | Attribute tmrSubMenuHover.VB_VarHelpID = -1 25 | 26 | Private WithEvents W As cWidgetBase 27 | Attribute W.VB_VarHelpID = -1 28 | 29 | Private Sub Class_Initialize() 30 | Set W = Cairo.WidgetBase 31 | End Sub 32 | 33 | Public Property Get Widget() As cWidgetBase 34 | Set Widget = W 35 | End Property 36 | Public Property Get Widgets() As cWidgets 37 | Set Widgets = W.Widgets 38 | End Property 39 | 40 | Public Property Get SubMenuDS() As cMenuItem 41 | Set SubMenuDS = mSubMenuDS 42 | End Property 43 | Friend Property Set SubMenuDS(NewValue As cMenuItem) 44 | Set mSubMenuDS = NewValue 45 | End Property 46 | 47 | Public Property Get Caption() As String 48 | Caption = mCaption 49 | End Property 50 | Public Property Let Caption(ByVal NewValue As String) 51 | Dim AccKey$, Pos& 52 | If mCaption = NewValue Then Exit Property 53 | mCaption = NewValue 54 | W.Refresh 55 | Pos = InStr(Replace(mCaption, "&&", "--"), "&") 56 | If Pos Then AccKey = Mid$(Replace(mCaption, "&&", "--"), Pos + 1, 1) 57 | Pos = InStr(mCaption, "|") 58 | If Pos Then mShortcutHint = Mid$(mCaption, Pos + 1) 59 | 60 | If Len(AccKey) Then W.AccessKeys = AccKey 61 | End Property 62 | 63 | Public Property Get Checked() As Boolean 64 | Checked = mChecked 65 | End Property 66 | Friend Property Let Checked(ByVal NewValue As Boolean) 67 | mChecked = NewValue 68 | End Property 69 | 70 | Public Property Get IsCheckable() As Boolean 71 | IsCheckable = mIsCheckable 72 | End Property 73 | Friend Property Let IsCheckable(ByVal NewValue As Boolean) 74 | mIsCheckable = NewValue 75 | If Not NewValue Then mIsOption = False 'IsOption works only if IsCheckable 76 | End Property 77 | 78 | Public Property Get IsOption() As Boolean 79 | IsOption = mIsOption 80 | End Property 81 | Friend Property Let IsOption(ByVal NewValue As Boolean) 82 | mIsOption = NewValue 83 | End Property 84 | 85 | Public Property Get IsActive() As Boolean 86 | IsActive = W.Focused And (Not mSubMenuDS Is Nothing Or Not mDeactivatedViaMouseLeave) 87 | End Property 88 | 89 | Private Sub W_LostFocus() 90 | W.MouseLeave Nothing 91 | W.Refresh 92 | End Sub 93 | 94 | Private Sub W_GotFocus() 95 | mDeactivatedViaMouseLeave = False 96 | End Sub 97 | 98 | Private Sub W_MouseEnter(ByVal MouseLeaveWidget As cWidgetBase) 99 | If Not mSubMenuDS Is Nothing Then Set tmrSubMenuHover = New_c.Timer(350, True) 100 | mDeactivatedViaMouseLeave = False 101 | W.SetFocus 102 | W.Refresh 103 | End Sub 104 | Private Sub W_MouseLeave(ByVal MouseEnterWidget As cWidgetBase) 105 | Set tmrSubMenuHover = Nothing 106 | mDeactivatedViaMouseLeave = True 107 | W.Refresh 108 | End Sub 109 | Private Sub tmrSubMenuHover_Timer() 110 | Set tmrSubMenuHover = Nothing 111 | If Not W.Enabled Then Exit Sub 112 | RaiseEvent ShowSubMenu(Me) 113 | W.RaiseBubblingEvent Me, "ShowSubMenu", W.object 114 | End Sub 115 | 116 | Private Sub W_AccessKeyPress(KeyAscii As Integer) 117 | If InStr(1, W.AccessKeys, Chr$(KeyAscii), vbTextCompare) Then 118 | If W.Enabled Then 119 | W.SetFocus 120 | W.RaiseBubblingEvent Me, "W_MouseUp", 1, 0, 1, 1 121 | End If 122 | End If 123 | End Sub 124 | 125 | Private Sub W_Paint(CC As cCairoContext, ByVal xAbs As Single, ByVal yAbs As Single, ByVal dx_Aligned As Single, ByVal dy_Aligned As Single, UserObj As Object) 126 | dx = dx_Aligned 127 | dy = dy_Aligned 128 | Alpha = W.AlphaInherited 129 | Draw CC 130 | End Sub 131 | 132 | Private Sub Draw(CC As cCairoContext) 133 | Const IcoOffsX& = 30, IcoSize& = 16, ArrowSize& = 9 134 | 135 | CC.SetSourceColor W.BackColor 136 | CC.Paint 137 | 138 | CC.DrawLine IcoOffsX - 1, 0, IcoOffsX - 1, dy, True, 1, &HD0D0D0, Alpha 139 | CC.DrawLine IcoOffsX, 0, IcoOffsX, dy, True, 1, vbWhite, Alpha 140 | 141 | If mCaption = "-" Then 142 | CC.DrawLine IcoOffsX, 4, dx - 2, 4, True, 1, &HD0D0D0, Alpha 143 | CC.DrawLine IcoOffsX, 5, dx - 2, 5, True, 1, vbWhite, Alpha 144 | 145 | Else 146 | If IsActive Then 147 | W.Alpha = 0.6 148 | CC.SetLineWidth 1, True 149 | Cairo.Theme.DrawTo CC, W, thmTypeListSelection, 0, 2, 0, dx - 4, dy, 3 150 | End If 151 | 152 | If mIsCheckable Then 153 | W.Alpha = 0.3 154 | Cairo.Theme.DrawTo CC, W, thmTypeListSelection, 0, 2, 0, dy + 2, dy, 3 155 | If mChecked Then 156 | If mIsOption Then 157 | DrawOptionMark CC, IcoSize + 3 158 | Else 159 | DrawCheckMark CC, IcoSize + 3 160 | End If 161 | End If 162 | End If 163 | 164 | W.Alpha = Alpha 165 | If Not mChecked And Len(W.ImageKey) Then 166 | CC.RenderSurfaceContent W.ImageKey, 6.5, (dy - 16) \ 2 + 0.5, IcoSize, IcoSize, , Alpha 167 | End If 168 | If Not mSubMenuDS Is Nothing Then 'this is a ParentNode 169 | Cairo.Theme.DrawTo CC, W, thmTypeArrow, 0, dx - 18, (dy - ArrowSize) \ 2 + 1, ArrowSize, ArrowSize, 0, thmDirectionRight 170 | End If 171 | W.SelectFontSettingsInto CC 172 | CC.DrawText IcoOffsX, 0, dx - IcoOffsX, dy, Replace(mCaption, "|" & mShortcutHint, vbNullString), True, vbLeftJustify, 5, True, dtHasAccelerators, Alpha 173 | CC.DrawText IcoOffsX, 0, dx - IcoOffsX, dy, mShortcutHint, True, vbRightJustify, 5, True, dtHasAccelerators, Alpha 174 | End If 175 | End Sub 176 | 177 | Private Sub DrawCheckMark(CC As cCairoContext, ByVal CheckSize As Long) 178 | Dim x As Double, y As Double 179 | y = (W.Height - CheckSize) / 2 + 2 180 | x = y + 3.3 181 | CC.SetLineCap Cairo_LINE_CAP_ROUND 182 | CC.SetLineWidth 2 183 | CC.SetSourceColor W.FocusColor, 0.85, 0.27 184 | x = x + 2: CheckSize = CheckSize - 4 185 | y = y + 2: CheckSize = CheckSize - 4 186 | CC.MoveTo x + CheckSize - 1.75, y + 1 187 | CC.LineTo x + CheckSize * 0.395, y + CheckSize - 1.9 188 | CC.LineTo x + 1.75, y + CheckSize * 0.55 189 | CC.Stroke True 190 | CC.SetLineWidth 1 191 | CC.SetSourceColor W.FocusColor, 0.35 192 | CC.Stroke 193 | End Sub 194 | 195 | Private Sub DrawOptionMark(CC As cCairoContext, ByVal OptionSize As Long) 196 | Dim x As Double, y As Double 197 | y = (W.Height - OptionSize) / 2 + 2 198 | x = y + 3.3 199 | CC.SetLineCap Cairo_LINE_CAP_ROUND 200 | 201 | OptionSize = OptionSize - 8 202 | x = x + 2 + OptionSize / 2 203 | y = y + 2 + OptionSize / 2 204 | 205 | Dim Pat As cCairoPattern 206 | CC.ARC x, y, OptionSize / 2 207 | 208 | Set Pat = Cairo.CreateRadialPattern(x, y, OptionSize / 2, x + OptionSize / 6, y - OptionSize / 4, 0) 209 | Pat.AddColorStop 1, W.FocusColor, 0# 210 | Pat.AddColorStop 0, W.FocusColor, 0.85, 0.22 211 | CC.Fill True, Pat 212 | 213 | CC.SetLineWidth 1 214 | CC.SetSourceColor W.FocusColor, 0.35, 0.4 215 | CC.Stroke 216 | End Sub 217 | 218 | -------------------------------------------------------------------------------- /cwProgressBar.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "cwProgressBar" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Option Explicit 15 | 16 | Public Enum eProgressStyle 17 | pg_Standard = 0 18 | pg_MarqueeLoop = 1 19 | pg_MarqueeBounce = 2 20 | End Enum 21 | 22 | Private mInternalW As Single, mInternalH As Single 23 | Private dx As Single, dy As Single, Alpha As Single 24 | 25 | Private mStyle As eProgressStyle 26 | Private mMin As Single, mMax As Single, mValue As Single 27 | Private mCaption As String 28 | Private mBorderRadius As Double 29 | 30 | Const MarqueeWidthPct As Double = 0.25 31 | Private WithEvents MarqueeTimer As cTimer, TaskBar As cTaskBar 32 | Attribute MarqueeTimer.VB_VarHelpID = -1 33 | 34 | Private WithEvents W As cWidgetBase 35 | Attribute W.VB_VarHelpID = -1 36 | 37 | Private Sub Class_Initialize() 38 | Set W = Cairo.WidgetBase 39 | W.CanGetFocus = False 40 | W.SelectionColor = vbGreen 41 | mBorderRadius = 2.5 42 | mMax = 100 43 | End Sub 44 | Public Property Get Widget() As cWidgetBase 45 | Set Widget = W 46 | End Property 47 | Public Property Get Widgets() As cWidgets 48 | Set Widgets = W.Widgets 49 | End Property 50 | 51 | 'after the necessities above, I start usually with all the Public Props 52 | Public Sub Clear() 53 | mCaption = vbNullString 54 | mValue = mMin 55 | W.Refresh 56 | If Not TaskBar Is Nothing And Not W.Root Is Nothing Then 57 | TaskBar.SetProgressState W.Root.DialogFormHwnd, TBPF_NOPROGRESS 58 | End If 59 | End Sub 60 | 61 | Public Property Get Value() As Single 62 | Value = mValue 63 | End Property 64 | Public Property Let Value(ByVal NewValue As Single) 65 | If NewValue > mMax Then 66 | mValue = mMax 67 | ElseIf NewValue < mMin Then 68 | mValue = mMin 69 | Else 70 | mValue = NewValue 71 | End If 72 | W.Refresh 73 | If Not TaskBar Is Nothing And Not W.Root Is Nothing Then 74 | TaskBar.SetProgressState W.Root.DialogFormHwnd, TBPF_NORMAL 75 | TaskBar.SetProgressValue W.Root.DialogFormHwnd, mValue - mMin, mMax - mMin 76 | End If 77 | End Property 78 | 79 | Public Property Get Min() As Single 80 | Min = mMin 81 | End Property 82 | Public Property Let Min(ByVal NewValue As Single) 83 | mMin = NewValue 84 | If mMin > mValue Then mValue = mMin 85 | End Property 86 | 87 | Public Property Get Max() As Single 88 | Max = mMax 89 | End Property 90 | Public Property Let Max(ByVal NewValue As Single) 91 | mMax = NewValue 92 | If mMax < mValue Then mValue = mMax 93 | End Property 94 | 95 | Public Property Get Caption() As String 96 | Caption = mCaption 97 | End Property 98 | Public Property Let Caption(NewValue As String) 99 | If mCaption = NewValue Then Exit Property 100 | mCaption = NewValue 101 | W.Refresh 102 | End Property 103 | 104 | Public Property Get BorderRadius() As Double 105 | BorderRadius = mBorderRadius 106 | End Property 107 | Public Property Let BorderRadius(ByVal NewValue As Double) 108 | If NewValue < 0 Then NewValue = 0 109 | If NewValue = mBorderRadius Then Exit Property 110 | mBorderRadius = NewValue 111 | W.Refresh 112 | End Property 113 | 114 | Public Property Get ReflectInTaskBar() As Boolean 115 | ReflectInTaskBar = Not TaskBar Is Nothing 116 | End Property 117 | Public Property Let ReflectInTaskBar(ByVal NewValue As Boolean) 118 | If ReflectInTaskBar = NewValue Then Exit Property 119 | If NewValue Then Set TaskBar = New_c.Cairo.TaskBar Else Set TaskBar = Nothing 120 | End Property 121 | Public Property Get Style() As eProgressStyle 122 | Style = mStyle 123 | End Property 124 | Public Property Let Style(ByVal NewValue As eProgressStyle) 125 | If mStyle = NewValue Then Exit Property 126 | 127 | mStyle = NewValue 128 | If mStyle = pg_Standard Then 129 | Set MarqueeTimer = Nothing 'let's not waste resources, if we don't need to in the standard-case 130 | Else 131 | mValue = 0 132 | mMin = 0 133 | mMax = 100 134 | Set MarqueeTimer = New_c.Timer(15, True, 1) 135 | End If 136 | 137 | W.Refresh 138 | If Not TaskBar Is Nothing And Not W.Root Is Nothing Then 139 | TaskBar.SetProgressState W.Root.DialogFormHwnd, IIf(mStyle = pg_Standard, TBPF_NOPROGRESS, TBPF_INDETERMINATE) 140 | End If 141 | End Property 142 | 'after the Public Props, the internal Event-Handlers 143 | Private Sub MarqueeTimer_Timer() 144 | mValue = mValue + MarqueeTimer.Tag 145 | 146 | Select Case True 147 | Case mStyle = pg_MarqueeLoop 148 | If mValue > (mMax * (1 + MarqueeWidthPct)) Then mValue = mMin 149 | 150 | Case mStyle = pg_MarqueeBounce 151 | If mValue > mMax Then MarqueeTimer.Tag = -1 152 | If mValue < (mMax * MarqueeWidthPct) Then MarqueeTimer.Tag = 1 153 | End Select 154 | 155 | W.Refresh 156 | End Sub 157 | 158 | 'with the Paint-Event usually as the last one... 159 | Private Sub W_Paint(CC As vbRichClient5.cCairoContext, ByVal xAbs As Single, ByVal yAbs As Single, ByVal dx_Aligned As Single, ByVal dy_Aligned As Single, UserObj As Object) 160 | dx = dx_Aligned: dy = dy_Aligned 161 | Alpha = W.AlphaInherited 162 | 163 | If dx >= dy Then 'normal, horizontal Bar 164 | mInternalW = dx: mInternalH = dy 165 | Draw CC 166 | Else 'switch to autodetected, vertical Orientation 167 | mInternalW = dy: mInternalH = dx 168 | CC.Save 169 | CC.RotateDrawingsDeg 270 170 | CC.TranslateDrawings -dy, 0 171 | Draw CC 172 | CC.Restore 173 | End If 174 | End Sub 175 | 176 | 'and the related Drawing-Cascade in the right order... 177 | Private Sub Draw(CC As cCairoContext) 178 | DrawBackground CC, 0.6, 0, 1.05, 0.3, 0.99, 0.3, 0.95, 1, 0.9 179 | DrawBorder CC, 0.85 180 | DrawUsedArea CC 181 | DrawCaption CC 182 | DrawShine CC 183 | End Sub 184 | Private Sub DrawBackground(CC As cCairoContext, ByVal WhiteStrokeAlpha As Double, ParamArray StopsAndShade()) 185 | Dim i& 186 | If W.BackColor = -1 Then Exit Sub 'no BackColor, so we leave here (and the BackGround transparent) 187 | 188 | CC.SetLineWidth 2, True 189 | CC.RoundedRect 0, 0, mInternalW, mInternalH, mBorderRadius, True 190 | With Cairo.CreateLinearPattern(0, 0, 0, mInternalH) 191 | 192 | For i = 0 To UBound(StopsAndShade) Step 2 'on the even indices are the Stop-Values - and on the uneven ones the Shade-Values 193 | .AddColorStop StopsAndShade(i), W.BackColor, Alpha, StopsAndShade(i + 1) 194 | Next i 195 | 196 | CC.Fill True, .This 197 | 198 | CC.SetSourceColor vbWhite, WhiteStrokeAlpha * Alpha 199 | CC.Stroke 200 | End With 201 | End Sub 202 | Private Sub DrawBorder(CC As cCairoContext, ByVal BorderAlpha As Double) 203 | CC.SetLineWidth 1, True 204 | CC.RoundedRect 0, 0, mInternalW, mInternalH, mBorderRadius, True 205 | CC.SetSourceColor W.BorderColor, BorderAlpha * Alpha 206 | CC.Stroke 207 | End Sub 208 | Private Sub DrawUsedArea(CC As cCairoContext) 209 | Dim ScaledValue As Double, StartX As Double 210 | 211 | CC.SetLineWidth 0 212 | ScaledValue = ((mValue - mMin) / (mMax - mMin)) * (mInternalW - 2.5) 213 | 214 | If mStyle <> pg_Standard Then 215 | StartX = ScaledValue - (mInternalW * MarqueeWidthPct) 216 | End If 217 | 218 | Cairo.Theme.DrawTo CC, W, thmTypeProgressFace, thmStateSolidColor, StartX, 0, ScaledValue - StartX, mInternalH, mBorderRadius 219 | End Sub 220 | Private Sub DrawCaption(CC As cCairoContext) 221 | If Len(mCaption) = 0 Then Exit Sub 222 | W.SelectFontSettingsInto CC 223 | CC.DrawText 0.05, 0.55, mInternalW, mInternalH, mCaption, True, vbCenter, , 1 224 | End Sub 225 | Private Sub DrawShine(CC As cCairoContext) 226 | Cairo.Theme.DrawTo CC, W, thmTypeShine, 0, 1, 1, mInternalW - 2, mInternalH \ 4 + 1, 1 227 | Cairo.Theme.DrawTo CC, W, thmTypeShine, 0, 1, 1, mInternalW - 2, mInternalH \ 4 + 1, 1 228 | Cairo.Theme.DrawTo CC, W, thmTypeShine, 0, 2, 1, mInternalW - 4, mInternalH \ 8 + 1, 1 229 | End Sub 230 | -------------------------------------------------------------------------------- /cwResizer.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "cwResizer" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Option Explicit 15 | 16 | Public Enum ResizerStyle 17 | ResizerVerticalRightAligned 18 | ResizerVerticalLeftAligned 19 | ResizerHorizontalBottomAligned 20 | ResizerHorizontalTopAligned 21 | End Enum 22 | 23 | Event ResizerMoved(ByVal NewParentLeft As Single, ByVal NewParentTop As Single, ByVal NewParentWidth As Single, ByVal NewParentHeight As Single, ByVal Delta As Single) 24 | 25 | Private Alpha As Single, dx As Single, dy As Single 26 | Private mResizerStyle As ResizerStyle, mSizePixels As Single 27 | Private mDownParentLeft As Single, mDownParentTop As Single 28 | Private mDownParentWidth As Single, mDownParentHeight As Single 29 | Private mDownX As Single, mDownY As Single, mDown As Boolean 30 | 31 | Public MinWidth As Single, MaxWidth As Single, MinHeight As Single, MaxHeight As Single 32 | 33 | Private WithEvents W As cWidgetBase 34 | Attribute W.VB_VarHelpID = -1 35 | 36 | Private Sub Class_Initialize() 37 | Set W = Cairo.WidgetBase 38 | W.CanGetFocus = False 39 | 40 | mSizePixels = 6 41 | MinWidth = mSizePixels: MaxWidth = 1000000 42 | MinHeight = mSizePixels: MaxHeight = 1000000 43 | 44 | On Error Resume Next 45 | With New_c.Crypt 46 | If Not Cairo.ImageList.Exists("VSplitCursor") Then Cairo.ImageList.AddImage "VSplitCursor", .Base64Dec(VSplitCursor_Png, True) 47 | If Not Cairo.ImageList.Exists("HSplitCursor") Then Cairo.ImageList.AddImage "HSplitCursor", .Base64Dec(HSplitCursor_Png, True) 48 | End With 49 | If Err Then Err.Clear 50 | End Sub 51 | 52 | Public Property Get Widget() As cWidgetBase 53 | Set Widget = W 54 | End Property 55 | Public Property Get Widgets() As cWidgets 56 | Set Widgets = W.Widgets 57 | End Property 58 | 59 | Public Property Get SizePixels() As Single 60 | SizePixels = mSizePixels 61 | End Property 62 | Public Property Let SizePixels(ByVal NewValue As Single) 63 | If mSizePixels = NewValue Then Exit Property 64 | mSizePixels = NewValue 65 | W.Refresh 66 | End Property 67 | 68 | Public Sub Init(ByVal ResizerStyle As ResizerStyle, Optional ByVal MinWidth As Single = 6, Optional ByVal MinHeight As Single = 6, _ 69 | Optional ByVal MaxWidth As Single, Optional ByVal MaxHeight As Single) 70 | Me.ResizerStyle = ResizerStyle 71 | Me.MinWidth = MinWidth: If MaxWidth > 0 Then Me.MaxWidth = MaxWidth 72 | Me.MinHeight = MinHeight: If MaxHeight > 0 Then Me.MaxHeight = MaxHeight 73 | End Sub 74 | 75 | Public Property Get ResizerStyle() As ResizerStyle 76 | ResizerStyle = mResizerStyle 77 | End Property 78 | Public Property Let ResizerStyle(ByVal NewValue As ResizerStyle) 79 | If mResizerStyle = NewValue Then Exit Property 80 | mResizerStyle = NewValue 81 | End Property 82 | 83 | Private Sub W_AddedToHierarchy() 84 | AlignMe 85 | End Sub 86 | 87 | Private Sub W_MouseEnter(ByVal MouseLeaveWidget As cWidgetBase) 88 | W.Refresh 89 | End Sub 90 | Private Sub W_MouseLeave(ByVal MouseEnterWidget As cWidgetBase) 91 | W.Refresh 92 | End Sub 93 | 94 | Private Sub W_MouseDown(Button As Integer, Shift As Integer, ByVal x As Single, ByVal y As Single) 95 | W.MoveToFront 96 | mDownParentLeft = W.Parent.Left: mDownParentTop = W.Parent.Top 97 | mDownParentWidth = W.Parent.Width: mDownParentHeight = W.Parent.Height 98 | mDownX = x: mDownY = y: mDown = True 99 | End Sub 100 | Private Sub W_MouseMove(Button As Integer, Shift As Integer, ByVal x As Single, ByVal y As Single) 101 | Dim Delta As Single, PT As Single, PL As Single, PW As Single, PH As Single, MaxW As Single, MaxH As Single 102 | 103 | If Cairo.ImageList.Exists("VSplitCursor") Then 104 | W.MouseIconImageKey = IIf(mResizerStyle < 2, "VSplitCursor,16,16", "HSplitCursor,16,16") 105 | Else 106 | W.MousePointer = IIf(mResizerStyle < 2, IDC_SIZEWE, IDC_SIZENS) 107 | End If 108 | If Button = 0 Then Exit Sub 109 | 110 | PL = mDownParentLeft: PT = mDownParentTop 111 | PW = mDownParentWidth: PH = mDownParentHeight 112 | Select Case mResizerStyle 113 | Case ResizerVerticalRightAligned: Delta = x - mDownX: PW = PW + Delta 114 | Case ResizerVerticalLeftAligned: Delta = mDownX - x: PW = PW + Delta: PL = PL - Delta 115 | Case ResizerHorizontalBottomAligned: Delta = y - mDownY: PH = PH + Delta 116 | Case ResizerHorizontalTopAligned: Delta = mDownY - y: PH = PH + Delta: PT = PT - Delta 117 | End Select 118 | 119 | MaxW = MaxWidth 120 | MaxH = MaxHeight 121 | If W.Parent Is W.Root Then 122 | Dim DlgFrm As cWidgetForm 123 | Set DlgFrm = Cairo.WidgetForms.ItemByHWnd(W.Root.DialogFormHwnd) 124 | If Not DlgFrm Is Nothing Then 125 | If DlgFrm.ScaleWidth < MaxW Then MaxW = DlgFrm.ScaleWidth 126 | If DlgFrm.ScaleHeight < MaxH Then MaxH = DlgFrm.ScaleHeight 127 | End If 128 | End If 129 | 130 | If PW < MinWidth Then PW = MinWidth: PL = mDownParentLeft: Delta = 0 131 | If PW > MaxW - 1 Then PW = MaxW - 1: PL = mDownParentLeft: Delta = 0 132 | If PH < MinHeight Then PH = MinHeight: PT = mDownParentTop: Delta = 0 133 | If PH > MaxH - 1 Then PH = MaxH - 1: PT = mDownParentTop: Delta = 0 134 | 135 | ' Debug.Print PT, PH, MaxH, MaxHeight 136 | RaiseEvent ResizerMoved(PL, PT, PW, PH, Delta) 137 | W.RaiseBubblingEvent Me, "ResizerMoved", PL, PT, PW, PH, Delta 138 | mDownParentLeft = W.Parent.Left: mDownParentTop = W.Parent.Top 139 | mDownParentWidth = W.Parent.Width: mDownParentHeight = W.Parent.Height 140 | AlignMe 141 | End Sub 142 | 143 | Private Sub W_MouseUp(Button As Integer, Shift As Integer, ByVal x As Single, ByVal y As Single) 144 | AlignMe 145 | mDown = False 146 | End Sub 147 | 148 | Private Sub W_BubblingEvent(Sender As Object, EventName As String, P1 As Variant, P2 As Variant, P3 As Variant, P4 As Variant, P5 As Variant, P6 As Variant, P7 As Variant) 149 | If EventName = "W_ContainerResize" Then AlignMe 150 | End Sub 151 | 152 | Private Sub AlignMe() 153 | Dim x As Single, y As Single, dx As Single, dy As Single 154 | dx = mSizePixels: dy = mSizePixels 155 | Select Case mResizerStyle 156 | Case ResizerVerticalRightAligned: x = W.Parent.ScaleWidth - dx: dy = W.Parent.ScaleHeight 157 | Case ResizerVerticalLeftAligned: dy = W.Parent.ScaleHeight 158 | Case ResizerHorizontalBottomAligned: y = W.Parent.ScaleHeight - dy: dx = W.Parent.ScaleWidth 159 | Case ResizerHorizontalTopAligned: dx = W.Parent.ScaleWidth 160 | End Select 161 | W.Move x, y, dx, dy 162 | End Sub 163 | 164 | Private Sub W_Paint(CC As cCairoContext, ByVal xAbs As Single, ByVal yAbs As Single, ByVal dx_Aligned As Single, ByVal dy_Aligned As Single, UserObj As Object) 165 | dx = dx_Aligned 166 | dy = dy_Aligned 167 | Alpha = IIf(W.MouseOver Or mDown, 0.6, 0.1) 168 | Draw CC 169 | End Sub 170 | 171 | Private Sub Draw(CC As cCairoContext) 172 | Dim Pat As cCairoPattern, PEndX As Long, PEndY As Long 173 | If dx = 0 Then dx = W.Width 174 | If dy = 0 Then dy = W.Height 175 | PEndX = dx 176 | PEndY = dy 177 | 178 | If mResizerStyle < 2 Then PEndY = 0 Else PEndX = 0 179 | Set Pat = Cairo.CreateLinearPattern(0, 0, PEndX, PEndY) 180 | Pat.AddColorStop 0, W.BackColor, Alpha, 1.4 181 | Pat.AddColorStop 1, W.BackColor, Alpha, 0.7 182 | CC.Rectangle 0, 0, dx, dy 183 | CC.Fill , Pat 184 | End Sub 185 | 186 | 187 | 188 | 189 | 190 | -------------------------------------------------------------------------------- /cwRibbon.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "cwRibbon" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Option Explicit 15 | 16 | Event SelectionChanged(ActiveEntry As cwRibbonEntry) 17 | 18 | Private Alpha As Single, dx As Single, dy As Single 19 | Private mCurrentEntryIndex As Long, mCaptionsHeight As Single 20 | 21 | Private WithEvents W As cWidgetBase 22 | Attribute W.VB_VarHelpID = -1 23 | 24 | Private Sub Class_Initialize() 25 | Set W = Cairo.WidgetBase 26 | W.ForwardFocus = True 27 | 28 | mCurrentEntryIndex = -1 29 | mCaptionsHeight = 20 30 | End Sub 31 | Public Property Get Widget() As cWidgetBase 32 | Set Widget = W 33 | End Property 34 | Public Property Get Widgets() As cWidgets 35 | Set Widgets = W.Widgets 36 | End Property 37 | 38 | Public Sub AddEntry(Caption As String, IconResourceKey As String, AssociatedWidget As Object) 39 | Dim Key As String, NewRibbonEntry As New cwRibbonEntry 40 | NewRibbonEntry.Caption = Caption 41 | NewRibbonEntry.Widget.ImageKey = IconResourceKey 42 | 43 | Key = Widgets.Count \ 2 & "_RibbEntry" 44 | Widgets.Add NewRibbonEntry, Key, EntriesCount * 150, 2, 150, mCaptionsHeight 45 | Widgets.Add AssociatedWidget, Key & "Assoc", 2, mCaptionsHeight, W.Width, W.Height - mCaptionsHeight, False 46 | 47 | AdjustEntries 48 | End Sub 49 | 50 | Private Sub AdjustEntries() 51 | Dim i As Long, y As Single, yy As Single, WEntry As cWidgetBase 52 | If Widgets.Count = 0 Then Exit Sub 53 | W.LockRefresh = True 54 | y = mCaptionsHeight 55 | For i = 0 To mCurrentEntryIndex 56 | 'the cwRibbon-Entry 57 | Set WEntry = Widgets(2 * i + 1).Widget 58 | ' WEntry.Move -1, y, W.Width, mAccEntryHeight 59 | ' y = y + mAccEntryHeight 60 | 61 | 'the associated Widget 62 | Set WEntry = Widgets(2 * i + 2).Widget 63 | If i < mCurrentEntryIndex Then WEntry.Visible = False 64 | Next i 65 | 66 | ' yy = W.ScaleHeight - (Widgets.Count \ 2 - mCurrentEntryIndex - 1) * mAccEntryHeight 67 | If Not WEntry Is Nothing Then 68 | ' WEntry.Move -1, y - 1, W.Width, yy - y + 2 69 | WEntry.Visible = True 70 | WEntry.SetFocus 71 | End If 72 | 73 | y = yy 74 | For i = mCurrentEntryIndex + 1 To Widgets.Count \ 2 - 1 75 | 'the cwAccordeon-Entry 76 | Set WEntry = Widgets(2 * i + 1).Widget 77 | ' WEntry.Move 0, y + 1, W.Width, mAccEntryHeight 78 | ' y = y + mAccEntryHeight 79 | 80 | 'the associated Widget 81 | Set WEntry = Widgets(2 * i + 2).Widget 82 | WEntry.Visible = False 83 | Next i 84 | W.LockRefresh = False 85 | End Sub 86 | 87 | Public Property Get EntriesCount() As Long 88 | EntriesCount = Widgets.Count \ 2 89 | End Property 90 | 91 | Public Function EntryByIndex(ByVal EntryIndexZeroBased As Long) As cwRibbonEntry 92 | If EntryIndexZeroBased < 0 Or EntryIndexZeroBased >= EntriesCount Then Exit Function 93 | Set EntryByIndex = Widgets(EntryIndexZeroBased * 2 + 1) 94 | End Function 95 | 96 | Public Property Get CurrentEntry() As cwRibbonEntry 97 | If EntriesCount = 0 Then Exit Property 98 | Set CurrentEntry = Widgets(CurrentEntryIndex * 2 + 1) 99 | End Property 100 | 101 | Public Property Get CurrentEntryIndex() As Long 102 | CurrentEntryIndex = mCurrentEntryIndex 103 | End Property 104 | Public Property Let CurrentEntryIndex(ByVal NewValue As Long) 105 | If NewValue < -1 Or NewValue >= EntriesCount Then Exit Property 106 | If mCurrentEntryIndex = NewValue Then Exit Property 107 | mCurrentEntryIndex = NewValue 108 | 109 | RaiseEvent SelectionChanged(CurrentEntry) 110 | AdjustEntries 111 | End Property 112 | 113 | Private Sub W_BubblingEvent(Sender As Object, EventName As String, P1 As Variant, P2 As Variant, P3 As Variant, P4 As Variant, P5 As Variant, P6 As Variant, P7 As Variant) 114 | Static FocusChange As Boolean 115 | If TypeOf Sender Is cwRibbonEntry Then 116 | Select Case EventName 117 | Case "W_LostFocus": If Not CurrentEntry Is Sender Then FocusChange = True 118 | Case "W_Click": CurrentEntryIndex = Split(Sender.Widget.Key, "_")(0) 119 | Case "W_KeyPress" 120 | If P1 = vbKeySpace Or P1 = vbKeyReturn Then CurrentEntryIndex = Split(Sender.Widget.Key, "_")(0) 121 | End Select 122 | 123 | ElseIf Not CurrentEntry Is Nothing Then 124 | If Sender Is CurrentEntry.AssociatedWidget Then 125 | If EventName = "W_KeyDown" Then 126 | If Not (P1 = vbKeyTab And P2 = vbShiftMask) Then Exit Sub 127 | If FocusChange Then FocusChange = False: Exit Sub 128 | If CurrentEntryIndex <= 0 Then W.SetFocus Else EntryByIndex(CurrentEntryIndex - 1).Widget.SetFocus 129 | End If 130 | End If 131 | End If 132 | End Sub 133 | 134 | Private Sub W_Resize() 135 | AdjustEntries 136 | End Sub 137 | 138 | Private Sub W_Paint(CC As cCairoContext, ByVal xAbs As Single, ByVal yAbs As Single, ByVal dx_Aligned As Single, ByVal dy_Aligned As Single, UserObj As Object) 139 | dx = dx_Aligned 140 | dy = dy_Aligned 141 | Alpha = W.AlphaInherited 142 | Draw CC 143 | End Sub 144 | 145 | Private Sub Draw(CC As cCairoContext) 146 | Dim i As Long, Pat As cCairoPattern, dyy As Single, TextShadowColor As Long 147 | 148 | 'the Caption-Background 149 | Set Pat = Cairo.CreateLinearPattern(0, 0, 0, dy) 150 | CC.SetLineWidth 0 151 | Pat.AddColorStop 0, W.BackColor, Alpha, 1.09 152 | Pat.AddColorStop 0.95, W.BackColor, Alpha, 0.93 153 | Pat.AddColorStop 1, W.BackColor, Alpha, 1.3 154 | CC.Rectangle 0, 0, dx, dy, True 155 | CC.Fill , Pat 156 | CC.SetLineWidth 1, True 157 | CC.DrawLine 0, dy - 1, dx, dy - 1, True 158 | CC.SetSourceColor W.BorderColor, Alpha * 0.9 159 | CC.Stroke 160 | End Sub 161 | 162 | 163 | -------------------------------------------------------------------------------- /cwRibbonEntry.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "cwRibbonEntry" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Option Explicit 15 | 16 | Private Alpha As Single, dx As Single, dy As Single 17 | Private mCaption As String 18 | 19 | Private WithEvents W As cWidgetBase 20 | Attribute W.VB_VarHelpID = -1 21 | 22 | Private Sub Class_Initialize() 23 | Set W = Cairo.WidgetBase 24 | End Sub 25 | Public Property Get Widget() As cWidgetBase 26 | Set Widget = W 27 | End Property 28 | Public Property Get Widgets() As cWidgets 29 | Set Widgets = W.Widgets 30 | End Property 31 | 32 | Public Property Get Caption() As String 33 | Caption = mCaption 34 | End Property 35 | Public Property Let Caption(ByVal NewValue As String) 36 | Dim AccKey$, Pos& 37 | If mCaption = NewValue Then Exit Property 38 | mCaption = NewValue 39 | W.Refresh 40 | Pos = InStr(Replace(mCaption, "&&", "--"), "&") 41 | If Pos Then AccKey = Mid$(Replace(mCaption, "&&", "--"), Pos + 1, 1) 42 | 43 | If Len(AccKey) Then W.AccessKeys = AccKey 44 | End Property 45 | 46 | Public Property Get IsOpen() As Boolean 47 | IsOpen = W.Parent.Object.CurrentEntryIndex = CLng(Split(W.Key, "_")(0)) 48 | End Property 49 | 50 | Public Property Get AssociatedWidget() As Object 51 | With W.Parent.Widgets 'the associated Widget is always one IndexPosition "below us" 52 | Set AssociatedWidget = .Item(.GetOneBasedChildIndexByKey(W.Key) + 1) 53 | End With 54 | End Property 55 | 56 | Private Sub W_GotFocus() 57 | If IsOpen Then AssociatedWidget.Widget.SetFocus 58 | End Sub 59 | 60 | Private Sub W_MouseEnter(ByVal MouseLeaveWidget As cWidgetBase) 61 | W.Refresh 62 | End Sub 63 | Private Sub W_MouseLeave(ByVal MouseEnterWidget As cWidgetBase) 64 | W.Refresh 65 | End Sub 66 | 67 | Private Sub W_AccessKeyPress(KeyAscii As Integer) 68 | If InStr(1, W.AccessKeys, Chr$(KeyAscii), vbTextCompare) Then 69 | W.SetFocus 70 | W.RaiseBubblingEvent Me, "W_Click" 71 | End If 72 | End Sub 73 | 74 | Private Sub W_Paint(CC As cCairoContext, ByVal xAbs As Single, ByVal yAbs As Single, ByVal dx_Aligned As Single, ByVal dy_Aligned As Single, UserObj As Object) 75 | dx = dx_Aligned 76 | dy = dy_Aligned 77 | Alpha = W.AlphaInherited 78 | Draw CC 79 | End Sub 80 | 81 | Private Sub Draw(CC As cCairoContext) 82 | Dim Pat As cCairoPattern, Color As Long, CaptExt As Double 83 | Dim IconKeys() As String, IconKey As String 84 | 85 | Color = W.ShadeColor(W.BackColor, 0.98) 'default color is the greyish one 86 | If IsOpen Then Color = W.SelectionColor 87 | If W.MouseOver Then Color = W.HoverColor 88 | 89 | 90 | CC.SetLineWidth 1, True 91 | Set Pat = Cairo.CreateLinearPattern(0, 0, 0, dy) 92 | Pat.AddColorStop 0, &HF0F0F0, Alpha 93 | Pat.AddColorStop 0.03, &HF0F0F0, Alpha 94 | Pat.AddColorStop 0.05, Color, Alpha, 0.97 95 | Pat.AddColorStop 0.1, Color, Alpha, 0.93 96 | Pat.AddColorStop 0.88, Color, Alpha, 1.03 97 | Pat.AddColorStop 1, Color, Alpha, 1.2 98 | CC.Rectangle 0, 0, dx, dy, True 99 | CC.Fill , Pat 100 | CC.SetSourceColor W.BorderColor, Alpha 101 | CC.DrawLine 0, dy - 1, dx, dy - 1, True 102 | CC.Stroke 103 | 104 | 105 | 'the focused area and a dotted rectangle 106 | If W.Focused Then 107 | CaptExt = CC.GetTextExtents(mCaption) 'measure the current Pixel-Len of the caption-text 108 | 109 | CC.RoundedRect dy - 3, 3, CaptExt + 4, dy - 7, 3, True 110 | CC.SetSourceColor W.FocusColor, Alpha * 0.3, 1.1 111 | CC.Fill 112 | Cairo.Theme.DrawTo CC, W, thmTypeDottedRectangle, 0, dy - 3, 3, CaptExt + 4, dy - 7, 2 113 | End If 114 | 115 | 'the Icon (if there was a resource-info given in the W.ImageKey) 116 | If Len(W.ImageKey) Then 117 | IconKeys = Split(W.ImageKey, ",") 118 | IconKey = Trim$(IconKeys(0)) 119 | If IsOpen Then 'we are the currently active (open and expanded) entry 120 | If UBound(IconKeys) > 0 Then IconKey = Trim$(IconKeys(1)) 121 | End If 122 | CC.RenderSurfaceContent IconKey, 3, 3, dy - 7, dy - 7, , Alpha 123 | End If 124 | 125 | 'the Caption-Text 126 | ' W.SelectFontSettingsInto CC, &HEEEEFF 127 | ' CC.DrawText dy - 7, 0, dx, dy - 1, mCaption, True, vbLeftJustify, 6, True, dtHasAccelerators, Alpha 128 | W.SelectFontSettingsInto CC 129 | CC.DrawText dy - 7, 1, dx, dy, mCaption, True, vbLeftJustify, 6, True, dtHasAccelerators, Alpha 130 | End Sub 131 | 132 | 133 | 134 | -------------------------------------------------------------------------------- /cwScoringLabel.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "cwScoringLabel" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Option Explicit 15 | 16 | Private Alpha As Single, dx As Single, dy As Single 17 | Private mCaptionTop As String 18 | Private mCaptionBottom As String 19 | Private mFractionLineWidth As Long 20 | Private mSingleLine As Boolean 21 | Private mInnerSpace As Long 22 | Private mBorderWidth As Long 23 | 24 | '****---- Start of cwImplementation-Conventions ----**** 25 | Private WithEvents W As cWidgetBase 26 | Attribute W.VB_VarHelpID = -1 27 | Private Sub Class_Initialize() 28 | 29 | Set W = Cairo.WidgetBase '<- this is required in each cwImplementation... 30 | 31 | 'some default-inits on our Widget-internal, local 'm' Variables 32 | mBorderWidth = 1 33 | mFractionLineWidth = 3 34 | mInnerSpace = 1 '1 Pixel Offset for the Text-Rendering - independent from (and additionally to) the BorderSize) 35 | mCaptionTop = "0" 36 | mCaptionBottom = "0" 37 | 38 | '...and the following "W-Defaults-adaptions" are done individually (as needed for the control in question) 39 | W.SetClientAreaOffsets mBorderWidth, mBorderWidth, mBorderWidth, mBorderWidth '<- this defines a widget-client-area 40 | W.CanGetFocus = False 'this way the Label will not be respected in the "Focus-Switch-Chain" 41 | 42 | End Sub 43 | 44 | Public Property Get Widget() As cWidgetBase 45 | Set Widget = W 46 | End Property 47 | Public Property Get Widgets() As cWidgets 48 | Set Widgets = W.Widgets 49 | End Property 50 | '****---- End of cwImplementation-Conventions ----**** 51 | 52 | 53 | Public Property Get CaptionTop() As String 54 | CaptionTop = mCaptionTop 55 | End Property 56 | Public Property Let CaptionTop(ByVal NewValue As String) 57 | If mCaptionTop = NewValue Then Exit Property 58 | mCaptionTop = NewValue 59 | W.Refresh 'a change of the Caption will require a Redraw, so let's signal that over W 60 | End Property 61 | 62 | Public Property Get CaptionBottom() As String 63 | CaptionBottom = mCaptionBottom 64 | End Property 65 | Public Property Let CaptionBottom(ByVal NewValue As String) 66 | If mCaptionBottom = NewValue Then Exit Property 67 | mCaptionBottom = NewValue 68 | W.Refresh 'a change of the Caption will require a Redraw, so let's signal that over W 69 | End Property 70 | 71 | Public Property Get BorderWidth() As Long 72 | BorderWidth = mBorderWidth 73 | End Property 74 | Public Property Let BorderWidth(ByVal NewValue As Long) 75 | If mBorderWidth = NewValue Then Exit Property 76 | mBorderWidth = NewValue 77 | W.SetClientAreaOffsets mBorderWidth, mBorderWidth, mBorderWidth, mBorderWidth 78 | W.Refresh 'a change of the BorderWidth will require a Redraw, so let's signal that over W 79 | End Property 80 | 81 | Public Property Get FractionLineWidth() As Long 82 | FractionLineWidth = mFractionLineWidth 83 | End Property 84 | Public Property Let FractionLineWidth(ByVal NewValue As Long) 85 | If mFractionLineWidth = NewValue Then Exit Property 86 | mFractionLineWidth = NewValue 87 | W.Refresh 'a change of the BorderWidth will require a Redraw, so let's signal that over W 88 | End Property 89 | 90 | Public Property Get InnerSpace() As Long 91 | InnerSpace = mInnerSpace 92 | End Property 93 | Public Property Let InnerSpace(ByVal NewValue As Long) 94 | If mInnerSpace = NewValue Then Exit Property 95 | mInnerSpace = NewValue 96 | W.Refresh 'a change of the InnerSpace will require a Redraw, so let's signal that over W 97 | End Property 98 | 99 | Public Property Get SingleLine() As Boolean 100 | SingleLine = mSingleLine 101 | End Property 102 | Public Property Let SingleLine(ByVal NewValue As Boolean) 103 | If mSingleLine = NewValue Then Exit Property 104 | mSingleLine = NewValue 105 | W.Refresh 'a change of the SingleLine-Mode will require a Redraw, so let's signal that over W 106 | End Property 107 | 108 | Private Sub W_Paint(CC As cCairoContext, ByVal xAbs As Single, ByVal yAbs As Single, ByVal dx_Aligned As Single, ByVal dy_Aligned As Single, UserObj As Object) 109 | Alpha = W.AlphaInherited 110 | dx = dx_Aligned 111 | dy = dy_Aligned 112 | 113 | Draw CC, W.AbsLeft - xAbs, W.AbsTop - yAbs 'here we just delegate to our internal Drawing-Routine... 114 | End Sub 115 | 116 | Private Sub Draw(CC As cCairoContext, ByVal x As Single, ByVal y As Single) 117 | Dim captionTopWidth As Double 118 | Dim captionBottomWidth As Double 119 | Dim mFontHeight As Double 120 | 121 | CC.SetLineWidth mBorderWidth 122 | If W.BackColor <> -1 Then 123 | CC.Rectangle x, y, W.Width, W.Height, True '<-- note the last optional Param, which ensures a Pixel-aligned drawing inside the Widgets-Bounds 124 | CC.SetSourceColor W.BackColor, W.Alpha 125 | CC.Fill 126 | End If 127 | If W.BorderColor <> -1 Then 128 | CC.Rectangle x, y, W.Width, W.Height, True '<-- note the last optional Param, which ensures a Pixel-aligned drawing inside the Widgets-Bounds 129 | CC.SetSourceColor W.BorderColor, W.Alpha 130 | CC.Stroke 131 | End If 132 | 133 | CC.SelectFont W.FontName, W.FontSize, W.ForeColor, W.FontBold, W.FontItalic 134 | captionTopWidth = CC.GetTextExtents(mCaptionTop) 135 | captionBottomWidth = CC.GetTextExtents(mCaptionBottom) 136 | mFontHeight = CC.GetFontHeight 137 | 138 | CC.SetSourceColor W.ForeColor 139 | If captionTopWidth > captionBottomWidth Then 140 | CC.RoundedRect _ 141 | (W.ScaleWidth - captionTopWidth) / 2, _ 142 | (W.ScaleHeight - mFractionLineWidth) / 2, _ 143 | captionTopWidth, _ 144 | mFractionLineWidth, 5, True 145 | Else 146 | CC.RoundedRect _ 147 | (W.ScaleWidth - captionBottomWidth) / 2, _ 148 | (W.ScaleHeight - mFractionLineWidth) / 2, _ 149 | captionBottomWidth, _ 150 | mFractionLineWidth, 5, True 151 | 152 | End If 153 | CC.Fill 154 | 155 | CC.DrawText 0, (W.ScaleHeight - mFractionLineWidth) / 2 - mFontHeight, W.ScaleWidth, W.ScaleHeight / 2, mCaptionTop, mSingleLine, vbCenter, mInnerSpace, 0 156 | CC.DrawText 0, (W.ScaleHeight + mFractionLineWidth) / 2, W.ScaleWidth, W.ScaleHeight / 2, mCaptionBottom, mSingleLine, vbCenter, mInnerSpace, 0 157 | End Sub 158 | 159 | 160 | -------------------------------------------------------------------------------- /cwStatusBar.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "cwStatusBar" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Option Explicit 15 | 16 | Event OwnerDrawOnTop(CC As cCairoContext, ByVal dx As Single, ByVal dy As Single) 17 | 18 | Private Alpha As Single, dx As Single, dy As Single, mCaption As String 19 | 20 | Private WithEvents W As cWidgetBase 21 | Attribute W.VB_VarHelpID = -1 22 | 23 | Private Sub Class_Initialize() 24 | Set W = Cairo.WidgetBase 25 | W.ForwardFocus = True 26 | End Sub 27 | Public Property Get Widget() As cWidgetBase: Set Widget = W: End Property 28 | Public Property Get Widgets() As cWidgets: Set Widgets = W.Widgets: End Property 29 | 30 | Public Property Get Caption() As String 31 | Caption = mCaption 32 | End Property 33 | Public Property Let Caption(ByVal NewValue As String) 34 | If mCaption = NewValue Then Exit Property 35 | mCaption = NewValue 36 | W.Refresh 37 | End Property 38 | 39 | Private Sub W_AddedToHierarchy() 40 | AdjustAlignment 41 | End Sub 42 | 43 | Private Sub W_BubblingEvent(Sender As Object, EventName As String, P1 As Variant, P2 As Variant, P3 As Variant, P4 As Variant, P5 As Variant, P6 As Variant, P7 As Variant) 44 | If EventName = "W_ContainerResize" Then AdjustAlignment 45 | End Sub 46 | 47 | Private Sub AdjustAlignment() 48 | W.Move 0, W.Parent.ScaleHeight - W.Height, W.Parent.ScaleWidth, W.Height 49 | End Sub 50 | 51 | Private Sub W_Paint(CC As cCairoContext, ByVal xAbs As Single, ByVal yAbs As Single, ByVal dx_Aligned As Single, ByVal dy_Aligned As Single, UserObj As Object) 52 | dx = dx_Aligned 53 | dy = dy_Aligned 54 | Alpha = W.AlphaInherited 55 | Draw CC 56 | End Sub 57 | 58 | Private Sub Draw(CC As cCairoContext) 59 | Dim Pat As cCairoPattern 60 | If dx = 0 Then dx = W.Width 61 | If dy = 0 Then dy = W.Height 62 | 63 | Set Pat = Cairo.CreateLinearPattern(0, 0, 0, dy) 64 | Pat.AddColorStop 0, W.BackColor, Alpha, 1.1 65 | Pat.AddColorStop 1, W.BackColor, Alpha, 0.9 66 | CC.Rectangle 0, 0, dx + 1, dy + 1 67 | CC.Fill , Pat 68 | 69 | CC.SetLineCap CAIRO_LINE_CAP_SQUARE 70 | CC.SetLineWidth 1, True 71 | CC.SetSourceColor W.BorderColor, 0.8 72 | CC.DrawLine 0, 0, dx, 0, True 73 | CC.Stroke 74 | ' CC.SetSourceColor vbWhite, 0.8 75 | ' CC.DrawLine 0, 1, dx, 1, True 76 | ' CC.Stroke 77 | ' CC.SetSourceColor vbWhite, 0.8, 0.85 78 | ' CC.DrawLine 0, dy - 1, dx, dy - 1, True 79 | ' CC.Stroke 80 | W.SelectFontSettingsInto CC, vbWhite 81 | If Len(mCaption) Then CC.DrawText 7, 1, dx - 7, dy, mCaption, , vbLeftJustify, 2, True, , 0.7 82 | W.SelectFontSettingsInto CC 83 | If Len(mCaption) Then CC.DrawText 7, 0, dx - 7, dy, mCaption, , vbLeftJustify, 2, True 84 | 85 | RaiseEvent OwnerDrawOnTop(CC, dx, dy) 86 | W.RaiseBubblingEvent Me, "OwnerDrawOnTop", CC, dx, dy 87 | End Sub 88 | 89 | -------------------------------------------------------------------------------- /cwToolBar.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "cwToolBar" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Option Explicit 15 | 16 | Event Click(Sender As cwToolBarItem) 17 | Event ArrowClick(Sender As cwToolBarItem) 18 | 19 | Public Enum DropDownArrowType 20 | ddNone = 0 21 | ddCrumbBar = 1 22 | ddDropDown = 2 23 | End Enum 24 | 25 | Public AllowGripperDrawing As Boolean 26 | 27 | Private dx As Single, dy As Single, Alpha As Single 28 | Private WithEvents W As cWidgetBase 29 | Attribute W.VB_VarHelpID = -1 30 | 31 | Private Sub Class_Initialize() 32 | AllowGripperDrawing = True 33 | Set W = Cairo.WidgetBase 34 | W.ForwardFocus = True 35 | ' W.CanGetFocus = False 36 | End Sub 37 | 38 | Public Property Get Widget() As cWidgetBase 39 | Set Widget = W 40 | End Property 41 | Public Property Get Widgets() As cWidgets 42 | Set Widgets = W.Widgets 43 | End Property 44 | 45 | Public Function AddItem(Key As String, Optional ImageKey As String, Optional Caption As String, Optional ByVal ArrowType As DropDownArrowType, Optional ToolTip As String, Optional ByVal Enabled As Boolean = True, Optional ByVal IsCheckable As Boolean) As cwToolBarItem 46 | Dim NewItem As cwToolBarItem, WLastItem As cWidgetBase 47 | Dim xOffs As Single, Width As Single, TxtWidth As Double 48 | Set NewItem = New cwToolBarItem 49 | NewItem.Widget.ToolTip = ToolTip 50 | NewItem.Widget.ImageKey = ImageKey 51 | NewItem.Widget.ToolTipDelay = W.ToolTipDelay 52 | NewItem.Widget.FontName = W.FontName 53 | NewItem.Widget.FontSize = W.FontSize 54 | NewItem.Widget.Enabled = Enabled 55 | NewItem.Caption = Caption 56 | NewItem.ArrowType = ArrowType 57 | NewItem.IsCheckable = IsCheckable 58 | 59 | xOffs = 9 60 | If Widgets.Count Then 61 | Set WLastItem = Widgets(Widgets.Count).Widget 62 | xOffs = WLastItem.Left + WLastItem.Width 63 | End If 64 | If Len(ImageKey) Then Width = dy - 5 65 | If Len(Caption) Then 66 | If Caption = "-" Then 67 | Width = 6 68 | Else 69 | With W.MeasureContext 70 | Width = Width + .GetTextExtents(Caption) + 10 71 | End With 72 | End If 73 | End If 74 | If ArrowType Then Width = Width + 15 75 | Widgets.Add NewItem, Key, 1 + xOffs, 3, Width, dy - 5 76 | Set AddItem = NewItem 77 | End Function 78 | 79 | Private Sub W_AddedToHierarchy() 80 | dx = W.Width 81 | dy = W.Height 82 | W_ContainerResize 83 | End Sub 84 | 85 | Private Sub W_BubblingEvent(Sender As Object, EventName As String, P1 As Variant, P2 As Variant, P3 As Variant, P4 As Variant, P5 As Variant, P6 As Variant, P7 As Variant) 86 | If Sender Is Nothing Then Exit Sub 87 | If TypeOf Sender Is cwToolBarItem And Left(EventName, 2) <> "W_" Then 'reflect the two normal Events of a cwToolBarItem 88 | If EventName = "Click" Then RaiseEvent Click(Sender) 89 | If EventName = "ArrowClick" Then RaiseEvent ArrowClick(Sender) 90 | End If 91 | End Sub 92 | 93 | Private Sub W_ContainerResize() 94 | W.Move 0, W.Top, W.Parent.ScaleWidth, W.Height 95 | W.Refresh 96 | End Sub 97 | 98 | Private Sub W_Paint(CC As cCairoContext, ByVal xAbs As Single, ByVal yAbs As Single, ByVal dx_Aligned As Single, ByVal dy_Aligned As Single, UserObj As Object) 99 | dx = dx_Aligned 100 | dy = dy_Aligned 101 | Alpha = W.AlphaInherited 102 | Draw CC 103 | End Sub 104 | 105 | Private Sub Draw(CC As cCairoContext) 106 | Dim Pat As cCairoPattern 107 | Set Pat = Cairo.CreateLinearPattern(0, 0, 0, dy) 108 | Pat.AddColorStop 0, W.BackColor, Alpha, 1.11 109 | Pat.AddColorStop 1, W.BackColor, Alpha, 0.93 110 | CC.Paint , Pat 111 | CC.DrawLine 0, dy - 1, dx, dy - 1, True, 1, vbBlack, 0.3 * Alpha 112 | 113 | If AllowGripperDrawing Then 114 | W.Alpha = 0.85 * Alpha 115 | Cairo.Theme.DrawTo CC, W, thmTypeSeparatorLine, 0, 5, 3, 1, dy - 4 116 | Cairo.Theme.DrawTo CC, W, thmTypeSeparatorLine, 0, 7, 3, 1, dy - 4 117 | W.Alpha = Alpha 118 | End If 119 | End Sub 120 | 121 | -------------------------------------------------------------------------------- /cwToolBarItem.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "cwToolBarItem" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Option Explicit 15 | 16 | Event Click() 17 | Event ArrowClick() 18 | 19 | Public Caption As String, IsCheckable As Boolean, ArrowType As DropDownArrowType 20 | 21 | Private BDown As Boolean, OutSide As Boolean, MOverArrow As Boolean, mChecked As Boolean 22 | 23 | Private dx As Single, dy As Single, Alpha As Single 24 | Private WithEvents W As cWidgetBase, WithEvents tmrDecouple As cTimer 25 | Attribute W.VB_VarHelpID = -1 26 | Attribute tmrDecouple.VB_VarHelpID = -1 27 | 28 | Private Sub Class_Initialize() 29 | Set W = Cairo.WidgetBase 30 | W.CanGetFocus = False 31 | End Sub 32 | 33 | Public Property Get Widget() As cWidgetBase 34 | Set Widget = W 35 | End Property 36 | Public Property Get Widgets() As cWidgets 37 | Set Widgets = W.Widgets 38 | End Property 39 | 40 | Private Sub Class_Terminate() 41 | Set tmrDecouple = Nothing 42 | End Sub 43 | 44 | Private Sub W_MouseDown(Button As Integer, Shift As Integer, ByVal x As Single, ByVal y As Single) 45 | If Button = 1 Then BDown = True: W.Refresh 46 | End Sub 47 | Private Sub W_MouseMove(Button As Integer, Shift As Integer, ByVal x As Single, ByVal y As Single) 48 | OutSide = (x < 0 Or x > dx Or y < 0 Or y > dy) 49 | MOverArrow = IIf(ArrowType > 0 And Not OutSide And x > dx - 16, True, False) 50 | W.Refresh 51 | End Sub 52 | Private Sub W_MouseUp(Button As Integer, Shift As Integer, ByVal x As Single, ByVal y As Single) 53 | If BDown And Not OutSide Then CheckAndRaiseClick 54 | BDown = False: OutSide = False: W.Refresh 55 | End Sub 56 | 57 | Public Property Get Checked() As Boolean 58 | Checked = mChecked 59 | End Property 60 | Public Property Let Checked(ByVal NewValue As Boolean) 61 | If mChecked = NewValue Or Not IsCheckable Then Exit Property 62 | mChecked = NewValue 63 | Set tmrDecouple = New_c.Timer(15, True, MOverArrow) 64 | W.Refresh 65 | End Property 66 | 67 | Private Sub CheckAndRaiseClick() 68 | If Not MOverArrow And IsCheckable Then mChecked = Not mChecked 69 | Set tmrDecouple = New_c.Timer(15, True, MOverArrow) 70 | End Sub 71 | 72 | Private Sub tmrDecouple_Timer() 73 | Dim OverArrow As Boolean 74 | OverArrow = tmrDecouple.Tag 75 | Set tmrDecouple = Nothing 76 | If OverArrow Then 77 | RaiseEvent ArrowClick 78 | W.RaiseBubblingEvent Me, "ArrowClick" 79 | Else 80 | RaiseEvent Click 81 | W.RaiseBubblingEvent Me, "Click" 82 | End If 83 | End Sub 84 | 85 | Private Sub W_MouseEnter(ByVal MouseLeaveWidget As vbRichClient5.cWidgetBase) 86 | W.Refresh 87 | End Sub 88 | Private Sub W_MouseLeave(ByVal MouseEnterWidget As vbRichClient5.cWidgetBase) 89 | MOverArrow = False 90 | W.Refresh 91 | End Sub 92 | 93 | Private Sub W_Paint(CC As cCairoContext, ByVal xAbs As Single, ByVal yAbs As Single, ByVal dx_Aligned As Single, ByVal dy_Aligned As Single, UserObj As Object) 94 | dx = dx_Aligned 95 | dy = dy_Aligned - 2 96 | Alpha = W.AlphaInherited 97 | Draw CC 98 | End Sub 99 | 100 | Private Sub Draw(CC As cCairoContext) 101 | Dim Srf As cCairoSurface, Pat As cCairoPattern, State As enmThemeDrawingState 102 | Dim TxtWidth As Double, FontHeight As Double, xOffs As Single, IcoOffs As Long 103 | Const ArrowSize& = 8 104 | 105 | If Caption = "-" Then 106 | W.Alpha = 0.85 107 | Cairo.Theme.DrawTo CC, W, thmTypeSeparatorLine, 0, 2, 1, 1, dy 108 | W.Alpha = Alpha 109 | Exit Sub 110 | End If 111 | 112 | IcoOffs = IIf(Len(Caption), 5, 3) 113 | If Len(W.ImageKey) Then xOffs = dy 114 | 115 | If W.Enabled Then 116 | CC.SetLineWidth IIf(BDown Or mChecked, 1.1, 1) 117 | 118 | If BDown Or mChecked Then 119 | If MOverArrow And Not mChecked Then CC.ClipExplicit dx - 16, 0, dx, dy 120 | CC.RoundedRect 0, 0, dx, dy, 2.2, True 121 | CC.SetSourceColor W.Parent.BackColor, Alpha, 0.89 122 | CC.Fill 123 | If MOverArrow And Not mChecked Then CC.ResetClip 124 | End If 125 | 126 | If W.MouseOver Or mChecked Then 127 | CC.RoundedRect 0, 0, dx, dy, 2.2, True 128 | Set Pat = Cairo.CreateLinearPattern(0, 0, 0, dy) 129 | Pat.AddColorStop 0, vbWhite, , IIf(BDown Or mChecked, 0.48, 0.82) 130 | Pat.AddColorStop 1, vbWhite, , IIf(BDown Or mChecked, 0.61, 0.48) 131 | CC.Stroke , Pat 132 | CC.DrawLine 1.5, dy - 0.2, dx - 2.5, dy - 0.2, True, 1, IIf(BDown Or mChecked, vbWhite, vbBlack), 0.2 133 | 134 | If ArrowType <> ddNone And W.MouseOver Then 135 | W.Alpha = 0.85 136 | Cairo.Theme.DrawTo CC, W, thmTypeSeparatorLine, 0, dx - 16, 2, 1, dy - 3 137 | W.Alpha = Alpha 138 | End If 139 | End If 140 | 141 | If Len(W.ImageKey) Then CC.RenderSurfaceContent W.ImageKey, IcoOffs, 2.5, 19, 19, CAIRO_FILTER_BEST, W.Alpha, True 142 | 143 | W.SelectFontSettingsInto CC 144 | If Len(Caption) Then CC.TextOut 5 + xOffs, 4, Caption 145 | 146 | Else 'disabled state 147 | Set Srf = Cairo.ImageList(W.ImageKey).CreateSimilar(, , , True) 148 | Srf.AdjustColors -88, 100 149 | Srf.AdjustColors 100 150 | Srf.AdjustColors 100 151 | CC.RenderSurfaceContent Srf, IcoOffs, 2.5, 19, 19, CAIRO_FILTER_BEST, 0.3, True 152 | 153 | W.SelectFontSettingsInto CC, W.DisabledColor 154 | If Len(Caption) Then CC.TextOut 5 + xOffs, 4, Caption 155 | End If 156 | 157 | If ArrowType Then 158 | If MOverArrow Then State = thmStateHovered 159 | If ArrowType = ddCrumbBar Then 160 | Cairo.Theme.DrawTo CC, W, thmTypeArrow, State, dx - 11.5, (dy - ArrowSize) \ 2, ArrowSize, ArrowSize, 0, IIf(MOverArrow, thmDirectionDown, thmDirectionRight) 161 | Else 162 | Cairo.Theme.DrawTo CC, W, thmTypeArrow, State, dx - 11.5, (dy - ArrowSize) \ 2, ArrowSize, ArrowSize, 0, thmDirectionDown 163 | End If 164 | End If 165 | End Sub 166 | -------------------------------------------------------------------------------- /cwTree.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "cwTree" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Option Explicit 15 | 16 | Event OwnerDrawItem(ByVal Index As Long, CC As cCairoContext, ByVal dx As Single, ByVal dy As Single, ByVal Alpha As Single) 17 | Event Click() 18 | Event DblClick() 19 | Event MouseUpClick() 20 | Event MouseMoveOnListItem(ByVal HoverIndex As Long, ByVal RelX As Single, ByVal RelY As Single) 21 | 22 | Public WithEvents VList As cwVList 'we inherit visually from a preimplemented Widget 23 | Attribute VList.VB_VarHelpID = -1 24 | Public DoubleClickExpandsNodes As Boolean 25 | 26 | Private mDataSourceKey As String, WithEvents mDS As cDataSource, WithEvents tmrDecouple As cTimer 27 | Attribute mDS.VB_VarHelpID = -1 28 | Attribute tmrDecouple.VB_VarHelpID = -1 29 | Private WithEvents W As cWidgetBase 30 | Attribute W.VB_VarHelpID = -1 31 | 32 | Private mCaption As String 33 | Private mLastHoverIndex As Long, mLastArrowSize As Single, mLastArrowXOffs As Single, mInArrowArea As Boolean, mLastMouseDownHoverIndex As Long 34 | 35 | Private Sub Class_Initialize() 36 | Set VList = New cwVList 'the Widget-Instance, to inherit from 37 | VList.RowHeight = 21 38 | VList.ListCount = 0 39 | VList.AllowLeftRightKeys = False 40 | 41 | 'the following is some kind of "visual inheritance", since we use the already existent 'W' 42 | 'from the VList, instead of creating our own, new 'W'-instance per: Set W = Cairo.WidgetBase 43 | Set W = VList.Widget 44 | DoubleClickExpandsNodes = True 'set the default to Expand/Collapse also on DoubleClicks 45 | End Sub 46 | Public Property Get Widget() As cWidgetBase 47 | Set Widget = W 48 | End Property 49 | Public Property Get Widgets() As cWidgets 50 | Set Widgets = W.Widgets 51 | End Property 52 | 53 | '*** Public Properties **** 54 | Public Property Get DataSourceKey() As String 55 | DataSourceKey = mDataSourceKey 56 | End Property 57 | Public Property Let DataSourceKey(ByVal NewValue As String) 58 | mDataSourceKey = NewValue 59 | On Error Resume Next 60 | Set DataSource = Cairo.DataSources(mDataSourceKey) 61 | On Error GoTo 0 62 | End Property 63 | 64 | Public Property Get DataSource() As cDataSource 65 | Set DataSource = mDS 66 | End Property 67 | Public Property Set DataSource(DS As cDataSource) 68 | Set mDS = DS 69 | mDS.TreeRefresh 70 | 71 | VList.ListIndex = -1 'the DS is at BOF after that (no selection) 72 | VList.ListCount = mDS.TreeVisibleCount 73 | End Property 74 | 75 | Public Property Get ListCount() As Long 76 | ListCount = VList.ListCount 77 | End Property 78 | Public Property Let ListCount(ByVal NewValue As Long) 79 | VList.ListCount = NewValue 80 | End Property 81 | 82 | Public Property Get ListIndex() As Long 83 | ListIndex = VList.ListIndex 84 | End Property 85 | Public Property Let ListIndex(ByVal NewValue As Long) 86 | VList.ListIndex = NewValue 87 | End Property 88 | 89 | Public Property Get Caption() As String 90 | Caption = mCaption 91 | End Property 92 | Public Property Let Caption(ByVal NewValue As String) 93 | Dim Btn As cwButton 94 | If mCaption = NewValue Then Exit Property 95 | mCaption = NewValue 96 | If Len(mCaption) Then 97 | If VList.HeaderHeight = 0 Then VList.HeaderHeight = 23 98 | If Not Widgets.Exists("btnExpand") Then 99 | MakeCaptionButton "btnExpand", 3, "6", "Expand all", vbGreen 100 | MakeCaptionButton "btnCollapse", 20, "5", "Collapse all", vbCyan 101 | End If 102 | Else 103 | VList.HeaderHeight = 0 104 | Widgets.Remove "btnExpand" 105 | Widgets.Remove "btnCollapse" 106 | End If 107 | W.Refresh 108 | End Property 109 | 110 | Private Sub MakeCaptionButton(Key As String, ByVal xOffs As Long, Caption As String, ToolTip As String, BackColor As Long) 111 | Dim Btn As cwButton 112 | Set Btn = Widgets.Add(New cwButton, Key, xOffs, (VList.HeaderHeight - 17) \ 2, 17, 17) 113 | Btn.Widget.CanGetFocus = False 114 | Btn.Widget.ToolTip = ToolTip 115 | Btn.Widget.BackColor = BackColor 116 | Btn.Widget.BorderColor = W.ShadeColor(W.BorderColor, 4) 117 | Btn.Widget.FocusColor = W.ShadeColor(W.BorderColor, 3) 118 | Btn.Widget.HoverColor = W.ShadeColor(Btn.Widget.BackColor, 1.5) 119 | Btn.Widget.FontName = "WebDings" 120 | Btn.Caption = Caption 121 | Btn.BorderRadius = 8 122 | Btn.DownStateCaptionOffset = 0 123 | End Sub 124 | 125 | Public Property Get LastMouseDownIndex() As Long 126 | LastMouseDownIndex = mLastMouseDownHoverIndex 127 | End Property 128 | 129 | Public Sub DrawArrow(CC As cCairoContext, ByVal Index As Long, ByVal xOffs As Single, ByVal ArrowSize As Single, ByVal Expanded As Boolean, Optional ByVal Expandable As Boolean = True) 130 | Dim State As enmThemeDrawingState 131 | If mLastHoverIndex = Index Then 132 | mLastArrowSize = ArrowSize 133 | mLastArrowXOffs = xOffs 134 | If mInArrowArea Then State = thmStateHovered 135 | End If 136 | If Expandable Then 137 | Cairo.Theme.DrawTo CC, W, thmTypeArrow, State, xOffs, (VList.RowHeight - ArrowSize) \ 2 + 1, ArrowSize, ArrowSize, 0, _ 138 | IIf(Expanded, thmDirectionSE, thmDirectionRight) 139 | End If 140 | End Sub 141 | 142 | '------------ all the different Event-Handlers ------------------------ 143 | Private Sub mDS_TreeStateChanged(ByVal Node As vbRichClient5.cCollection, ByVal Reason As TreeChangeReason) 144 | Set tmrDecouple = New_c.Timer(100, True, "TreeStateChanged") 145 | End Sub 146 | 147 | Private Sub mDS_Move(ByVal NewRowIdxZeroBased As Long) 148 | If VList.ListIndex = NewRowIdxZeroBased Then Exit Sub 149 | VList.ListIndex = NewRowIdxZeroBased 150 | End Sub 151 | 152 | Private Sub VList_Click() 153 | Dim DoRaise As Boolean 154 | If Not mDS Is Nothing Then 155 | If VList.ListIndex = -1 And mDS.AbsolutePosition > 0 Then 156 | mDS.MoveFirst 157 | mDS.MovePrevious 'ensure BOF-Position 158 | DoRaise = True 159 | ElseIf VList.ListIndex <> -1 And mDS.AbsolutePosition <> VList.ListIndex + 1 Then 160 | mDS.AbsolutePosition = VList.ListIndex + 1 161 | DoRaise = True 162 | End If 163 | 164 | ' If mDS.Count > 0 Then 165 | ' If VList.ListIndex = -1 And mDS.AbsolutePosition <> VList.ListIndex Then 166 | ' mDS.MoveFirst 167 | ' mDS.MovePrevious 168 | ' DoRaise = True 169 | ' ElseIf mDS.AbsolutePosition <> VList.ListIndex + 1 Then 170 | ' mDS.AbsolutePosition = VList.ListIndex + 1 171 | ' DoRaise = True 172 | ' End If 173 | ' End If 174 | End If 175 | If DoRaise Then 176 | RaiseEvent Click 177 | W.RaiseBubblingEvent Me, "Click" 178 | End If 179 | End Sub 180 | 181 | Private Sub VList_DblClick() 182 | If mInArrowArea Then Exit Sub 183 | 184 | RaiseEvent DblClick 185 | W.RaiseBubblingEvent Me, "DblClick" 186 | If DoubleClickExpandsNodes Then ExpandOrCollapse VList.ListIndex 187 | End Sub 188 | 189 | Private Sub VList_MouseMoveOnListItem(ByVal HoverIndex As Long, ByVal RelX As Single, ByVal RelY As Single) 190 | Dim InArrowArea As Boolean 191 | If mLastHoverIndex <> HoverIndex Then 192 | mInArrowArea = False 193 | mLastHoverIndex = HoverIndex 194 | W.Refresh 195 | End If 196 | InArrowArea = (RelX > mLastArrowXOffs - 4 And RelX < mLastArrowXOffs + mLastArrowSize + 4) 197 | ' Debug.Print HoverIndex, InArrowArea 198 | If InArrowArea <> mInArrowArea Then 199 | mInArrowArea = InArrowArea 200 | W.Refresh 201 | Else 202 | If Not VList.ShowHoverBar Then W.Refresh 203 | End If 204 | RaiseEvent MouseMoveOnListItem(HoverIndex, RelX, RelY) 205 | End Sub 206 | 207 | Private Sub VList_MouseUpClick() 208 | RaiseEvent MouseUpClick 209 | W.RaiseBubblingEvent Me, "MouseUpClick" 210 | End Sub 211 | 212 | Private Sub VList_OwnerDrawHeader(CC As vbRichClient5.cCairoContext, ByVal dx As Single, ByVal dy As Single, ByVal Alpha As Single) 213 | If Len(mCaption) = 0 Then Exit Sub 214 | Cairo.Theme.DrawTo CC, W, thmTypeButtonFace, 0, -1, -2, dx + 3, dy + 3, 1, thmDirectionDown 215 | Cairo.Theme.DrawTo CC, W, thmTypeShine, 0, 0, -1, dx, Int((dy + 2) \ 2) - 1, 0, thmDirectionDown 216 | 217 | CC.DrawLine 0, dy, dx, dy, True, 1, W.BorderColor, 0.3 218 | W.SelectFontSettingsInto CC 219 | CC.DrawText 40, 1, dx - 40, dy, mCaption, True, vbLeftJustify, 2, True 220 | End Sub 221 | 222 | Private Sub VList_OwnerDrawItem(ByVal Index As Long, CC As cCairoContext, ByVal dx As Single, ByVal dy As Single, ByVal Alpha As Single) 223 | RaiseEvent OwnerDrawItem(Index, CC, dx, dy, Alpha) 224 | End Sub 225 | 226 | Private Sub W_BubblingEvent(Sender As Object, EventName As String, P1 As Variant, P2 As Variant, P3 As Variant, P4 As Variant, P5 As Variant, P6 As Variant, P7 As Variant) 227 | Dim W As cWidgetBase 228 | 229 | If mDS Is Nothing Or Sender Is Nothing Then Exit Sub 230 | Set W = Sender.Widget 231 | If W.Key = "btnExpand" And EventName = "Click" Then 232 | mDS.TreeNodeExpand mDS.Col, True 233 | VList.ListIndex = -1 234 | ElseIf W.Key = "btnCollapse" And EventName = "Click" Then 235 | mDS.TreeNodeCollapse mDS.Col, True 236 | VList.ListIndex = -1 237 | End If 238 | End Sub 239 | 240 | Private Sub W_MouseDown(Button As Integer, Shift As Integer, ByVal x As Single, ByVal y As Single) 241 | mLastMouseDownHoverIndex = VList.HoverIndex 242 | End Sub 243 | 244 | Private Sub W_MouseUp(Button As Integer, Shift As Integer, ByVal x As Single, ByVal y As Single) 245 | If mInArrowArea And mLastMouseDownHoverIndex = VList.HoverIndex Then ExpandOrCollapse VList.HoverIndex 246 | End Sub 247 | 248 | Private Sub W_KeyDown(KeyCode As Integer, Shift As Integer) 249 | Dim Key, Value, Parent As cCollection, ParentBackIndex As Long 250 | If VList.ListIndex < 0 Then Exit Sub 251 | If Not mDS.TreeElementInfoByVisibleIndex(VList.ListIndex, Key, Value, , , Parent) Then Exit Sub 252 | If TypeOf Value Is cCollection Then 'we have a Node 253 | Select Case KeyCode 254 | Case vbKeyRight 255 | If mDS.TreeNodeIsExpanded(Value) Then 256 | If VList.ListIndex < mDS.Count - 1 Then VList.ListIndex = VList.ListIndex + 1 257 | Else 258 | mDS.TreeNodeExpand Value 259 | If Not mDS.TreeNodeIsExpanded(Value) Then 'that's when the expansion has failed, or was reset by the client-App in an Event 260 | If VList.ListIndex < mDS.Count - 1 Then VList.ListIndex = VList.ListIndex + 1 261 | End If 262 | End If 263 | Case vbKeyLeft 264 | If mDS.TreeNodeIsExpanded(Value) Then 265 | mDS.TreeNodeCollapse Value 266 | Else 267 | If VList.ListIndex > 0 Then VList.ListIndex = VList.ListIndex - 1 268 | End If 269 | Case vbKeyBack: ParentBackIndex = mDS.TreeNodeGetVisibleIndex(Parent) + 1 270 | End Select 271 | Else 'we have a Value-Item 272 | Select Case KeyCode 273 | Case vbKeyRight: If VList.ListIndex < mDS.Count - 1 Then VList.ListIndex = VList.ListIndex + 1 274 | Case vbKeyLeft: If VList.ListIndex > 0 Then VList.ListIndex = VList.ListIndex - 1 275 | Case vbKeyBack: ParentBackIndex = mDS.TreeNodeGetVisibleIndex(Parent) + 1 276 | End Select 277 | End If 278 | If ParentBackIndex Then VList.ListIndex = ParentBackIndex - 1 279 | End Sub 280 | 281 | Private Sub tmrDecouple_Timer() 282 | Dim Node As cCollection 283 | Select Case tmrDecouple.Tag 284 | Case "TreeStateChanged": VList.ListCount = mDS.Count 'setting the VList.Count to the DataSource.Count ensures a Tree-Refresh 285 | End Select 286 | Set tmrDecouple = Nothing 287 | End Sub 288 | 289 | Private Sub ExpandOrCollapse(ByVal Index As Long) 290 | Dim Key, Value 291 | If Not mDS.TreeElementInfoByVisibleIndex(Index, Key, Value) Then Exit Sub 292 | If Not TypeOf Value Is cCollection Then Exit Sub 293 | ' If Value.Count = 0 Then Exit Sub 294 | If mDS.TreeNodeIsExpanded(Value) Then mDS.TreeNodeCollapse Value Else mDS.TreeNodeExpand Value 295 | End Sub 296 | 297 | 298 | 299 | -------------------------------------------------------------------------------- /cwUpDown.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "cwUpDown" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Option Explicit 15 | 16 | Event DataIndexChange() 17 | 18 | 'DataSource-Implementation-Vars 19 | Private WithEvents mDS As cDataSource, mDataSourceKey As String, mDataField As String 20 | Attribute mDS.VB_VarHelpID = -1 21 | Public WithEvents VList As cwVList 22 | Attribute VList.VB_VarHelpID = -1 23 | Private WithEvents W As cWidgetBase, mShowHoverBar As Boolean 24 | Attribute W.VB_VarHelpID = -1 25 | 26 | Private Sub Class_Initialize() 27 | Set VList = New cwVList 28 | 29 | Set W = VList.Widget '<- this does not create a new WidgetBase-Instance, but "inherits" the Vlist-WidgetBase 30 | W.FocusColor = -1 31 | W.BorderColor = -1 32 | W.BackColor = -1 33 | ShowHoverBar = True 34 | End Sub 35 | 36 | Public Property Get Widget() As cWidgetBase 37 | Set Widget = W 38 | End Property 39 | Public Property Get Widgets() As cWidgets 40 | Set Widgets = W.Widgets 41 | End Property 42 | 43 | Public Property Get ShowHoverBar() As Boolean 44 | ShowHoverBar = mShowHoverBar 45 | End Property 46 | Public Property Let ShowHoverBar(ByVal RHS As Boolean) 47 | mShowHoverBar = RHS 48 | VList.ShowHoverBar = RHS 49 | End Property 50 | 51 | '***************** Start of typical-DataSource-related Procedures *************** 52 | Public Function SetDataSource(CollectionOrRecordset As Object, Key As String, Optional DataField As String) As cDataSource 53 | If Len(DataField) Then mDataField = DataField 54 | Set SetDataSource = New_c.DataSource 55 | SetDataSource.Init CollectionOrRecordset, Key, Cairo.DataSourceDispatcher 56 | Set DataSource = SetDataSource 57 | End Function 58 | 59 | Public Property Get DataSourceKey() As String 60 | DataSourceKey = mDataSourceKey 61 | End Property 62 | Public Property Let DataSourceKey(ByVal NewValue As String) 63 | mDataSourceKey = NewValue 64 | On Error Resume Next 65 | Set DataSource = Cairo.DataSources(mDataSourceKey) 66 | On Error GoTo 0 67 | End Property 68 | 69 | Public Property Get DataSource() As cDataSource 70 | Set DataSource = mDS 71 | End Property 72 | Public Property Set DataSource(DS As cDataSource) 73 | VList.ListCount = 0 74 | Set mDS = DS 75 | If mDS Is Nothing Then Exit Property 76 | mDataSourceKey = mDS.Key 77 | VList.ListCount = mDS.RecordCount 78 | If mDS.RecordCount Then mDS.MoveLast: mDS.MoveFirst 79 | End Property 80 | 81 | Public Property Get DataField() As String 82 | DataField = mDataField 83 | End Property 84 | Public Property Let DataField(ByVal NewValue As String) 85 | mDataField = NewValue 86 | End Property 87 | Private Property Get FieldIndex() As Long 88 | Dim i As Long 89 | If mDS Is Nothing Then Exit Property 90 | For i = 0 To mDS.FieldCount - 1 91 | If StrComp(mDS.FieldName(i), mDataField, vbTextCompare) = 0 Then FieldIndex = i: Exit For 92 | Next i 93 | End Property 94 | 95 | Private Sub mDS_Move(ByVal NewRowIdxZeroBased As Long) 96 | If VList.ListIndex <> NewRowIdxZeroBased Then VList.ListIndex = NewRowIdxZeroBased 97 | End Sub 98 | Private Sub mDS_NewDataContentArrived() 99 | VList.ListCount = mDS.RecordCount 100 | VList.ListIndex = IIf(VList.ListCount, 0, -1) 101 | End Sub 102 | '***************** End of typical-DataSource-related Procedures *************** 103 | 104 | Public Property Get DataIndex() As Long 105 | DataIndex = VList.ScrollIndex 106 | End Property 107 | 108 | Public Property Get DataValue() 109 | DataValue = GetDataValue(DataIndex) 110 | End Property 111 | 112 | Private Function GetDataValue(Index As Long) 113 | If mDS Is Nothing Then GetDataValue = "UpDown": Exit Function 114 | If Index < 0 Or Index >= mDS.RecordCount Then Exit Function 115 | GetDataValue = mDS.ValueMatrix(Index, FieldIndex) 116 | End Function 117 | 118 | Private Sub W_Resize() 119 | VList.RowHeight = W.ScaleHeight - 1 120 | End Sub 121 | 122 | Private Sub VList_ScrollIndexChange() 123 | VList.ListIndex = VList.ScrollIndex 124 | If Not mDS Is Nothing Then mDS.AbsolutePosition = VList.ScrollIndex + 1 125 | RaiseEvent DataIndexChange 126 | End Sub 127 | 128 | Private Sub VList_OwnerDrawItem(ByVal Index As Long, CC As cCairoContext, ByVal dx As Single, ByVal dy As Single, ByVal Alpha As Single) 129 | W.SelectFontSettingsInto CC 130 | CC.DrawText 1, 1, dx, dy, CStr(GetDataValue(Index)), True, vbCenter, 0, True 131 | End Sub 132 | 133 | -------------------------------------------------------------------------------- /cwVList.cls: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vbRichClient/vbWidgets/c8e97287f178d2470f8fa3219b4dcda51eefe6e8/cwVList.cls -------------------------------------------------------------------------------- /modWidgets.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "modWidgets" 2 | Option Explicit 3 | 4 | Public Const VSplitCursor_Png$ = "iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAIAAAD8GO2jAAAABnRSTlMAwADAAMCNeLu6AAAAb0lEQVR42u3WSwqAMAwEUEe8V66enGxcdCNSmkCtLpysSgl59BcKd99Wxr60uoB/AEcxz8wAkIyI6/j7FQgQ0KLdy9skADN7AOhWrxsJMKheNBIgIkgOEtL3nG/RwKh0i9Ihdw31IgGvAdDPTsB0nEm6NMFxeZ+IAAAAAElFTkSuQmCC" 5 | Public Const HSplitCursor_Png$ = "iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAIAAAD8GO2jAAAABnRSTlMAwADAAMCNeLu6AAAAh0lEQVR42u2UsQ7AIAhEoel/8evyZedg4mKbcBibDtzkQHjAIdpak5O6jmYvQAEKkAOY2UGAmakqxSAAI7uIUIw7PoeRfb4BrDHuHupAn5SIeQUgq+iI1k7TIjyIaMuDiLY8SMRwHgCYNQII+kR8NHcfNcazc4DJoHaMPnbsBv/vXBegAN8DOhNVk1H7kjSuAAAAAElFTkSuQmCC" 6 | 7 | Declare Function GetInstanceEx Lib "DirectCom" (StrPtr_FName As Long, StrPtr_ClassName As Long, ByVal UseAlteredSearchPath As Boolean) As Object 8 | 9 | Public New_c As cConstructor, Cairo As cCairo, fActivePopUp As cfPopUp, Voice As Object 10 | 11 | Public Sub Main() 12 | On Error Resume Next 13 | Set New_c = GetInstanceEx(StrPtr(App.Path & "\vbRichClient5.dll"), StrPtr("cConstructor"), True) 14 | If New_c Is Nothing Then 15 | Err.Clear 16 | Set New_c = New cConstructor 17 | End If 18 | 19 | Set Cairo = New_c.Cairo 20 | 21 | Set Cairo.Theme = New cThemeWin7 22 | ' Cairo.FontOptions = CAIRO_ANTIALIAS_DEFAULT 23 | End Sub 24 | 25 | Sub Speak(ByVal Text As String) 'support for blind people (mainly over cVerticalLayout, which simplifies the desing of simple Forms for blind-developers) 26 | On Error Resume Next 27 | If Voice Is Nothing Then Set Voice = CreateObject("SAPI.SpVoice") 'create the Speech-API-HelperObject 28 | If Not Voice Is Nothing Then Voice.Speak Text, 1 Or 2 Or 8 'SVSFlagsAsync OR SVSFPurgeBeforeSpeak OR XML-support 29 | If Err Then Err.Clear 30 | End Sub 31 | 32 | 33 | -------------------------------------------------------------------------------- /vbWidgets.dll: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vbRichClient/vbWidgets/c8e97287f178d2470f8fa3219b4dcda51eefe6e8/vbWidgets.dll -------------------------------------------------------------------------------- /vbWidgets.vbp: -------------------------------------------------------------------------------- 1 | Type=OleDll 2 | Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#..\..\Windows\SysWow64\stdole2.tlb#OLE Automation 3 | Reference=*\G{C79C91A4-10F5-4F71-A490-3B7915514344}#2.2#0#..\RC5\vbRichClient5.dll#vbRichClient5 4 | Module=modWidgets; modWidgets.bas 5 | Class=cwFrame; cwFrame.cls 6 | Class=cwVScrollBar; cwVScrollBar.cls 7 | Class=cwHScrollBar; cwHScrollBar.cls 8 | Class=cwButton; cwButton.cls 9 | Class=cwTextBox; cwTextBox.cls 10 | Class=cThemeWin7; cThemeWin7.cls 11 | Class=cwLabel; cwLabel.cls 12 | Class=cwImage; cwImage.cls 13 | Class=cwBrowser; cwBrowser.cls 14 | Class=cwAccordeon; cwAccordeon.cls 15 | Class=cwFileList; cwFileList.cls 16 | Class=cwAccordeonEntry; cwAccordeonEntry.cls 17 | Class=cwMDIMock; cwMDIMock.cls 18 | Class=cwVList; cwVList.cls 19 | Class=cwResizer; cwResizer.cls 20 | Class=cwStatusBar; cwStatusBar.cls 21 | Class=cwFormButtons; cwFormButtons.cls 22 | Class=cwToolBar; cwToolBar.cls 23 | Class=cwGrid; cwGrid.cls 24 | Class=cwUpDown; cwUpDown.cls 25 | Class=cwGlowButton; cwGlowButton.cls 26 | Class=cwScoringLabel; cwScoringLabel.cls 27 | Class=cwDropDown; cwDropDown.cls 28 | Class=cfPopUp; cfPopUp.cls 29 | Class=cwTree; cwTree.cls 30 | Class=cwDirList; cwDirList.cls 31 | Class=cwMenu; cwMenu.cls 32 | Class=cwMenuItem; cwMenuItem.cls 33 | Class=cwMenuBarItem; cwMenuBarItem.cls 34 | Class=cwMenuBar; cwMenuBar.cls 35 | Class=cwToolBarItem; cwToolBarItem.cls 36 | Class=cwDropDownList; cwDropDownList.cls 37 | Class=cwProgressBar; cwProgressBar.cls 38 | Class=cUndoRedo; cUndoRedo.cls 39 | Class=cIME; cIME.cls 40 | Class=cQRDecode; cQRDecode.cls 41 | Class=cQREncode; cQREncode.cls 42 | Class=cwLabeledTextBox; cwLabeledTextBox.cls 43 | Class=cwScrollBar; cwScrollBar.cls 44 | Class=cLayoutCell; cLayoutCell.cls 45 | Class=cLayoutBand; cLayoutBand.cls 46 | Class=cLayoutVertical; cLayoutVertical.cls 47 | Startup="Sub Main" 48 | HelpFile="" 49 | Title="vbWidgets" 50 | ExeName32="vbWidgets.dll" 51 | Command32="" 52 | Name="vbWidgets" 53 | HelpContextID="0" 54 | CompatibleMode="1" 55 | CompatibleEXE32="vbWidgets.dll" 56 | MajorVer=1 57 | MinorVer=0 58 | RevisionVer=0 59 | AutoIncrementVer=0 60 | ServerSupportFiles=0 61 | VersionCompanyName=" os" 62 | CompilationType=-1 63 | OptimizationType=0 64 | FavorPentiumPro(tm)=0 65 | CodeViewDebugInfo=0 66 | NoAliasing=0 67 | BoundsCheck=-1 68 | OverflowCheck=-1 69 | FlPointCheck=-1 70 | FDIVCheck=-1 71 | UnroundedFP=-1 72 | StartMode=1 73 | Unattended=0 74 | Retained=0 75 | ThreadPerObject=0 76 | MaxNumberOfThreads=1 77 | ThreadingModel=1 78 | --------------------------------------------------------------------------------