home *** CD-ROM | disk | FTP | other *** search
Attribute VB_Name = "otlcb95bas" Option Explicit Option Base 1 'OTL variables Public Type OtlSetup 'one per outline Levels As Integer VariableNames(5) As String 'Max 5 levels BmpField As String 'field holding bitmap to use for leafs if not use default CheckmarkField As String 'field to examine to determine if record is selected BmpFlag As Integer LineFlag As Integer PlusFlag As Integer CheckmarkFlag As Integer AutoCheckParents As Integer DisplayLines As Integer DisplayIdx(100) As Integer 'Max 100 lines visible DisplayCount As Integer 'virtual Ubound of displayidx VisibleItems As Integer VisChangeFlag As Integer LineHeight As Integer 'Twips ColWidth As Integer 'twips ElementClicked As Integer SelectColor As Long 'RGB SelectTextColor As Long FontName As String FontColor As Long Fontsize As Single TopIdx As Integer SelectIdx As Integer CurrentLine As Integer LastLine As Integer PrevTop As Integer PrevSel As Integer LastType As Integer ' 0=None, 1=Parent, 2=Collapse, 3=Expand, 4=Child, Last clicked or keypress End Type Public Type OtlData 'Use in array Caption As String Level As Integer Visible As Integer Expanded As Integer VisibleIdx As Long Bookmark As String Bitmap As Picture 'if not use default Selected As Integer '0-none, 1-all, 2-some SyncIdx As Integer 'Optional, sync to another array Itemdata As Long IsParent As Boolean 'is this a parent End Type 'standard images Global gBranchOpenPic As Control Global gBranchClosedPic As Control Global gLeafPic As Control Global gCustomPic As Control Global gPlusPic As Control Global gMinusPic As Control 'checked images Global gBranchOpenAllPic As Control 'checked Global gBranchClosedAllPic As Control Global gBranchOpenSomePic As Control Global gBranchClosedSomePic As Control Global gLeafCheckedPic As Control Dim ChangingScroll As Integer 'KeyCodes Constants Const KEY_PRIOR = &H21 Const KEY_NEXT = &H22 Const KEY_END = &H23 Const KEY_HOME = &H24 Const KEY_LEFT = &H25 Const KEY_UP = &H26 Const KEY_RIGHT = &H27 Const KEY_DOWN = &H28 Const KEY_ADD = &H6B Const KEY_SUBTRACT = &H6D #If Win32 Then Declare Function BitBlt Lib "gdi32" (ByVal hDestDC%, ByVal x%, ByVal y%, ByVal nWidth%, ByVal nHeight%, ByVal hSrcDC%, ByVal xSrc%, ByVal ySrc%, ByVal dwRop&) As Integer Declare Function StretchBlt Lib "gdi32" (ByVal hDestDC%, ByVal x%, ByVal y%, ByVal nWidth%, ByVal nHeight%, ByVal hSrcDC%, ByVal xSrc%, ByVal ySrc%, ByVal nsrcWidth%, ByVal nsrcHeight%, ByVal dwRop&) As Integer Declare Function SetPixel Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long #Else Declare Function BitBlt Lib "GDI" (ByVal hDestDC%, ByVal x%, ByVal y%, ByVal nWidth%, ByVal nHeight%, ByVal hSrcDC%, ByVal xSrc%, ByVal ySrc%, ByVal dwRop&) As Integer Declare Function StretchBlt Lib "GDI" (ByVal hDestDC%, ByVal x%, ByVal y%, ByVal nWidth%, ByVal nHeight%, ByVal hSrcDC%, ByVal xSrc%, ByVal ySrc%, ByVal nsrcWidth%, ByVal nsrcHeight%, ByVal dwRop&) As Integer Declare Function SetPixel Lib "GDI" (ByVal hDC As Integer, ByVal x As Integer, ByVal y As Integer, ByVal crColor As Long) As Long #End If 'Establishes the Bitmap objects for an outline control 'Sub OutlineBmpSetup(BranchOpen As Control, BoFile As String, BranchClosed As Control, BcFile As String, Leaf As Control, LFile As String, CustomPic As Control) 'On Error Resume Next ' 'Set gBranchOpenPic = IIf(m_PictureOpen = Nothing, BranchOpen, m_PictureOpen) 'Set gBranchClosedPic = IIf(m_PictureClosed = Nothing, BranchClosed, m_PictureClosed) 'Set gLeafPic = IIf(m_PictureItemNotSelected = Nothing, Leaf, m_PictureItemNotSelected) 'Set gCustomPic = IIf(m_PictureItemNotSelected = Nothing, CustomPic, m_PictureItemNotSelected) ' 'If BoFile > "" Then gBranchOpenPic.Picture = LoadPicture(BoFile) 'If BcFile > "" Then gBranchClosedPic.Picture = LoadPicture(BcFile) 'If LFile > "" Then gLeafPic.Picture = LoadPicture(LFile) ' 'End Sub Sub OutlineBmpSetup(BranchOpen As Control, BoPic As Picture, BranchClosed As Control, BcPic As Picture, Leaf As Control, LPic As Picture, CustomPic As Control, CPic As Picture) On Error Resume Next Set gBranchOpenPic = BranchOpen Set gBranchClosedPic = BranchClosed Set gLeafPic = Leaf Set gCustomPic = CustomPic If Not BoPic Is Nothing Then gBranchOpenPic.Picture = BoPic If Not BcPic Is Nothing Then gBranchClosedPic.Picture = BcPic If Not LPic Is Nothing Then gLeafPic.Picture = LPic If Not CPic Is Nothing Then gCustomPic.Picture = CPic End Sub Sub OutlineBmpCheckedSetup(BranchOpenAll As Control, BoaPic As Picture, BranchClosedAll As Control, BcaPic As Picture, BranchOpenSome As Control, BosPic As Picture, BranchClosedSome As Control, BcsPic As Picture, LeafChecked As Control, LcPic As Picture) 'On Error Resume Next Set gBranchOpenAllPic = BranchOpenAll Set gBranchClosedAllPic = BranchClosedAll Set gBranchOpenSomePic = BranchOpenSome Set gBranchClosedSomePic = BranchClosedSome Set gLeafCheckedPic = LeafChecked If Not BoaPic Is Nothing Then gBranchOpenAllPic.Picture = BoaPic If Not BcaPic Is Nothing Then gBranchClosedAllPic.Picture = BcaPic If Not BosPic Is Nothing Then gBranchOpenSomePic.Picture = BosPic If Not BcsPic Is Nothing Then gBranchClosedSomePic.Picture = BcsPic If Not LcPic Is Nothing Then gLeafCheckedPic.Picture = LcPic End Sub 'Processes a mouse click. Sub OutlineClick(OtlPic As Control, OtlScroll As Control, OtlSet As OtlSetup, Otldat As CollectionEx) Dim foo As Integer Dim Children As Integer 'set select OtlSet.LastType = 0 If OtlSet.CurrentLine > OtlSet.DisplayCount Then Exit Sub 'default as child click, but change later if parent OtlSet.LastType = IIf(OtlSet.ElementClicked > 0, 4, 0) 'If OtlSet.ElementClicked > 0 Then OtlSet.SelectIdx = OtlSet.DisplayIdx(OtlSet.CurrentLine) OtlSet.SelectIdx = OtlSet.DisplayIdx(OtlSet.CurrentLine) 'if pictureclick then select all or deselect all, don't expand If OtlSet.ElementClicked = 1 And OtlSet.CheckmarkFlag Then If Otldat(OtlSet.DisplayIdx(OtlSet.CurrentLine)).IsParent Then OtlSet.LastType = 1 Else OtlSet.LastType = 4 End If OtlSet.VisChangeFlag = True If Otldat(OtlSet.DisplayIdx(OtlSet.CurrentLine)).Selected = 1 Then Otldat(OtlSet.DisplayIdx(OtlSet.CurrentLine)).Selected = 0 Else Otldat(OtlSet.DisplayIdx(OtlSet.CurrentLine)).Selected = 1 End If If OtlSet.AutoCheckParents Then 'set child select For foo = OtlSet.DisplayIdx(OtlSet.CurrentLine) + 1 To Otldat.Count If Otldat(foo).Level <= Otldat(OtlSet.DisplayIdx(OtlSet.CurrentLine)).Level Then Exit For Otldat(foo).Selected = Otldat(OtlSet.DisplayIdx(OtlSet.CurrentLine)).Selected Next foo 'set parent selects CheckMarkParents OtlSet, Otldat End If Else 'is it a branch? 'If OtlDat(OtlSet.DisplayIdx(OtlSet.CurrentLine)).Level < OtlSet.Levels - 1 Then If Otldat(OtlSet.DisplayIdx(OtlSet.CurrentLine)).IsParent Then OtlSet.VisChangeFlag = True 'was it expanded? If Otldat(OtlSet.DisplayIdx(OtlSet.CurrentLine)).Expanded = True Then 'Collapse children OtlSet.LastType = 2 For foo = OtlSet.DisplayIdx(OtlSet.CurrentLine) + 1 To Otldat.Count If Otldat(foo).Level <= Otldat(OtlSet.DisplayIdx(OtlSet.CurrentLine)).Level Then Exit For Otldat(foo).Expanded = False Otldat(foo).Visible = False Next foo Else 'Expand next level OtlSet.LastType = 3 Children = 0 For foo = OtlSet.DisplayIdx(OtlSet.CurrentLine) + 1 To Otldat.Count If Otldat(foo).Level <= Otldat(OtlSet.DisplayIdx(OtlSet.CurrentLine)).Level Then Exit For Else If Otldat(foo).Level = Otldat(OtlSet.DisplayIdx(OtlSet.CurrentLine)).Level + 1 Then Otldat(foo).Expanded = False Otldat(foo).Visible = True Children = Children + 1 End If End If Next foo End If Otldat(OtlSet.DisplayIdx(OtlSet.CurrentLine)).Expanded = Not Otldat(OtlSet.DisplayIdx(OtlSet.CurrentLine)).Expanded If Children + OtlSet.CurrentLine >= OtlSet.DisplayLines Then If Children < OtlSet.DisplayLines Then OtlSet.TopIdx = OtlSet.DisplayIdx((OtlSet.CurrentLine + Children + 1) - OtlSet.DisplayLines) OtlSet.SelectIdx = OtlSet.DisplayIdx(OtlSet.CurrentLine) OtlSet.CurrentLine = OtlSet.CurrentLine - (Children + 1) Else OtlSet.TopIdx = OtlSet.DisplayIdx(OtlSet.CurrentLine) OtlSet.SelectIdx = OtlSet.DisplayIdx(OtlSet.CurrentLine) OtlSet.CurrentLine = 1 End If End If End If End If OutlineRefresh OtlPic, OtlScroll, OtlSet, Otldat End Sub Public Sub OutlineExpand(Index As Integer, OtlPic As Control, OtlScroll As Control, OtlSet As OtlSetup, Otldat As CollectionEx) Dim foo As Integer Dim Children As Integer 'set select OtlSet.LastType = 0 OtlSet.SelectIdx = Index If Otldat(Index).IsParent Then OtlSet.VisChangeFlag = True 'was it expanded? If Otldat(Index).Expanded = False Then 'Expand next level OtlSet.LastType = 3 Children = 0 For foo = Index + 1 To Otldat.Count If Otldat(foo).Level <= Otldat(Index).Level Then Exit For Else If Otldat(foo).Level = Otldat(Index).Level + 1 Then Otldat(foo).Expanded = False Otldat(foo).Visible = True Children = Children + 1 End If End If Next foo Otldat(Index).Expanded = True If Children + Index >= OtlSet.DisplayLines Then If Children < OtlSet.DisplayLines Then OtlSet.TopIdx = (Index + Children + 1) - OtlSet.DisplayLines OtlSet.SelectIdx = Index Index = Index - (Children + 1) Else OtlSet.TopIdx = Index OtlSet.SelectIdx = Index OtlSet.CurrentLine = 1 End If 'if children End If End If End If OutlineRefresh OtlPic, OtlScroll, OtlSet, Otldat End Sub Public Sub OutlineCollapse(Index As Integer, OtlPic As Control, OtlScroll As Control, OtlSet As OtlSetup, Otldat As CollectionEx) Dim foo As Integer Dim Children As Integer 'set select OtlSet.LastType = 0 OtlSet.SelectIdx = Index If Otldat(Index).IsParent Then OtlSet.VisChangeFlag = True 'was it expanded? If Otldat(Index).Expanded = True Then 'Collapse children OtlSet.LastType = 2 For foo = Index + 1 To Otldat.Count If Otldat(foo).Level <= Otldat(Index).Level Then Exit For Otldat(foo).Expanded = False Otldat(foo).Visible = False Next foo Otldat(Index).Expanded = False OtlSet.TopIdx = Index OtlSet.SelectIdx = Index OtlSet.CurrentLine = 1 End If End If OutlineRefresh OtlPic, OtlScroll, OtlSet, Otldat End Sub Public Sub CheckMarkParents(OtlSet As OtlSetup, Otldat As CollectionEx) Dim foo As Integer ReDim LevelValue(OtlSet.Levels) As Double ReDim levelcount(OtlSet.Levels) As Integer For foo = Otldat.Count To 1 Step -1 'handle control break if this is not a child ' If OtlDat(foo).Level <= OtlSet.Levels - 2 Then If Otldat(foo).IsParent Then If LevelValue(Otldat(foo).Level + 1) = 0 Then Otldat(foo).Selected = 0 'none selected Else If levelcount(Otldat(foo).Level + 1) = LevelValue(Otldat(foo).Level + 1) Then Otldat(foo).Selected = 1 'all selected Else Otldat(foo).Selected = 2 'some selected End If End If LevelValue(Otldat(foo).Level + 1) = 0 levelcount(Otldat(foo).Level + 1) = 0 End If If Otldat(foo).Level > 0 Then 'increment parent count Select Case Otldat(foo).Selected Case 1 LevelValue(Otldat(foo).Level) = LevelValue(Otldat(foo).Level) + 1 Case 2 LevelValue(Otldat(foo).Level) = LevelValue(Otldat(foo).Level) + 0.0001 End Select levelcount(Otldat(foo).Level) = levelcount(Otldat(foo).Level) + 1 End If Next foo End Sub 'Closes all open branches. Sub OutlineCollapseAll(OtlPic As Control, OtlScroll As Control, OtlSet As OtlSetup, Otldat As CollectionEx) Dim foo As Integer Dim TotVisible As Integer For foo = 1 To Otldat.Count If Otldat(foo).Level > 0 Then Otldat(foo).Visible = False Otldat(foo).Expanded = False Else Otldat(foo).Expanded = False End If If Otldat(foo).Visible = True Then TotVisible = TotVisible + 1 Next foo If Otldat(OtlSet.SelectIdx).Visible = False Then OtlSet.SelectIdx = 1 If TotVisible <= OtlSet.DisplayLines Then OtlSet.TopIdx = 1 Else OtlSet.TopIdx = OtlSet.SelectIdx End If OtlSet.VisChangeFlag = True OutlineRefresh OtlPic, OtlScroll, OtlSet, Otldat End Sub 'Opens all branches. Sub OutlineExpandAll(OtlPic As Control, OtlScroll As Control, OtlSet As OtlSetup, Otldat As CollectionEx) Dim foo As Integer For foo = 1 To Otldat.Count Otldat(foo).Visible = True 'If OtlDat(foo).Level < OtlSet.Levels - 1 Then OtlDat(foo).Expanded = True If Otldat(foo).IsParent Then Otldat(foo).Expanded = True Next foo OtlSet.VisChangeFlag = True OutlineRefresh OtlPic, OtlScroll, OtlSet, Otldat End Sub 'Locates text within the control. Sub OutlineFind(FindItem As String, FindMode As Integer, OtlPic As Control, OtlScroll As Control, OtlSet As OtlSetup, Otldat As CollectionEx) Dim ItemStart As Integer, foo As Integer, foobar As Integer Dim foo2 As Integer If FindMode = 0 Then ItemStart = 1 Else ItemStart = OtlSet.SelectIdx + 1 End If For foo = ItemStart To Otldat.Count If InStr(1, Otldat(foo).Caption, FindItem, 1) > 0 Then OtlSet.SelectIdx = foo OtlSet.TopIdx = foo If Otldat(foo).Level <> 0 Then For foobar = foo To 1 Step -1 If Otldat(foobar).Level = 0 Then Otldat(foobar).Expanded = True Otldat(foobar).Visible = True Exit For End If Next foobar For foo2 = foobar + 1 To Otldat.Count If Otldat(foo2).Level = 0 Then Exit For Otldat(foo2).Visible = True Next foo2 End If OtlSet.CurrentLine = 1 OtlSet.VisChangeFlag = True OutlineRefresh OtlPic, OtlScroll, OtlSet, Otldat Exit Sub End If Next foo 'item not found Beep End Sub 'goto a specific node Sub OutlineGoto(FindItem As Integer, OtlPic As Control, OtlScroll As Control, OtlSet As OtlSetup, Otldat As CollectionEx) Dim foo As Integer, foobar As Integer Dim foo2 As Integer foo = FindItem If foo <= Otldat.Count Then OtlSet.SelectIdx = foo OtlSet.TopIdx = foo If Otldat(foo).Level <> 0 Then For foobar = foo To 1 Step -1 If Otldat(foobar).Level = 0 Then Otldat(foobar).Expanded = True Otldat(foobar).Visible = True Exit For End If Next foobar For foo2 = foobar + 1 To Otldat.Count If Otldat(foo2).Level = 0 Then Exit For Otldat(foo2).Visible = True Next foo2 End If OtlSet.CurrentLine = 1 OtlSet.VisChangeFlag = True OutlineRefresh OtlPic, OtlScroll, OtlSet, Otldat Else Beep End If End Sub 'Processes outline control keys Sub OutlineKeyPress(KeyCode As Integer, OtlPic As Control, OtlScroll As Control, OtlSet As OtlSetup, Otldat As CollectionEx) Dim foo As Integer, VisCount As Integer On Error Resume Next Select Case KeyCode Case vbKeyReturn OtlSet.ElementClicked = 2 OutlineClick OtlPic, OtlScroll, OtlSet, Otldat Case vbKeySpace OtlSet.ElementClicked = 1 OutlineClick OtlPic, OtlScroll, OtlSet, Otldat Case KEY_PRIOR VisCount = 0 foo = 0 For foo = OtlSet.TopIdx To 1 Step -1 If Otldat(foo).Visible = True Then VisCount = VisCount + 1 If VisCount = OtlSet.DisplayLines Then Exit For Next foo OtlSet.CurrentLine = 1 OtlSet.TopIdx = foo + 1 OtlSet.SelectIdx = OtlSet.TopIdx OutlineRefresh OtlPic, OtlScroll, OtlSet, Otldat Case KEY_NEXT For foo = OtlSet.DisplayLines To 1 Step -1 If OtlSet.DisplayIdx(foo) > 0 Then OtlSet.TopIdx = OtlSet.DisplayIdx(foo) Exit For End If Next foo OtlSet.CurrentLine = 1 OtlSet.SelectIdx = OtlSet.TopIdx OutlineRefresh OtlPic, OtlScroll, OtlSet, Otldat Case KEY_END OutlineGoto Otldat.Count, OtlPic, OtlScroll, OtlSet, Otldat Case KEY_HOME OutlineGoto 1, OtlPic, OtlScroll, OtlSet, Otldat Case KEY_LEFT OutlineCollapse OtlSet.SelectIdx, OtlPic, OtlScroll, OtlSet, Otldat Case KEY_RIGHT OutlineExpand OtlSet.SelectIdx, OtlPic, OtlScroll, OtlSet, Otldat Case KEY_UP If OtlSet.CurrentLine > 1 Then OtlSet.CurrentLine = OtlSet.CurrentLine - 1 OtlSet.SelectIdx = OtlSet.DisplayIdx(OtlSet.CurrentLine) Else For foo = OtlSet.TopIdx - 1 To 1 Step -1 If Otldat(foo).Visible = True Then OtlSet.TopIdx = foo OtlSet.SelectIdx = OtlSet.TopIdx Exit For End If Next foo End If OutlineRefresh OtlPic, OtlScroll, OtlSet, Otldat Case KEY_DOWN If OtlSet.CurrentLine < OtlSet.DisplayCount Then OtlSet.CurrentLine = OtlSet.CurrentLine + 1 OtlSet.SelectIdx = OtlSet.DisplayIdx(OtlSet.CurrentLine) Else For foo = OtlSet.DisplayIdx(OtlSet.CurrentLine) + 1 To Otldat.Count If Otldat(foo).Visible = True Then OtlSet.TopIdx = OtlSet.DisplayIdx(2) OtlSet.SelectIdx = foo Exit For End If Next foo End If OutlineRefresh OtlPic, OtlScroll, OtlSet, Otldat Case Else End Select End Sub 'Processes MouseDown to get coordinates of click. Sub OutlineMouseDown2Line(OtlSet As OtlSetup, Otldat As CollectionEx, y As Single, x As Single) On Error Resume Next OtlSet.LastLine = OtlSet.CurrentLine OtlSet.CurrentLine = (y \ OtlSet.LineHeight) + 1 OtlSet.ElementClicked = (x - Otldat(OtlSet.DisplayIdx(OtlSet.CurrentLine)).Level * OtlSet.ColWidth) \ OtlSet.ColWidth '0=+/-, 1=Pic, 2=Caption If OtlSet.ElementClicked > 2 Then OtlSet.ElementClicked = 2 If OtlSet.LineFlag = 0 And OtlSet.ElementClicked = 0 Then OtlSet.ElementClicked = 1 ElseIf OtlSet.LineFlag = 0 And OtlSet.ElementClicked = 1 Then OtlSet.ElementClicked = 2 End If If OtlSet.BmpFlag = 0 And OtlSet.ElementClicked = 1 Then OtlSet.ElementClicked = 2 End Sub 'Setup routine for plus/minus Sub OutlinePlusMinusSetup(PlusPic As Control, PlusFile As String, MinusPic As Control, MinusFile As String) On Error Resume Next Set gPlusPic = PlusPic Set gMinusPic = MinusPic If PlusFile > "" Then gPlusPic.Picture = LoadPicture(PlusFile) If MinusFile > "" Then gMinusPic.Picture = LoadPicture(MinusFile) End Sub 'This is main drawing routine for outline control. Sub OutlineRefresh(OtlPic As Control, OtlScroll As Control, OtlSet As OtlSetup, Otldat As CollectionEx) 'On Error Resume Next 'Paints control from data array Dim foo As Integer, foobar As Integer, TotItems As Long Dim CurrY As Integer, currX As Integer Dim BmpWidth As Integer, BmpHeight As Integer Dim TwipsY As Integer, TwipsX As Integer, TxtWidth As Integer Dim LineCount As Integer, HoldForeColor As Long Dim TotVis As Long, SelPnt As Long ReDim PrevLevelLine(20) As Integer Dim PrevBmpFile As Picture Dim SearchLevel As Integer 'GMG 989818: Dim yLine1 As Single, yLine2 As Single If ChangingScroll Then Exit Sub 'don't recurse scroll change End If TwipsY = Screen.TwipsPerPixelY TwipsX = Screen.TwipsPerPixelX 'OtlSet.LineHeight = 12 * twipsx BmpWidth = OtlSet.LineHeight BmpHeight = OtlSet.LineHeight 'Just changing select bar? If OtlSet.TopIdx = OtlSet.PrevTop And OtlSet.VisChangeFlag = False Then 'OtlPic.AutoRedraw = False For foo = 1 To OtlSet.DisplayCount CurrY = (foo - 1) * OtlSet.LineHeight 'highlight currently selected item If OtlSet.DisplayIdx(foo) = OtlSet.SelectIdx Then OtlPic.CurrentY = CurrY currX = OutlineSetX(3, Otldat(OtlSet.DisplayIdx(foo)).Level, OtlSet) TxtWidth = currX + OtlPic.TextWidth(Otldat(OtlSet.DisplayIdx(foo)).Caption) + 75 OtlPic.Line (currX + 10, CurrY)-(TxtWidth * 2, CurrY + OtlSet.LineHeight - TwipsY), OtlPic.BackColor, BF OtlPic.Line (currX + 10, CurrY)-(TxtWidth, CurrY + OtlSet.LineHeight - TwipsY), OtlSet.SelectColor, BF OtlSet.CurrentLine = foo 'Print Caption OtlPic.CurrentY = CurrY OtlPic.CurrentX = currX HoldForeColor = OtlPic.ForeColor OtlPic.ForeColor = OtlSet.SelectTextColor OtlPic.Print " " & Otldat(OtlSet.DisplayIdx(foo)).Caption OtlPic.ForeColor = HoldForeColor Else 'unhighlight previously selected item If OtlSet.DisplayIdx(foo) = OtlSet.PrevSel Then OtlPic.CurrentY = CurrY currX = OutlineSetX(3, Otldat(OtlSet.DisplayIdx(foo)).Level, OtlSet) TxtWidth = currX + OtlPic.TextWidth(Otldat(OtlSet.DisplayIdx(foo)).Caption) + 75 OtlPic.Line (currX + 10, CurrY)-(TxtWidth, CurrY + OtlSet.LineHeight - TwipsY), OtlPic.BackColor, BF 'Print Caption OtlPic.CurrentY = CurrY OtlPic.CurrentX = currX OtlPic.Print " " & Otldat(OtlSet.DisplayIdx(foo)).Caption End If End If Next foo 'OtlPic.AutoRedraw = True Else Erase OtlSet.DisplayIdx OtlPic.Cls 'TotItems = UBound(OtlDat) TotItems = Otldat.Count LineCount = 0 For foo = OtlSet.TopIdx To TotItems 'GMG 980818 : without this we will crash If foo > 0 Then If Otldat(foo).Visible = True Then CurrY = (LineCount) * OtlSet.LineHeight If LineCount = 0 Then OtlSet.TopIdx = foo End If OtlSet.DisplayIdx(LineCount + 1) = foo 'Print Select Highlight If OtlSet.SelectIdx = foo Then OtlPic.CurrentY = CurrY currX = OutlineSetX(3, Otldat(foo).Level, OtlSet) TxtWidth = currX + OtlPic.TextWidth(Otldat(foo).Caption) + 75 OtlPic.Line (currX + 10, CurrY)-(TxtWidth, CurrY + OtlSet.LineHeight - TwipsY), OtlSet.SelectColor, BF OtlSet.CurrentLine = LineCount + 1 HoldForeColor = OtlPic.ForeColor 'Print Select Caption OtlPic.ForeColor = OtlSet.SelectTextColor OtlPic.CurrentY = CurrY OtlPic.CurrentX = currX OtlPic.Print " " & Otldat(foo).Caption OtlPic.ForeColor = HoldForeColor Else 'Print Caption OtlPic.CurrentY = CurrY currX = OutlineSetX(3, Otldat(foo).Level, OtlSet) OtlPic.CurrentX = currX OtlPic.Print " " & Otldat(foo).Caption End If 'draw lines with default forecolor 'MOD FOR EXPLORER STYLE DOTTED LINES... If OtlSet.LineFlag = 1 Then PrevLevelLine(Otldat(foo).Level + 1) = LineCount currX = OutlineSetX(0, Otldat(foo).Level, OtlSet) 'horizontal lines connecting subitems DotLine95 OtlPic, currX, CurrY + OtlSet.LineHeight \ 2, currX + OtlSet.ColWidth * 0.6, CurrY + OtlSet.LineHeight \ 2 If LineCount = 0 Then If Otldat(foo).Level > 0 Then DotLine95 OtlPic, currX, CurrY + OtlSet.LineHeight \ 2, currX, CurrY Else If Otldat(foo - 1).Level = Otldat(foo).Level Then 'vertical lines connecting subitems DotLine95 OtlPic, currX, CurrY + OtlSet.LineHeight \ 2, currX, CurrY - OtlSet.LineHeight \ 2 '- twipsy Else If Otldat(foo - 1).Level < Otldat(foo).Level Then 'vertical line below pictures/folders DotLine95 OtlPic, currX, CurrY + OtlSet.LineHeight \ 2, currX, CurrY Else For foobar = LineCount - 1 To 1 Step -1 If Otldat(OtlSet.DisplayIdx(foobar) + 1).Level <= Otldat(foo).Level Then Exit For End If Next foobar If Otldat(OtlSet.DisplayIdx(foobar) + 1).Level <= Otldat(foo).Level Then 'vertical line between collapsed parents '************************************************************************************* 'GMG 980811 : don't draw any lines above the top [+] yLine2 = CurrY + OtlSet.LineHeight \ 2 yLine1 = OtlSet.LineHeight * (foobar) - OtlSet.LineHeight \ 2 'If (yLine1 < 120) And (OtlDat(foo).Level = 0) And (OtlSet.TopIdx = 1) Then ' i wasnt sure whether to use foo or (otlset.displayidx(foobar)+1), ' but i dont think we should have any case like this: If (yLine1 < OtlSet.LineHeight \ 2 + 10) And (OtlSet.TopIdx = 1) Then 'this must be the very top node, so dont draw too high yLine1 = OtlSet.LineHeight \ 2 + 10 End If DotLine95 OtlPic, currX, yLine2, currX, yLine1 'DotLine95 OtlPic, currX, CurrY + OtlSet.LineHeight \ 2, currX, OtlSet.LineHeight * (foobar + 1) - OtlSet.LineHeight \ 2 '************************************************************************************* Else 'Equal level at top or next/any is above limit of control visible area DotLine95 OtlPic, currX, CurrY + OtlSet.LineHeight \ 2, currX, 0 'OtlSet.LineHeight * (foobar + 1) - OtlSet.LineHeight \ 2 End If End If End If End If End If 'GMG 980811 : moved this down here so the bitmap gets blt'd last 'blt bmp If OtlSet.BmpFlag = 1 Then OtlPic.CurrentY = CurrY currX = OutlineSetX(2, Otldat(foo).Level, OtlSet) OtlPic.CurrentX = currX 'do bitmap by kind 'If OtlDat(foo).Level = OtlSet.Levels - 1 Then If Not Otldat(foo).IsParent Then 'Leaf If Not Otldat(foo).Bitmap Is Nothing Then Err = 0 If Not PrevBmpFile Is Otldat(foo).Bitmap Then 'gCustomPic.Picture = LoadPicture(OtlDat(foo).Bitmap) Set gCustomPic.Picture = Otldat(foo).Bitmap If Err <> 0 Then Err = 0 'gCustomPic.Picture = LoadPicture(App.Path & "\" & OtlDat(foo).Bitmap) Set gCustomPic.Picture = Otldat(foo).Bitmap End If If Err = 0 Then Set PrevBmpFile = Otldat(foo).Bitmap End If End If If Err = 0 And OtlSet.CheckmarkFlag = 0 Then OtlPic.PaintPicture gCustomPic.Picture, currX, CurrY Else If OtlSet.CheckmarkFlag And (Otldat(foo).Selected = 1) Then OtlPic.PaintPicture gLeafCheckedPic.Picture, currX, CurrY Else OtlPic.PaintPicture gLeafPic.Picture, currX, CurrY End If End If Else If OtlSet.CheckmarkFlag And (Otldat(foo).Selected = 1) Then OtlPic.PaintPicture gLeafCheckedPic.Picture, currX, CurrY Else OtlPic.PaintPicture gLeafPic.Picture, currX, CurrY End If End If Else PaintBranchBmp OtlPic, Otldat(foo).Expanded, Otldat(foo).Selected, OtlSet.CheckmarkFlag, currX, CurrY, OtlSet End If End If 'set next line LineCount = LineCount + 1 If LineCount >= OtlSet.DisplayLines Or foo = Otldat.Count Then Exit For End If End If End If Next foo LineCount = LineCount - 1 OtlSet.DisplayCount = LineCount + 1 'Complete Line processing If OtlSet.LineFlag = 1 And foo < TotItems Then SearchLevel = Otldat(foo).Level 'Last item displayed For foobar = foo + 1 To TotItems If Otldat(foobar).Level <= SearchLevel Then currX = OutlineSetX(0, Otldat(foobar).Level, OtlSet) 'vertical line down from expanded parent '************************************************************************************* 'GMG 980811 : don't draw any lines above the top [+] yLine2 = OtlPic.Height yLine1 = PrevLevelLine(Otldat(foobar).Level + 1) * OtlSet.LineHeight If (yLine1 < OtlSet.LineHeight \ 2 + 10) And (Otldat(foobar).Level = 0) And (OtlSet.TopIdx = 1) Then 'this must be the very top node, so dont draw too high yLine1 = OtlSet.LineHeight \ 2 + 10 End If DotLine95 OtlPic, currX, yLine2, currX, yLine1 '- twipsy 'DotLine95 OtlPic, currX, OtlPic.Height, currX, PrevLevelLine(OtlDat(foobar).Level + 1) * OtlSet.LineHeight '- twipsy '************************************************************************************* SearchLevel = Otldat(foobar).Level - 1 If SearchLevel < 0 Then Exit For End If Next foobar End If 'draw plus minus boxes LineCount = 0 CurrY = 0 If (OtlSet.PlusFlag = 1) Then For foo = OtlSet.TopIdx To TotItems 'If (OtlDat(foo).Level < OtlSet.Levels - 1) And OtlDat(foo).Visible Then If (Otldat(foo).IsParent) And Otldat(foo).Visible Then CurrY = (LineCount) * OtlSet.LineHeight + OtlSet.LineHeight / 2 - Screen.TwipsPerPixelY currX = OutlineSetX(1, Otldat(foo).Level, OtlSet) OtlPic.CurrentX = currX 'does the branch have child entries? If foo = TotItems Then 'last entry so no children Drawbox Pic:=OtlPic, x:=(currX), y:=(CurrY), Plus:=False Else 'no kids If Otldat(foo + 1).Level <= Otldat(foo).Level Then Drawbox Pic:=OtlPic, x:=(currX), y:=(CurrY), Plus:=False Else 'does have children, but is it expanded already? If Otldat(foo).Expanded = True Then Drawbox Pic:=OtlPic, x:=(currX), y:=(CurrY), Plus:=False Else 'PLUS - has unexpanded children Drawbox Pic:=OtlPic, x:=(currX), y:=(CurrY), Plus:=True End If End If End If End If If Otldat(foo).Visible Then 'set next line LineCount = LineCount + 1 If LineCount >= OtlSet.DisplayLines Or foo = Otldat.Count Then Exit For End If End If Next foo End If 'Set Scroll Bar 'Determine visible items If OtlSet.VisChangeFlag Then ChangingScroll = True OtlSet.VisChangeFlag = False OtlSet.VisibleItems = -1 For foo = 1 To TotItems If Otldat(foo).Visible = True Then OtlSet.VisibleItems = OtlSet.VisibleItems + 1 Otldat(foo).VisibleIdx = OtlSet.VisibleItems Else Otldat(foo).VisibleIdx = -1 End If Next foo If OtlSet.VisibleItems > 0 Then OtlScroll.Visible = True OtlScroll.Max = OtlSet.VisibleItems Else OtlScroll.Visible = False OtlScroll.value = 0 End If OtlScroll.SmallChange = 1 OtlScroll.LargeChange = 10 ChangingScroll = False End If End If If OtlScroll.Visible = True Then ChangingScroll = True OtlScroll.value = Otldat(OtlSet.SelectIdx).VisibleIdx ChangingScroll = False End If OtlSet.PrevSel = OtlSet.SelectIdx OtlSet.PrevTop = OtlSet.TopIdx End Sub Public Sub PaintBranchBmp(OtlPic As Object, Expanded As Integer, Selected As Integer, CheckmarkFlag As Integer, currX As Integer, CurrY As Integer, OtlSet As OtlSetup) If CheckmarkFlag = False Then If Expanded Then OtlPic.PaintPicture gBranchOpenPic.Picture, currX, CurrY Else OtlPic.PaintPicture gBranchClosedPic.Picture, currX, CurrY End If Else If Expanded Then Select Case Selected Case 0 OtlPic.PaintPicture gBranchOpenPic.Picture, currX, CurrY Case 1 OtlPic.PaintPicture gBranchOpenAllPic.Picture, currX, CurrY Case 2 OtlPic.PaintPicture gBranchOpenSomePic.Picture, currX, CurrY End Select Else Select Case Selected Case 0 OtlPic.PaintPicture gBranchClosedPic.Picture, currX, CurrY Case 1 OtlPic.PaintPicture gBranchClosedAllPic.Picture, currX, CurrY Case 2 OtlPic.PaintPicture gBranchClosedSomePic.Picture, currX, CurrY End Select End If End If End Sub Public Function OutlineSetX(ViewType As Integer, Level As Integer, OtlSet As OtlSetup) As Integer 'used for win95 style outlines -- always have bmp, lines, +/- 'ViewType --> 0 = line, 1 = +/- box, 2 = bmp, 3 = text Dim currX As Integer 'added to move text over if bitmaps or lines are not displayed If OtlSet.BmpFlag = 0 And ViewType = 3 Then ViewType = 2 If OtlSet.PlusFlag = 0 And OtlSet.BmpFlag = 0 And ViewType = 3 Then ViewType = 2 If OtlSet.PlusFlag = 0 And OtlSet.BmpFlag = 0 And OtlSet.LineFlag = 0 And ViewType = 2 Then ViewType = 1 If OtlSet.PlusFlag = 0 And OtlSet.BmpFlag = 1 And OtlSet.LineFlag = 0 And ViewType = 2 Then ViewType = 1 If OtlSet.PlusFlag = 0 And OtlSet.BmpFlag = 1 And OtlSet.LineFlag = 0 And ViewType = 3 Then ViewType = 2 OtlSet.ColWidth = 17 * Screen.TwipsPerPixelX Select Case ViewType Case 0 'lines If Level > 0 Then currX = Level * OtlSet.ColWidth + OtlSet.LineHeight \ 2 Else currX = OtlSet.LineHeight \ 2 End If Case 1 '+/- box If Level > 0 Then currX = Level * OtlSet.ColWidth + OtlSet.LineHeight \ 2 Else currX = OtlSet.LineHeight \ 2 + Screen.TwipsPerPixelX End If Case 2 'bmp If Level > 0 Then currX = Level * OtlSet.ColWidth + OtlSet.ColWidth + Screen.TwipsPerPixelX * 2 Else currX = OtlSet.ColWidth + (Screen.TwipsPerPixelX * 2) End If Case 3 'text caption If Level > 0 Then currX = Level * OtlSet.ColWidth + OtlSet.ColWidth + OtlSet.LineHeight + (Screen.TwipsPerPixelX * 2) Else currX = OtlSet.ColWidth + OtlSet.LineHeight + (Screen.TwipsPerPixelX * 2) End If End Select OutlineSetX = currX End Function Sub Drawbox(Pic As Object, x As Long, y As Long, Plus As Integer) Dim twips As Integer, Holdstyle As Integer twips = Screen.TwipsPerPixelY Holdstyle = Pic.DrawStyle Pic.Line (x - 4 * twips, y - 4 * twips)-Step(8 * twips, 8 * twips), &HFFFFFF, BF Pic.DrawStyle = 0 Pic.Line (x - 4 * twips, y - 4 * twips)-Step(8 * twips, 8 * twips), &H808080, B Pic.Line (x - 2 * twips, y)-Step(5 * twips, 0), &H0 If Plus Then Pic.Line (x, y - 2 * twips)-Step(0, 5 * twips), &H0 Pic.DrawStyle = Holdstyle End Sub Public Sub DotLine95(OtlPic As Control, x1, y1, x2, y2) 'draws horizontal or vertical only ... no angles in this rev Dim foo As Integer, LowVal, HighVal, TwipsX As Integer, TwipsY As Integer Dim OtlPicHdc As Long Dim Checkit As Long TwipsX = Screen.TwipsPerPixelX TwipsY = Screen.TwipsPerPixelY OtlPicHdc = OtlPic.hDC If x1 = x2 Then If y1 < y2 Then LowVal = y1 HighVal = y2 Else LowVal = y2 HighVal = y1 End If If (LowVal \ TwipsY) Mod 2 = 1 Then LowVal = (LowVal \ TwipsY) * TwipsY - TwipsY If (x1 \ TwipsX) Mod 2 = 1 Then x1 = (x1 \ TwipsX) * TwipsX + TwipsX For foo = LowVal To HighVal Step TwipsX * 2 Checkit = SetPixel(OtlPicHdc, x1 / TwipsX, foo / TwipsY, &H808080) Next foo Else If x1 < x2 Then LowVal = x1 HighVal = x2 Else LowVal = x2 HighVal = x1 End If If (LowVal \ TwipsX) Mod 2 = 1 Then LowVal = (LowVal \ TwipsX) * TwipsX + TwipsX HighVal = (HighVal \ TwipsX) * TwipsX + TwipsX End If If (HighVal \ TwipsX) Mod 2 = 1 Then HighVal = (HighVal \ TwipsX) * TwipsX + TwipsX If (y1 \ TwipsY) Mod 2 = 1 Then y1 = (y1 \ TwipsY) * TwipsY - TwipsY For foo = LowVal To HighVal Step TwipsY * 2 Checkit = SetPixel(OtlPicHdc, foo / TwipsX, y1 / TwipsY, &H808080) Next foo End If End Sub 'Used to adjust outline control in response to scroll bar changes. Sub OutlineScroll(ScrollValue As Integer, OtlPic As Control, OtlScroll As Control, OtlSet As OtlSetup, Otldat As CollectionEx) Dim foo As Integer, Vispoint As Long If ChangingScroll Then Exit Sub Vispoint = -1 If ScrollValue < Otldat(OtlSet.DisplayIdx(1)).VisibleIdx Then For foo = OtlSet.DisplayIdx(1) To 1 Step -1 If ScrollValue = Otldat(foo).VisibleIdx Then OtlSet.CurrentLine = 1 OtlSet.SelectIdx = foo OtlSet.TopIdx = OtlSet.SelectIdx OutlineRefresh OtlPic, OtlScroll, OtlSet, Otldat Exit For End If Next foo Else If ScrollValue > Otldat(OtlSet.DisplayIdx(OtlSet.DisplayCount)).VisibleIdx Then 'find bottom to select For foo = OtlSet.DisplayIdx(OtlSet.DisplayCount) To Otldat.Count If ScrollValue = Otldat(foo).VisibleIdx Then OtlSet.CurrentLine = OtlSet.DisplayCount OtlSet.SelectIdx = foo Exit For End If Next foo 'Find TopIdx for display For foo = OtlSet.SelectIdx To 1 Step -1 If Otldat(foo).VisibleIdx = ScrollValue - OtlSet.DisplayCount Then Exit For Next foo OtlSet.TopIdx = foo + 1 OutlineRefresh OtlPic, OtlScroll, OtlSet, Otldat Else 'make sure current item is selected within display when scrollbar moves For foo = 1 To OtlSet.DisplayCount If Otldat(OtlSet.DisplayIdx(foo)).VisibleIdx = ScrollValue Then OtlSet.CurrentLine = foo OtlSet.SelectIdx = OtlSet.DisplayIdx(foo) OutlineRefresh OtlPic, OtlScroll, OtlSet, Otldat End If Next foo End If End If OtlPic.SetFocus End Sub 'Initializes the parameters for a code-based outline control Sub OutlineSetup(OtlPic As Control, OtlScroll As Control, OtlSet As OtlSetup, DataFields As String, Bmps As Boolean, Lines As Boolean, Plus As Boolean, Checkmarks As Boolean, SelectColor As Long, SelectTextColor As Long, BmpField As String, CheckmarkField As String) 'Initializes the OtlSetup control psuedo-properties 'Note: if using bitmaps for bullets, must have pic loaded for branch open, closed, and leaf Dim foo As Integer 'Dim VarArr() As String 'ReDim VarArr(0) As String 'OtlScroll.Move OtlPic.ScaleWidth - OtlScroll.Width, 0, OtlScroll.Width, OtlPic.ScaleHeight OtlScroll.Move OtlPic.Width - OtlScroll.Width, 0, OtlScroll.Width, OtlPic.Height 'removed for test - kdq 'foo = Parse2Array(DataFields, VarArr(), ",") 'DoEvents 'OtlSet.Levels = UBound(VarArr) + 1 'Erase OtlSet.VariableNames() 'For foo = 0 To OtlSet.Levels - 1 ' OtlSet.VariableNames(foo) = Trim$(VarArr(foo)) 'Next foo If BmpField > "" Then OtlSet.BmpField = BmpField Else OtlSet.BmpField = "" OtlSet.VisChangeFlag = True 'force first count If Bmps Then OtlSet.BmpFlag = 1 Else OtlSet.BmpFlag = 0 If Lines Then OtlSet.LineFlag = 1 Else OtlSet.LineFlag = 0 If Plus Then OtlSet.PlusFlag = 1 Else OtlSet.PlusFlag = 0 If Checkmarks Then OtlSet.CheckmarkFlag = True Else OtlSet.CheckmarkFlag = False OtlSet.CheckmarkField = CheckmarkField OtlSet.LineHeight = OtlPic.TextHeight("X") '* 1.1 'If OtlSet.LineHeight Mod Screen.TwipsPerPixelY <> 0 Then OtlSet.LineHeight = (OtlSet.LineHeight \ Screen.TwipsPerPixelY) * Screen.TwipsPerPixelY + Screen.TwipsPerPixelY OtlSet.LineHeight = OtlSet.LineHeight + ((OtlSet.LineHeight \ Screen.TwipsPerPixelY) Mod 4) * Screen.TwipsPerPixelY OtlSet.DisplayLines = OtlPic.Height \ OtlSet.LineHeight Erase OtlSet.DisplayIdx OtlSet.SelectColor = SelectColor OtlSet.SelectTextColor = SelectTextColor OtlSet.TopIdx = 1 OtlSet.SelectIdx = 1 OtlSet.PrevTop = -1 OtlSet.PrevSel = -1 End Sub 'Stretches a picture to a region in Destination Sub StrBltAllToPoint(dest As Object, dX As Integer, dY As Integer, dWidth As Integer, dHeight As Integer, source As Control) Dim foo As Integer, DestHoldMode As Integer, SrcHoldMode As Integer DestHoldMode = dest.ScaleMode dest.ScaleMode = 3 'Pixels SrcHoldMode = source.ScaleMode source.ScaleMode = 3 'Pixels foo = StretchBlt(dest.hDC, dX, dY, dWidth, dHeight, source.hDC, 0, 0, source.ScaleWidth, source.ScaleHeight, &HCC0020) dest.ScaleMode = DestHoldMode source.ScaleMode = SrcHoldMode End Sub 
