home *** CD-ROM | disk | FTP | other *** search
VERSION 5.00 Object = "{3B7C8863-D78F-101B-B9B5-04021C009402}#1.2#0"; "RICHTX32.OCX" Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "COMCTL32.OCX" Begin VB.UserControl ctlData ClientHeight = 2700 ClientLeft = 0 ClientTop = 0 ClientWidth = 3675 BeginProperty Font Name = "Tahoma" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty ScaleHeight = 2700 ScaleWidth = 3675 Begin VB.PictureBox picTabContainer BackColor = &H80000005& Height = 2415 Index = 4 Left = 360 ScaleHeight = 2355 ScaleWidth = 5835 TabIndex = 5 Top = 2880 Width = 5895 Begin VB.Label lblDBVer AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "DB Version:" ForeColor = &H000080FF& Height = 195 Left = 720 TabIndex = 17 Top = 1800 Width = 825 End Begin VB.Label lblItems AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Number Of Code Items: " ForeColor = &H000080FF& Height = 195 Left = 720 TabIndex = 16 Top = 1560 Width = 1755 End Begin VB.Shape shpBorder BorderStyle = 0 'Transparent FillColor = &H00C0E0FF& FillStyle = 0 'Solid Height = 1815 Left = 0 Top = 525 Width = 375 End Begin VB.Label lblFeatures AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Features found in the Develpers Code Book" DragIcon = "ctlData.ctx":0000 ForeColor = &H000080FF& Height = 195 Left = 720 TabIndex = 14 Top = 1080 Width = 3135 End Begin VB.Label lblAbout AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "About the Developers Code Book" DragIcon = "ctlData.ctx":030A ForeColor = &H000080FF& Height = 195 Left = 720 TabIndex = 13 Top = 1320 Width = 2385 End Begin VB.Label lblUrl AutoSize = -1 'True BackColor = &H00C0E0FF& BackStyle = 0 'Transparent Caption = "http://www.vbsquare.com/dev/" DragIcon = "ctlData.ctx":0614 BeginProperty Font Name = "Tahoma" Size = 8.25 Charset = 0 Weight = 400 Underline = -1 'True Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H000080FF& Height = 195 Left = 1440 TabIndex = 12 Top = 600 Width = 2820 End Begin VB.Label lblTitle AutoSize = -1 'True BackColor = &H000080FF& Caption = "Developers Code Book" BeginProperty Font Name = "Tahoma" Size = 21.75 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 525 Left = 0 TabIndex = 11 Top = 0 Width = 4410 End End Begin VB.PictureBox picTabContainer Height = 1575 Index = 5 Left = 1440 ScaleHeight = 1515 ScaleWidth = 3435 TabIndex = 7 Top = 3720 Width = 3495 Begin ComctlLib.ListView lvDetails Height = 975 Left = 120 TabIndex = 8 Top = 0 Width = 3015 _ExtentX = 5318 _ExtentY = 1720 View = 3 LabelEdit = 1 LabelWrap = -1 'True HideSelection = 0 'False _Version = 327682 ForeColor = -2147483640 BackColor = -2147483643 BorderStyle = 1 Appearance = 1 NumItems = 2 BeginProperty ColumnHeader(1) {0713E8C7-850A-101B-AFC0-4210102A8DA7} Key = "" Object.Tag = "" Text = "Description" Object.Width = 2540 EndProperty BeginProperty ColumnHeader(2) {0713E8C7-850A-101B-AFC0-4210102A8DA7} SubItemIndex = 1 Key = "" Object.Tag = "" Text = "Content" Object.Width = 2540 EndProperty End End Begin VB.PictureBox picTabContainer Height = 1575 Index = 2 Left = 1080 ScaleHeight = 1515 ScaleWidth = 3315 TabIndex = 2 Top = 3480 Width = 3375 Begin prjDevBook.ctlColour rtfExample Height = 1215 Left = 0 TabIndex = 10 Top = 0 Width = 2895 _ExtentX = 5106 _ExtentY = 2143 BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} Name = "Courier New" Size = 9 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} Name = "Courier New" Size = 9 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty BackColor = -2147483643 BorderStyle = 1 MouseIcon = "ctlData.ctx":091E OLEDropMode = 2 ScrollBars = 3 ColourComment = 32768 ColourKeyword = 8388608 TextRTF = $"ctlData.ctx":093A Object.TabStop = -1 'True End End Begin VB.PictureBox picTabContainer Height = 1575 Index = 3 Left = 840 ScaleHeight = 1515 ScaleWidth = 3435 TabIndex = 3 Top = 3240 Width = 3495 Begin RichTextLib.RichTextBox rtfNotes Height = 1095 Left = 0 TabIndex = 4 Top = 0 Width = 2895 _ExtentX = 5106 _ExtentY = 1931 _Version = 393217 ScrollBars = 3 TextRTF = $"ctlData.ctx":0A46 BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} Name = "Verdana" Size = 9.75 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty End End Begin VB.PictureBox picTabContainer Height = 1455 Index = 1 Left = 600 ScaleHeight = 1395 ScaleWidth = 3075 TabIndex = 1 Top = 3000 Width = 3135 Begin prjDevBook.ctlColour rtfCode Height = 1215 Left = 0 TabIndex = 9 Top = 0 Width = 2895 _ExtentX = 5106 _ExtentY = 2143 BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} Name = "Courier New" Size = 9.75 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} Name = "Courier New" Size = 9.75 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty BackColor = -2147483643 BorderStyle = 1 MouseIcon = "ctlData.ctx":0B52 OLEDropMode = 2 ScrollBars = 3 ColourComment = 32768 ColourKeyword = 8388608 TextRTF = $"ctlData.ctx":0B6E Object.TabStop = -1 'True End End Begin RichTextLib.RichTextBox txtTemp Height = 615 Left = 3720 TabIndex = 6 Top = 480 Visible = 0 'False Width = 855 _ExtentX = 1508 _ExtentY = 1085 _Version = 393217 Enabled = -1 'True HideSelection = 0 'False TextRTF = $"ctlData.ctx":0C7A BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} Name = "Courier New" Size = 9 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty End Begin ComctlLib.TabStrip tbsTab Height = 2655 Left = 0 TabIndex = 0 Top = 0 Width = 3615 _ExtentX = 6376 _ExtentY = 4683 ImageList = "imgIcons" _Version = 327682 BeginProperty Tabs {0713E432-850A-101B-AFC0-4210102A8DA7} NumTabs = 5 BeginProperty Tab1 {0713F341-850A-101B-AFC0-4210102A8DA7} Caption = "Code" Key = "" Object.Tag = "" Object.ToolTipText = "Code" ImageVarType = 8 ImageKey = "EDIT" EndProperty BeginProperty Tab2 {0713F341-850A-101B-AFC0-4210102A8DA7} Caption = "Example" Key = "" Object.Tag = "" Object.ToolTipText = "Example" ImageVarType = 8 ImageKey = "EXAMPLE" EndProperty BeginProperty Tab3 {0713F341-850A-101B-AFC0-4210102A8DA7} Caption = "Notes" Key = "" Object.Tag = "" Object.ToolTipText = "Notes" ImageVarType = 8 ImageKey = "NOTES" EndProperty BeginProperty Tab4 {0713F341-850A-101B-AFC0-4210102A8DA7} Caption = "Help" Key = "" Object.Tag = "" Object.ToolTipText = "Help" ImageVarType = 8 ImageKey = "HELP" EndProperty BeginProperty Tab5 {0713F341-850A-101B-AFC0-4210102A8DA7} Caption = "Details" Key = "" Object.Tag = "" Object.ToolTipText = "Details" ImageVarType = 8 ImageKey = "PROPS" EndProperty EndProperty BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} Name = "Tahoma" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty End Begin ComctlLib.ImageList imgIcons Left = 4080 Top = 2040 _ExtentX = 1005 _ExtentY = 1005 BackColor = -2147483633 ImageWidth = 16 ImageHeight = 16 MaskColor = 12632256 _Version = 327682 BeginProperty Images {0713E8C2-850A-101B-AFC0-4210102A8DA7} NumListImages = 5 BeginProperty ListImage1 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "ctlData.ctx":0D86 Key = "NOTES" EndProperty BeginProperty ListImage2 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "ctlData.ctx":10A0 Key = "EXAMPLE" EndProperty BeginProperty ListImage3 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "ctlData.ctx":13BA Key = "HELP" EndProperty BeginProperty ListImage4 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "ctlData.ctx":16D4 Key = "EDIT" EndProperty BeginProperty ListImage5 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "ctlData.ctx":19EE Key = "PROPS" EndProperty EndProperty End Begin VB.Label lblCaption BackColor = &H8000000C& Caption = "Developers Code Book" BeginProperty Font Name = "Tahoma" Size = 14.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H00FFFFFF& Height = 375 Left = 1560 TabIndex = 15 Top = 5640 Width = 3735 End Attribute VB_Name = "ctlData" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = True Attribute VB_PredeclaredId = False Attribute VB_Exposed = False '---------------------------------------- '- Name: Sam Huggill '- Email: sam@vbsquare.com '- Web: http://www.vbsquare.com/ '- Company: Lighthouse Internet Solutions '- Date/Time: 14/08/99 11:27:24 '---------------------------------------- '- Notes: Data control for the program. ' Interface between the tree and ' the data module '---------------------------------------- Option Explicit Private Const NumberOfTabs = 5 Private Const m_def_Enabled = 0 Private blnChanged As Boolean Dim m_Enabled As Boolean 'Default Property Values: Const m_def_Text = "" Const m_def_Code = "0" Const m_def_Example = "0" Const m_def_Notes = "" Const m_def_Caption = "0" 'Property Variables: Dim m_Text As String Dim m_Code As String Dim m_Example As String Dim m_Notes As String Dim m_Caption As String Private m_lngClr As Long Private sngListViewX As Single Private sngListViewY As Single Private WithEvents m_cMenu As cPopupMenu Attribute m_cMenu.VB_VarHelpID = -1 Private WithEvents m_cDetails As cPopupMenu Attribute m_cDetails.VB_VarHelpID = -1 Public Property Get Text() As String Text = rtfCode.Text End Property Public Property Get Code() As String Code = rtfCode.TextRTF End Property Public Property Let Code(ByVal New_Code As String) rtfCode.TextRTF = New_Code PropertyChanged "Code" End Property Public Property Get Example() As String Example = rtfExample.TextRTF End Property Public Property Let Example(ByVal New_Example As String) rtfExample.TextRTF = New_Example PropertyChanged "Example" End Property Public Property Get Notes() As String Notes = rtfNotes.TextRTF End Property Public Property Let Notes(ByVal New_Notes As String) rtfNotes.TextRTF = New_Notes ' rtfNotes.SelStart = 0 ' rtfNotes.SelLength = Len(rtfNotes.Text) ' rtfNotes.SelFontSize = "10" ' rtfNotes.SelStart = 0 PropertyChanged "Notes" End Property Public Property Get Caption() As String Caption = lblCaption End Property Public Property Let Caption(ByVal New_Caption As String) Dim strFirst As String Dim strSecond As String Dim strNewString As String PropertyChanged "Caption" '// Check for the ampersand character and '// add another one to make it visible If InStr(1, New_Caption, "&", vbTextCompare) Then strFirst = ParseString(New_Caption, "&", 1) strSecond = ParseString(New_Caption, "&", 2) strNewString = strFirst & "&&" & strSecond Else strNewString = New_Caption End If lblCaption = strNewString End Property Public Property Get Enabled() As Boolean Attribute Enabled.VB_Description = "Returns/sets a value that determines whether an object can respond to user-generated events." Enabled = UserControl.Enabled End Property Public Property Let Enabled(ByVal New_Enabled As Boolean) UserControl.Enabled() = New_Enabled PropertyChanged "Enabled" End Property Function Find(strFind As String) As Boolean Dim lngRet As Long Dim strBuffer As String Dim objRTF As Control '// Find text in the current edit window Select Case tbsTab.SelectedItem.Index Case 1 Set objRTF = rtfCode Case 2 Set objRTF = rtfExample Case 3 Set objRTF = rtfNotes Case Else End Select If Not (objRTF Is Nothing) Then strBuffer = objRTF.Text lngRet = InStr(1, strBuffer, strFind, vbTextCompare) If lngRet <> 0 Then objRTF.SelStart = lngRet - 1 objRTF.SelLength = Len(strFind) Find = True Exit Function End If MsgBox "Word not found." Find = False End If End Function Private Sub lblAbout_DragDrop(Source As Control, X As Single, Y As Single) If Source Is lblAbout Then With lblAbout frmAbout.Show vbModal .Font.Underline = False .ForeColor = &H80FF& End With End If End Sub Private Sub lblAbout_DragOver(Source As Control, X As Single, Y As Single, State As Integer) If State = vbLeave Then With lblAbout .Drag vbEndDrag .Font.Underline = False .ForeColor = &H80FF& End With End If End Sub Private Sub lblAbout_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) With lblAbout .ForeColor = vbBlue .Font.Underline = True .Drag vbBeginDrag End With End Sub Private Sub lblFeatures_DragDrop(Source As Control, X As Single, Y As Single) If Source = lblFeatures Then With lblFeatures MsgBox "Feature (excuse the pun!) not yet implemented :)" .Font.Underline = False .ForeColor = &H80FF& End With End If End Sub Private Sub lblFeatures_DragOver(Source As Control, X As Single, Y As Single, State As Integer) If State = vbLeave Then With lblFeatures .Drag vbEndDrag .Font.Underline = False .ForeColor = &H80FF& End With End If End Sub Private Sub lblFeatures_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) With lblFeatures .ForeColor = vbBlue .Font.Underline = True .Drag vbBeginDrag End With End Sub Private Sub lblUrl_DragDrop(Source As Control, X As Single, Y As Single) If Source Is lblURL Then With lblURL ShowUrl .Caption .Font.Underline = False .ForeColor = &H80FF& End With End If End Sub Private Sub lblUrl_DragOver(Source As Control, X As Single, Y As Single, State As Integer) If State = vbLeave Then With lblURL .Drag vbEndDrag .Font.Underline = False .ForeColor = &H80FF& End With End If End Sub Private Sub lblUrl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) With lblURL .ForeColor = vbBlue .Font.Underline = True .Drag vbBeginDrag End With End Sub Private Sub lvDetails_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) If Button = vbRightButton Then m_cDetails.Restore "FileMenu" If lvDetails.SelectedItem Is Nothing Then m_cDetails.Enabled(m_cDetails.IndexForKey("EDIT")) = False m_cDetails.Enabled(m_cDetails.IndexForKey("DELETE")) = False m_cDetails.Enabled(m_cDetails.IndexForKey("EXPORT")) = False Else If InStr(lvDetails.SelectedItem.Key, "L") Then ' Item is a link m_cDetails.Enabled(m_cDetails.IndexForKey("EXPORT")) = False m_cDetails.Enabled(m_cDetails.IndexForKey("EDIT")) = True m_cDetails.Enabled(m_cDetails.IndexForKey("DELETE")) = False Else m_cDetails.Enabled(m_cDetails.IndexForKey("EXPORT")) = True m_cDetails.Enabled(m_cDetails.IndexForKey("EDIT")) = False m_cDetails.Enabled(m_cDetails.IndexForKey("DELETE")) = True End If End If Call m_cDetails.ShowPopupMenu(X + 50, Y + lvDetails.tOp + (lblCaption.Height * 2)) End If sngListViewX = X sngListViewY = Y End Sub Private Sub m_cDetails_Click(ItemNumber As Long) Dim strPath As String Dim lngRetVal As Long Dim liItem As ListItem Dim strFile As String Select Case m_cDetails.ItemKey(ItemNumber) Case "IMPORT" ' Import a file strPath = frmMain.ShowFileDialog(eOpen, "", "File name to import...", "") If strPath <> "" Then modFiles.InsertFile strPath strFile = Right$(modData.Description, 3) Set liItem = lvDetails.ListItems.Add(, modData.Key, strFile) liItem.SubItems(1) = modData.Description Case "EXPORT" ' Export a file modFiles.OutputFile lvDetails Case "HLINK" ' Insert a hyperlink g_strLink = "" g_strName = "" frmInput.Show vbModal DoEvents If g_blnEnd = True Then ' The Input form has unloaded modFiles.InsertLink g_strLink, g_strName DoEvents With lvDetails Set liItem = .ListItems.Add(, modData.Key, modData.Description) liItem.SubItems(1) = g_strLink End With End If Case "EDIT" ' Edit or remove a hyperlink If lvDetails.SelectedItem Is Nothing Then MsgBox "Please select an item.": Exit Sub lngRetVal = MsgBox("Would you like to delete this link?", vbYesNo + vbQuestion) If lngRetVal = vbYes Then modData.EditLink lvDetails.SelectedItem.Key, True, lvDetails Else g_strName = lvDetails.SelectedItem.Text g_strLink = lvDetails.SelectedItem.SubItems(1) frmInput.Show vbModal If g_blnEnd = True Then modData.EditLink lvDetails.SelectedItem.Key, False, lvDetails, g_strLink, g_strName End If End If Case "DELETE" If lvDetails.SelectedItem Is Nothing Then Exit Sub lngRetVal = MsgBox("Are you sure you want to delete this file?", vbYesNo + vbCritical) If lngRetVal = vbYes Then modData.Key = lvDetails.SelectedItem.Key modData.DeleteFile lvDetails End If End Select End Sub Private Sub m_cMenu_Click(ItemNumber As Long) Dim sName As String Dim sEmail As String Dim sWeb As String Dim sCompany As String Dim sLine As String Dim sHeader As String '// Handle context menu clicks Select Case m_cMenu.ItemKey(ItemNumber) Case "HEADER" sName = GetSetting(ThisApp, "General", "Name", "") sEmail = GetSetting(ThisApp, "General", "Email", "") sWeb = GetSetting(ThisApp, "General", "Web", "") sCompany = GetSetting(ThisApp, "General", "Company", "") sLine = "'----------------------------------------" sHeader = sLine & vbCrLf & "'- Name:" & vbTab & sName sHeader = sHeader & vbCrLf & "'- Email:" & vbTab & sEmail sHeader = sHeader & vbCrLf & "'- Web:" & vbTab & sWeb sHeader = sHeader & vbCrLf & "'- Company:" & vbTab & sCompany sHeader = sHeader & vbCrLf & sLine sHeader = sHeader & vbCrLf & "'- Notes: " & vbTab sHeader = sHeader & vbCrLf & "'" & vbTab & vbTab sHeader = sHeader & vbCrLf & sLine Select Case tbsTab.SelectedItem.Index Case 1 rtfCode.SelStart = 0 Clipboard.SetText sHeader & vbCrLf rtfCode.PasteCode Case 2 rtfExample.SelStart = 0 Clipboard.SetText sHeader & vbCrLf & vbCrLf & rtfExample.Text rtfExample.PasteCode Case 3 rtfNotes.SelStart = 0 rtfNotes.Text = sHeader & vbCrLf & vbCrLf & rtfNotes.Text Case Else End Select Case "COPY" Copy Case "CUT" Cut Case "PASTE" Paste Case "DELETE" If frmMain.tvwItems.SelectedItem Is Nothing Then MsgBox "No item selected.", vbOKOnly + vbInformation Exit Sub End If modData.Key = frmMain.tvwItems.SelectedItem.Key modData.DeleteNode frmMain.tvwItems Case "SELECTALL" SelectAll Case "COLOUR" frmMain.tbrMain.ButtonEnabled("COLOUR") = False DoEvents Colour Case "FIND" frmFind.Show vbModal Case "PRINT" PrintCode Case Else End Select End Sub Private Sub picTabContainer_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single) lblAbout.ForeColor = &H80FF& End Sub Private Sub rtfCode_GotFocus() Dim Control As Object On Error Resume Next '// Allow tabs in the edit window For Each Control In Controls Control.TabStop = False Next Control End Sub Private Sub rtfCode_KeyUp(KeyCode As Integer, Shift As Integer) '// Enable/Disable the cut/copy/paste items If rtfCode.SelLength = 0 Then frmMain.tbrMain.ButtonEnabled("CUT") = False frmMain.tbrMain.ButtonEnabled("COPY") = False Else frmMain.tbrMain.ButtonEnabled("CUT") = True frmMain.tbrMain.ButtonEnabled("COPY") = True End If frmMain.tbrMain.ButtonEnabled("PASTE") = Clipboard.GetFormat(vbCFRTF) End Sub Private Sub rtfCode_LostFocus() '// Update the code if necessary modData.CompareCode frmMain.tvwItems, rtfCode.TextRTF, "Code" End Sub Private Sub rtfCode_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) If rtfCode.SelLength = 0 Then frmMain.tbrMain.ButtonEnabled("CUT") = False frmMain.tbrMain.ButtonEnabled("COPY") = False Else frmMain.tbrMain.ButtonEnabled("CUT") = True frmMain.tbrMain.ButtonEnabled("COPY") = True End If End Sub Private Sub rtfCode_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) Dim lngMenu As Long '// Show the context menu If Button = vbRightButton Then m_cMenu.Restore "DataMenu" m_cMenu.Enabled(m_cMenu.IndexForKey("PASTE")) = Clipboard.GetFormat(vbCFText) If rtfCode.SelLength = 0 Then m_cMenu.Enabled(m_cMenu.IndexForKey("COPY")) = False m_cMenu.Enabled(m_cMenu.IndexForKey("CUT")) = False End If lngMenu = m_cMenu.ShowPopupMenu(X, Y + rtfCode.tOp + (lblCaption.Height * 2)) End If If rtfCode.SelLength = 0 Then frmMain.tbrMain.ButtonEnabled("CUT") = False frmMain.tbrMain.ButtonEnabled("COPY") = False Else frmMain.tbrMain.ButtonEnabled("CUT") = True frmMain.tbrMain.ButtonEnabled("COPY") = True End If End Sub Private Sub rtfCode_SelChange() '// Enable/Disable the cut/copy/paste items If rtfCode.SelLength = 0 Then frmMain.tbrMain.ButtonEnabled("CUT") = False frmMain.tbrMain.ButtonEnabled("COPY") = False Else frmMain.tbrMain.ButtonEnabled("CUT") = True frmMain.tbrMain.ButtonEnabled("COPY") = True End If frmMain.tbrMain.ButtonEnabled("PASTE") = Clipboard.GetFormat(vbCFRTF) End Sub Private Sub rtfExample_LostFocus() '// Update the example if necessary modData.CompareCode frmMain.tvwItems, rtfExample.TextRTF, "Example" End Sub Private Sub rtfExample_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) Dim lngMenu As Long '// Show the context menu If Button = vbRightButton Then m_cMenu.Restore "DataMenu" m_cMenu.Enabled(m_cMenu.IndexForKey("PASTE")) = Clipboard.GetFormat(vbCFText) If rtfExample.SelLength = 0 Then m_cMenu.Enabled(m_cMenu.IndexForKey("COPY")) = False m_cMenu.Enabled(m_cMenu.IndexForKey("CUT")) = False End If lngMenu = m_cMenu.ShowPopupMenu(X, Y + rtfCode.tOp + (lblCaption.Height * 2)) End If End Sub Private Sub rtfNotes_GotFocus() '// Disable the colour button frmMain.tbrMain.ButtonEnabled("COLOUR") = False End Sub Private Sub rtfNotes_LostFocus() '// Update the code if necessary modData.CompareCode frmMain.tvwItems, rtfNotes.TextRTF, "Notes" frmMain.tbrMain.ButtonEnabled("COLOUR") = True End Sub Private Sub rtfNotes_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) Dim lngMenu As Long '// Show the context menu If Button = vbRightButton Then m_cMenu.Restore "DataMenu" m_cMenu.Enabled(m_cMenu.IndexForKey("PASTE")) = Clipboard.GetFormat(vbCFText) If rtfNotes.SelLength = 0 Then m_cMenu.Enabled(m_cMenu.IndexForKey("COPY")) = False m_cMenu.Enabled(m_cMenu.IndexForKey("CUT")) = False End If m_cMenu.Enabled(m_cMenu.IndexForKey("COLOUR")) = False lngMenu = m_cMenu.ShowPopupMenu(X, Y + rtfCode.tOp + (lblCaption.Height * 2)) End If End Sub Private Sub tbsTab_Click() Static PrevTab As Integer PrevTab = Switch(PrevTab = 0, 1, PrevTab >= 1 And PrevTab <= NumberOfTabs, PrevTab) picTabContainer(PrevTab).Visible = False picTabContainer(tbsTab.SelectedItem.Index).Visible = True picTabContainer(tbsTab.SelectedItem.Index).Refresh PrevTab = tbsTab.SelectedItem.Index DoEvents End Sub Private Sub tbsTab_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) lblURL.ForeColor = &H80FF& End Sub Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) lblAbout.ForeColor = &H80FF& End Sub Private Sub UserControl_Resize() '// Resize our panels With lblCaption .Move ScaleLeft, ScaleTop, ScaleWidth, .Height End With With tbsTab .Move UserControl.ScaleLeft, lblCaption.Height, UserControl.ScaleWidth, UserControl.ScaleHeight - lblCaption.Height End With With picTabContainer(1) .tOp = tbsTab.ClientTop .Width = tbsTab.ClientWidth .left = tbsTab.ClientLeft .Height = tbsTab.ClientHeight .Move .left, .tOp, .Width, .Height End With With picTabContainer(2) .tOp = tbsTab.ClientTop .Width = tbsTab.ClientWidth .left = tbsTab.ClientLeft .Height = tbsTab.ClientHeight .Move .left, .tOp, .Width, .Height End With With picTabContainer(3) .tOp = tbsTab.ClientTop .Width = tbsTab.ClientWidth .left = tbsTab.ClientLeft .Height = tbsTab.ClientHeight .Move .left, .tOp, .Width, .Height End With With picTabContainer(4) .tOp = tbsTab.ClientTop .Width = tbsTab.ClientWidth .left = tbsTab.ClientLeft .Height = tbsTab.ClientHeight .Move .left, .tOp, .Width, .Height End With With picTabContainer(5) .tOp = tbsTab.ClientTop .Width = tbsTab.ClientWidth .left = tbsTab.ClientLeft .Height = tbsTab.ClientHeight .Move .left, .tOp, .Width, .Height End With With tbsTab rtfCode.Move ScaleLeft, 0, .ClientWidth - rtfCode.left, .ClientHeight rtfExample.Move ScaleLeft, 0, .ClientWidth - rtfCode.left, .ClientHeight rtfNotes.Move ScaleLeft, 0, .ClientWidth - rtfCode.left, .ClientHeight lvDetails.Move ScaleLeft, 0, .ClientWidth - lvDetails.left, .ClientHeight End With With lblTitle .Move .left, .tOp, tbsTab.ClientWidth, .Height End With With shpBorder .Move .left, lblTitle.tOp + lblTitle.Height, .Width, tbsTab.ClientHeight - lblTitle.Height End With '// Remove the annoying text wrapping rtfCode.RightMargin = rtfCode.Width * 8 rtfExample.RightMargin = rtfExample.Width * 8 End Sub Public Sub Initalize() Dim intCount As Integer Dim blnControl As Boolean Dim blnTab As Boolean Dim intTabIndex As Integer Dim intIndex As Integer '// Organise our tabs For intCount = 1 To NumberOfTabs With picTabContainer(intCount) .BorderStyle = 0 .left = tbsTab.ClientLeft .tOp = tbsTab.ClientTop .Width = tbsTab.ClientWidth .Height = tbsTab.ClientHeight .Visible = False End With Next intCount '// Set the default caption lblCaption.Caption = "Developers Code Book" '// Adjust the list view controls SetControl '// Show the last used tab blnTab = GetSetting(ThisApp, "General", "Remember Tabs", True) If blnTab Then intTabIndex = Val(GetSetting(ThisApp, "General", "Data Control", 1)) '// Thanks to Randy Ledyard If intTabIndex = 0 Then intTabIndex = 1 tbsTab.Tabs(intTabIndex).Selected = True End If '// Init the popupmenu Set m_cMenu = New cPopupMenu With m_cMenu .ImageList = frmMain.ilsMenu .hwndOwner = UserControl.hwnd .GradientHighlight = True .Clear '// Add the items .AddItem "Insert &Header", , , , 24, , , "HEADER" .AddItem "&Delete Item", , , , 14, , , "DELETE" .AddItem "-", , , , , , , "SEP1" .AddItem "Cu&t", , , , 6, , , "CUT" .AddItem "&Copy", , , , 7, , , "COPY" .AddItem "&Paste", , , , 8, , , "PASTE" .AddItem "Select &All", , , , 22, , , "SELECTALL" .AddItem "-", , , , , , , "SEP2" .AddItem "Syntax Highlight", , , , 20, , , "COLOUR" .AddItem "Find", , , , 21, , , "FIND" .AddItem "Print code", , , , 23, , , "PRINT" .Store "DataMenu" End With Set m_cDetails = New cPopupMenu With m_cDetails .ImageList = frmMain.ilsMenu .hwndOwner = UserControl.hwnd .GradientHighlight = True .Clear .AddItem "&Import File", , , , 15, , , "IMPORT" .AddItem "&Export File", , , , 16, , , "EXPORT" .AddItem "&Delete File", , , , 14, , , "DELETE" .AddItem "-" .AddItem "&Insert Hyperlink", , , , 11, , , "HLINK" .AddItem "&Edit/Remove Hyperlink", , , , 25, , , "EDIT" .Store "FileMenu" End With '// Count the items CountItems frmMain.tvwItems rtfCode.ColourComment = GetSetting(ThisApp, "Colour", "Comment", RGB(0, 127, 0)) rtfExample.ColourComment = rtfCode.ColourComment rtfCode.ColourKeyword = GetSetting(ThisApp, "Colour", "Keyword", RGB(0, 0, 127)) rtfExample.ColourKeyword = rtfCode.ColourKeyword rtfCode.ColourText = GetSetting(ThisApp, "Colour", "Text", RGB(0, 0, 0)) rtfExample.ColourText = rtfCode.ColourText rtfNotes.Font.Size = "10" lblDBVer.Caption = lblDBVer.Caption & " " & App.Major modData.GetLinks lvDetails modData.GetFiles lvDetails End Sub Sub SelectTab(intTab As Integer) tbsTab.Tabs(intTab).Selected = True End Sub Sub SelectAll() Select Case tbsTab.SelectedItem.Index Case 1 rtfCode.SelStart = 0 rtfCode.SelLength = Len(rtfCode.Text) Case 2 rtfExample.SelStart = 0 rtfExample.SelLength = Len(rtfExample.Text) Case 3 rtfNotes.SelStart = 0 rtfNotes.SelLength = Len(rtfNotes.Text) Case Else End Select frmMain.tbrMain.ButtonEnabled("CUT") = True frmMain.tbrMain.ButtonEnabled("COPY") = True End Sub Sub Copy() '// You may want to remove this line '// It was put in because of problems copying Clipboard.Clear Select Case tbsTab.SelectedItem.Index Case 1 Clipboard.SetText rtfCode.SelText Case 2 Clipboard.SetText rtfExample.SelText Case 3 Clipboard.SetText rtfNotes.SelText Case Else End Select End Sub Sub Cut() Select Case tbsTab.SelectedItem.Index Case 1 Clipboard.SetText rtfCode.SelText rtfCode.SelText = "" Case 2 Clipboard.SetText rtfExample.SelText rtfExample.SelText = "" Case 3 Clipboard.SetText rtfNotes.SelText rtfNotes.SelText = "" Case Else End Select End Sub Sub Colour() '// Colours the current edit windows code Select Case tbsTab.SelectedItem.Index Case 1 rtfCode.Colour rtfCode, True DoEvents rtfCode.SetFocus Case 2 rtfExample.Colour rtfExample, True DoEvents rtfExample.SetFocus Case Else End Select DoEvents frmMain.tbrMain.ButtonEnabled("COLOUR") = True End Sub Public Sub PrintCode() ' Code by Jeffj rtfCode.SelPrint Printer.hdc, frmMain.cmdDialog End Sub Sub SetControl() Dim lStyle As Long Dim lHeaderHWND As Long Dim lLVHwnd As Long Dim lCount As Long '// Authored by Chris Eastwood lLVHwnd = lvDetails.hwnd SendMessageLong lLVHwnd, LVM_SETEXTENDEDLISTVIEWSTYLE, LVS_EX_FULLROWSELECT, True ' ' Turn off Redrawing at this point to speed up / hide the visible changes ' SendMessageLong lvDetails.hwnd, WM_SETREDRAW, False, &O0 For lCount = 0 To lvDetails.ColumnHeaders.Count - 1 Call SendMessageLong(lvDetails.hwnd, LVM_SETCOLUMNWIDTH, lCount, ByVal LVSCW_AUTOSIZE_USEHEADER) Next ' ' Turn Redrawing back on ' SendMessageLong lvDetails.hwnd, WM_SETREDRAW, True, &O0 End Sub Sub Terminate() Dim intTabIndex As Integer Dim blnTab As Boolean '// Save the current tab blnTab = GetSetting(ThisApp, "General", "Remember Tabs", True) If blnTab = True Then SaveSetting ThisApp, "General", "Data Control", tbsTab.SelectedItem.Index End If If Not (m_cDetails Is Nothing) Then m_cDetails.Clear m_cDetails.DestroySubClass End If Set m_cDetails = Nothing End Sub Public Function Undo() As Boolean Select Case tbsTab.SelectedItem.Index Case 1 SendMessage rtfCode.hwnd, EM_UNDO, 0&, 0& Case 2 SendMessage rtfExample.hwnd, EM_UNDO, 0&, 0& Case 3 SendMessage rtfNotes.hwnd, EM_UNDO, 0&, 0& Case Else End Select End Function Public Function CanUndo() As Boolean Select Case tbsTab.SelectedItem.Index Case 1 CanUndo = SendMessage(rtfCode.hwnd, EM_CANUNDO, 0&, 0&) Case 2 CanUndo = SendMessage(rtfExample.hwnd, EM_CANUNDO, 0&, 0&) Case 3 CanUndo = SendMessage(rtfNotes.hwnd, EM_CANUNDO, 0&, 0&) Case Else End Select End Function Public Sub Details(blnShow As Boolean) picTabContainer(tbsTab.SelectedItem.Index).Visible = blnShow tbsTab.Enabled = blnShow End Sub Public Sub Paste() Select Case tbsTab.SelectedItem.Index Case 1 rtfCode.PasteCode Case 2 rtfExample.PasteCode Case 3 rtfNotes.SelRTF = Clipboard.GetText(vbCFRTF) Case Else rtfCode.PasteCode End Select End Sub Public Property Get PlainCode() As String PlainCode = rtfCode.Text End Property Public Property Get PlainNotes() As String PlainNotes = rtfNotes.Text End Property Public Sub Redraw(blnRedraw As Boolean) If blnRedraw Then SendMessage UserControl.hwnd, WM_SETREDRAW, True, 0& Else SendMessage UserControl.hwnd, WM_SETREDRAW, False, 0& End If End Sub Public Sub CountItems(tvw As TreeView) '// If the number of items exceeds 67,000 then '// the API should be used because the treeviews '// Nodes.Count method fails to work lblItems = "Number of items: " & tvw.Nodes.Count - 1 End Sub Public Function Comment(lngNewClr As Long) As Long rtfCode.ColourComment = lngNewClr rtfExample.ColourComment = lngNewClr Comment = rtfExample.ColourComment SaveSetting ThisApp, "Colour", "Comment", lngNewClr End Function Public Function Keyword(lngNewClr As Long) As Long rtfCode.ColourKeyword = lngNewClr rtfExample.ColourKeyword = lngNewClr Keyword = rtfExample.ColourKeyword SaveSetting ThisApp, "Colour", "Keyword", lngNewClr End Function Public Function TextC(lngNewClr As Long) As Long rtfCode.ColourText = lngNewClr rtfExample.ColourText = lngNewClr TextC = rtfExample.ColourText SaveSetting ThisApp, "Colour", "Text", lngNewClr End Function Private Sub ShowUrl(strUrl As String) Call ShellExecute(0&, vbNullString, strUrl, vbNullString, vbNullString, vbNormalFocus) End Sub 'After trapping these coordinates, pass them to the HitTest method of the ListView control during the DoubleClick event to determine whether a user has double-clicked on a particular ListItem object: Private Sub lvDetails_DblClick() Dim lListItem As ListItem Set lListItem = lvDetails.HitTest(sngListViewX, _ sngListViewY) If (lListItem Is Nothing) Then Else If InStr(lListItem.Key, "L") Then ShellExecute 0&, vbNullString, lListItem.SubItems(1), vbNullString, vbNullString, vbNormalFocus End If Set lListItem = Nothing End Sub Sub SetColours() rtfCode.ColourComment = GetSetting(ThisApp, "Colour", "Comment", RGB(0, 127, 0)) rtfExample.ColourComment = rtfCode.ColourComment rtfCode.ColourKeyword = GetSetting(ThisApp, "Colour", "Keyword", RGB(0, 0, 127)) rtfExample.ColourKeyword = rtfCode.ColourKeyword rtfCode.ColourText = GetSetting(ThisApp, "Colour", "Text", RGB(0, 0, 0)) rtfExample.ColourText = rtfCode.ColourText rtfNotes.Font.Size = "10" End Sub 
(.txt)