able/windows-nt
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity
windows-nt/Source/XPSP1/NT/admin/pchealth/authtools/prodtools/ui/frmmain.frm
CryptoAlgo Inc b3cac27891 Add source files
2020-09-26 16:20:57 +08:00

5027 lines
132 KiB
Plaintext
Raw Permalink Blame History

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmMain
Caption = "HSC Production Tool"
ClientHeight = 8670
ClientLeft = 60
ClientTop = 630
ClientWidth = 11895
Icon = "frmMain.frx":0000
LinkTopic = "Form1"
ScaleHeight = 8670
ScaleWidth = 11895
Begin VB.ComboBox cboNavModel
Height = 315
Left = 8280
Style = 2 'Dropdown List
TabIndex = 5
Top = 0
Width = 1575
End
Begin VB.CommandButton cmdEditEntry
Caption = "Edit"
Height = 255
Left = 11160
TabIndex = 23
Top = 2520
Width = 615
End
Begin VB.TextBox txtEntry
Height = 285
Left = 6960
TabIndex = 22
Top = 2520
Width = 4095
End
Begin VB.CommandButton cmdURI
Caption = "..."
Height = 255
Left = 11400
TabIndex = 16
Top = 1440
Width = 375
End
Begin VB.CheckBox chkSubSite
Caption = "Su&bSite"
Height = 255
Left = 6480
TabIndex = 3
Top = 0
Width = 855
End
Begin VB.TextBox txtIconURI
Height = 285
Left = 6960
TabIndex = 18
Tag = "1"
Top = 1800
Width = 4815
End
Begin VB.Timer tmrRefresh
Interval = 18000
Left = 4320
Top = 0
End
Begin VB.CheckBox chkVisible
Caption = "&Visible"
Height = 255
Left = 5640
TabIndex = 2
Top = 0
Width = 855
End
Begin VB.ComboBox cboLocInclude
Height = 315
Left = 10800
TabIndex = 7
Text = "cboLocInclude"
Top = 0
Width = 975
End
Begin VB.ComboBox cboNavigateLink
Height = 315
Left = 9360
Style = 2 'Dropdown List
TabIndex = 25
Top = 3000
Width = 1935
End
Begin VB.ComboBox cboKeywords
Height = 1935
ItemData = "frmMain.frx":212A
Left = 5640
List = "frmMain.frx":212C
Sorted = -1 'True
Style = 1 'Simple Combo
TabIndex = 39
Tag = "1"
Top = 5520
Width = 6135
End
Begin VB.CommandButton cmdNavigateLink
Caption = "Go"
Height = 375
Left = 11400
TabIndex = 26
Top = 3000
Width = 375
End
Begin VB.Timer tmrScrollDuringDrag
Left = 3960
Top = 0
End
Begin MSComctlLib.StatusBar staInfo
Align = 2 'Align Bottom
Height = 375
Left = 0
TabIndex = 47
Top = 8295
Width = 11895
_ExtentX = 20981
_ExtentY = 661
_Version = 393216
BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628}
NumPanels = 3
BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628}
AutoSize = 1
Object.Width = 8440
MinWidth = 1270
EndProperty
BeginProperty Panel2 {8E3867AB-8586-11D1-B16A-00C0F0283628}
AutoSize = 1
Object.Width = 8440
MinWidth = 1270
EndProperty
BeginProperty Panel3 {8E3867AB-8586-11D1-B16A-00C0F0283628}
Object.Width = 3528
MinWidth = 3528
EndProperty
EndProperty
End
Begin VB.CommandButton cmdRefresh
Caption = "Refresh"
Height = 375
Left = 4080
TabIndex = 43
Top = 7800
Width = 1215
End
Begin VB.CommandButton cmdAddRemove
Caption = "&Add/Remove Keywords ..."
Height = 375
Left = 8880
TabIndex = 37
Top = 5040
Width = 2895
End
Begin VB.CommandButton cmdCreateLeaf
Caption = "Create Topic"
Height = 375
Left = 1440
TabIndex = 41
Top = 7800
Width = 1215
End
Begin MSComctlLib.ImageList ilsIcons
Left = 3360
Top = 0
_ExtentX = 1005
_ExtentY = 1005
BackColor = -2147483643
ImageWidth = 16
ImageHeight = 16
MaskColor = 16776960
_Version = 393216
BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628}
NumListImages = 6
BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmMain.frx":212E
Key = ""
EndProperty
BeginProperty ListImage2 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmMain.frx":2240
Key = ""
EndProperty
BeginProperty ListImage3 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmMain.frx":2352
Key = ""
EndProperty
BeginProperty ListImage4 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmMain.frx":2464
Key = ""
EndProperty
BeginProperty ListImage5 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmMain.frx":2576
Key = ""
EndProperty
BeginProperty ListImage6 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmMain.frx":2688
Key = ""
EndProperty
EndProperty
End
Begin VB.CommandButton cmdDelete
Caption = "Delete"
Height = 375
Left = 2760
TabIndex = 42
Top = 7800
Width = 1215
End
Begin VB.CommandButton cmdCreateGroup
Caption = "Create Node"
Height = 375
Left = 120
TabIndex = 40
Top = 7800
Width = 1215
End
Begin MSComDlg.CommonDialog dlgCommon
Left = 2880
Top = 0
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.CommandButton cmdCancel
Caption = "Cancel"
Height = 375
Left = 10560
TabIndex = 46
Top = 7800
Width = 1215
End
Begin VB.CommandButton cmdSave
Caption = "Save"
Height = 375
Left = 9240
TabIndex = 45
Top = 7800
Width = 1215
End
Begin VB.ComboBox cboType
Height = 315
Left = 6960
Style = 2 'Dropdown List
TabIndex = 13
Top = 1080
Width = 4815
End
Begin VB.TextBox txtURI
Height = 285
Left = 6960
TabIndex = 15
Tag = "1"
Top = 1440
Width = 4335
End
Begin VB.TextBox txtDescription
Height = 285
Left = 6960
TabIndex = 11
Tag = "1"
Top = 720
Width = 4815
End
Begin VB.TextBox txtTitle
Height = 285
Left = 6960
TabIndex = 9
Tag = "1"
Top = 360
Width = 4815
End
Begin MSComctlLib.TreeView treTaxonomy
Height = 7335
Left = 120
TabIndex = 1
Tag = "1"
Top = 360
Width = 5415
_ExtentX = 9551
_ExtentY = 12938
_Version = 393217
Indentation = 529
Style = 7
Appearance = 1
End
Begin VB.Frame fraSKU
Caption = "&SKU"
Height = 1575
Left = 5640
TabIndex = 27
Top = 3360
Width = 6135
Begin VB.CheckBox chkWindowsMillennium
Caption = "Windows Me"
Height = 255
Left = 240
TabIndex = 28
Top = 240
Width = 1695
End
Begin VB.CheckBox chkDataCenterServer64
Caption = "64-bit Datacenter Server"
Height = 255
Left = 3120
TabIndex = 36
Top = 1200
Width = 2055
End
Begin VB.CheckBox chkAdvancedServer64
Caption = "64-bit Advanced Server"
Height = 255
Left = 3120
TabIndex = 34
Top = 720
Width = 2055
End
Begin VB.CheckBox chkProfessional64
Caption = "64-bit Professional"
Height = 255
Left = 240
TabIndex = 31
Top = 960
Width = 1695
End
Begin VB.CheckBox chkDataCenterServer
Caption = "32-bit Datacenter Server"
Height = 255
Left = 3120
TabIndex = 35
Top = 960
Width = 2055
End
Begin VB.CheckBox chkAdvancedServer
Caption = "32-bit Advanced Server"
Height = 255
Left = 3120
TabIndex = 33
Top = 480
Width = 2055
End
Begin VB.CheckBox chkServer
Caption = "32-bit Server"
Height = 255
Left = 3120
TabIndex = 32
Top = 240
Width = 2055
End
Begin VB.CheckBox chkProfessional
Caption = "32-bit Professional"
Height = 255
Left = 240
TabIndex = 30
Top = 720
Width = 1695
End
Begin VB.CheckBox chkStandard
Caption = "32-bit Personal"
Height = 255
Left = 240
TabIndex = 29
Top = 480
Width = 1695
End
End
Begin VB.TextBox txtComments
Height = 285
Left = 6960
TabIndex = 20
Tag = "1"
Top = 2160
Width = 4815
End
Begin VB.Label lblNavModel
Caption = "Nav Model:"
Height = 255
Left = 7440
TabIndex = 4
Top = 0
Width = 855
End
Begin VB.Label lblEntry
Caption = "Entry:"
Height = 255
Left = 5640
TabIndex = 21
Top = 2520
Width = 1215
End
Begin VB.Label lblLastModified
BorderStyle = 1 'Fixed Single
Height = 375
Left = 5400
TabIndex = 44
Top = 7800
Width = 3735
End
Begin VB.Label lblIconURI
Caption = "Ico&n URI:"
Height = 255
Left = 5640
TabIndex = 17
Top = 1800
Width = 1215
End
Begin VB.Label lblLocInclude
Caption = "&Loc. Incl:"
Height = 255
Left = 9960
TabIndex = 6
Top = 0
Width = 735
End
Begin VB.Label lblNavigateLink
Caption = "Vie&w Topic:"
Height = 255
Left = 8400
TabIndex = 24
Top = 3000
Width = 855
End
Begin VB.Label lblComments
Caption = "&Comments:"
Height = 255
Left = 5640
TabIndex = 19
Top = 2160
Width = 1215
End
Begin VB.Label lblKeywords
Caption = "&Keywords associated with selected Node:"
Height = 255
Left = 5640
TabIndex = 38
Top = 5160
Width = 3135
End
Begin VB.Label lblURI
Caption = "&URI of the topic:"
Height = 255
Left = 5640
TabIndex = 14
Top = 1440
Width = 1215
End
Begin VB.Label lblType
Caption = "Ty&pe:"
Height = 255
Left = 5640
TabIndex = 12
Top = 1080
Width = 1215
End
Begin VB.Label lblDescription
Caption = "&Description:"
Height = 255
Left = 5640
TabIndex = 10
Top = 720
Width = 1215
End
Begin VB.Label lblTitle
Caption = "* T&itle:"
Height = 255
Left = 5640
TabIndex = 8
Top = 360
Width = 1215
End
Begin VB.Label lblTaxonomy
Caption = "&Taxonomy tree (including topics):"
Height = 255
Left = 120
TabIndex = 0
Top = 120
Width = 2775
End
Begin VB.Menu mnuFile
Caption = "&File"
Begin VB.Menu mnuFileOpenDatabase
Caption = "Open Database..."
End
Begin VB.Menu mnuFileExportHHT
Caption = "Archive authoring group changes..."
End
Begin VB.Menu mnuFileImportHHT
Caption = "Restore authoring group changes..."
End
Begin VB.Menu mnuSeparator0
Caption = "-"
End
Begin VB.Menu mnuFileExit
Caption = "Exit"
End
End
Begin VB.Menu mnuEdit
Caption = "&Edit"
Begin VB.Menu mnuEditStopSigns
Caption = "Stop Signs..."
End
Begin VB.Menu mnuEditStopWords
Caption = "Stop Words..."
End
Begin VB.Menu mnuEditKeywords
Caption = "Keywords..."
End
Begin VB.Menu mnuEditSynonymSets
Caption = "Synonym Sets..."
End
Begin VB.Menu mnuSeparator1
Caption = "-"
End
Begin VB.Menu mnuEditFind
Caption = "Find..."
Shortcut = ^F
End
Begin VB.Menu mnuEditCopy
Caption = "Copy"
Shortcut = ^Y
End
Begin VB.Menu mnuEditCut
Caption = "Cut"
Shortcut = ^T
End
Begin VB.Menu mnuEditPaste
Caption = "Paste"
Shortcut = ^P
End
Begin VB.Menu mnuSeparator2
Caption = "-"
End
Begin VB.Menu mnuEditCopyKeywords
Caption = "Copy Keywords"
Shortcut = ^K
End
Begin VB.Menu mnuEditPasteKeywords
Caption = "Paste Keywords"
Shortcut = ^L
End
End
Begin VB.Menu mnuTools
Caption = "T&ools"
Begin VB.Menu mnuToolsCreateHHTandCAB
Caption = "Create HHT and CAB..."
End
Begin VB.Menu mnuToolsFilterBySKU
Caption = "Filter by SKU..."
End
Begin VB.Menu mnuToolsImporter
Caption = "Importer..."
End
Begin VB.Menu mnuToolsParameters
Caption = "Parameters..."
End
Begin VB.Menu mnuToolsPropagateKeywords
Caption = "Propagate Keywords"
End
Begin VB.Menu mnuToolsSetFont
Caption = "Set Font..."
End
End
Begin VB.Menu mnuHelp
Caption = "&Help"
Begin VB.Menu mnuHelpContents
Caption = "Contents..."
End
Begin VB.Menu mnuSeparator3
Caption = "-"
End
Begin VB.Menu mnuHelpAbout
Caption = "About..."
End
End
Begin VB.Menu mnuRightClick
Caption = "RightClick"
Visible = 0 'False
Begin VB.Menu mnuRightClickCopy
Caption = "Copy"
End
Begin VB.Menu mnuRightClickCut
Caption = "Cut"
End
Begin VB.Menu mnuRightClickPaste
Caption = "Paste"
End
Begin VB.Menu mnuSeparator4
Caption = "-"
End
Begin VB.Menu mnuRightClickCopyKeywords
Caption = "Copy Keywords"
End
Begin VB.Menu mnuRightClickPasteKeywords
Caption = "Paste Keywords"
End
Begin VB.Menu mnuSeparator5
Caption = "-"
End
Begin VB.Menu mnuRightClickCreateNode
Caption = "Create Node"
End
Begin VB.Menu mnuRightClickCreateTopic
Caption = "Create Topic"
End
Begin VB.Menu mnuRightClickDelete
Caption = "Delete"
End
Begin VB.Menu mnuSeparator6
Caption = "-"
End
Begin VB.Menu mnuRightClickKeywordify
Caption = "Create Keywords from Titles"
End
Begin VB.Menu mnuRightClickExport
Caption = "Archive authoring group changes..."
End
End
Begin VB.Menu mnuMove
Caption = "Move"
Visible = 0 'False
Begin VB.Menu mnuMoveAbove
Caption = "Move Above"
End
Begin VB.Menu mnuMoveBelow
Caption = "Move Below"
End
Begin VB.Menu mnuMoveInside
Caption = "Move Inside"
End
End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private WithEvents p_clsTaxonomy As AuthDatabase.Taxonomy
Attribute p_clsTaxonomy.VB_VarHelpID = -1
Private WithEvents p_clsHHT As AuthDatabase.HHT
Attribute p_clsHHT.VB_VarHelpID = -1
Private p_clsKeywords As AuthDatabase.Keywords
Private p_clsParameters As AuthDatabase.Parameters
Private p_clsSizer As Sizer
Private p_colKeywords As Collection
Private p_dictKeywordsWithTitle As Scripting.Dictionary
Private p_intAuthoringGroup As Long
Private p_blnDatabaseOpen As Boolean
Private p_nodeMouseDown As Node
Private p_blnCtrlMouseDown As Boolean
Private p_nodeCopied As Node
Private p_nodeCut As Node
Private p_blnScrollUp As Boolean
Private p_DOMNode As MSXML2.IXMLDOMNode
Private p_blnHHKDragDrop As Boolean
Private p_blnAddRemoveKeywordsOpen As Boolean
Private p_strKeywords As String
Private p_blnNoHHTStatus As Boolean
Private p_enumFilterSKUs As SKU_E
Private p_blnCreating As Boolean
Private p_blnUpdating As Boolean
Private p_blnDragging As Boolean
Private p_blnSettingControls As Boolean
Private Const KEY_PREFIX_C As String = "TID"
Private Const CREATE_KEY_C As String = "Node being created"
Private Const MODIFY_KEY_C As String = "Node being modified"
Private Const MDB_FILE_FILTER_C As String = "Microsoft Access 2000 Files (*.mdb)|*.mdb"
Private Const XML_FILE_FILTER_C As String = "XML Files (*.xml)|*.xml"
Private Const HELP_FILE_NAME_C As String = "Hsc.chm"
Private Const HELP_EXE_C As String = "hh.exe"
Private Enum STATUS_BAR_PANEL_E
SBPANEL_DATABASE = 1
SBPANEL_OTHER = 2
SBPANEL_MODE = 3
End Enum
Private Declare Function SendMessage Lib "user32" Alias _
"SendMessageA" ( _
ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any _
) As Long
Private Enum IMAGE_E
IMAGE_LEAF_E = 1
IMAGE_GROUP_E = 2
IMAGE_BAD_LEAF_E = 3
IMAGE_BAD_GROUP_E = 4
IMAGE_FOREIGN_LEAF_E = 5
IMAGE_FOREIGN_GROUP_E = 6
End Enum
' Usage of a Node's Key and Tag:
' If a Taxonomy Node's TID is 8, then Key is TID8. Tag is its DOM Node.
' For a node being modified, Key is MODIFY_KEY_C.
' For a node under construction, Key is CREATE_KEY_C. Tag is the parent's DOM Node.
' A gotcha: You need to use CStr in p_colKeywords(CStr(intKID)).
' Otherwise, you will simply get the intKID'th keyword, not one with intKID as key.
Private Sub Form_Load()
SetLogFile
Set g_AuthDatabase = New AuthDatabase.Main
Set g_ErrorInfo = New CErrorInfo
Set p_clsTaxonomy = g_AuthDatabase.Taxonomy
Set p_clsHHT = g_AuthDatabase.HHT
Set p_clsKeywords = g_AuthDatabase.Keywords
Set p_clsParameters = g_AuthDatabase.Parameters
Set p_clsSizer = New Sizer
Set p_colKeywords = New Collection
Set p_dictKeywordsWithTitle = New Scripting.Dictionary
Set p_nodeMouseDown = Nothing
Set p_nodeCopied = Nothing
Set p_nodeCut = Nothing
Set p_DOMNode = Nothing
p_blnCtrlMouseDown = False
p_blnHHKDragDrop = False
p_blnAddRemoveKeywordsOpen = False
tmrScrollDuringDrag.Enabled = False
tmrScrollDuringDrag.Interval = 20
PopulateCboWithSKUs cboNavigateLink
p_InitializeLocIncludeCombo
p_InitializeNavModelCombo
p_enumFilterSKUs = ALL_SKUS_C
p_StrikeoutUnselectedSKUs
p_blnCreating = False
p_blnUpdating = False
p_blnDragging = False
p_blnSettingControls = False
' The user needs to open a database first
p_DisableEverything
p_InitializeTaxonomyTree
p_SetToolTips
End Sub
Private Sub Form_Unload(Cancel As Integer)
Set g_AuthDatabase = Nothing
Set g_ErrorInfo = Nothing
Set g_Font = Nothing
Set p_clsTaxonomy = Nothing
Set p_clsHHT = Nothing
Set p_clsKeywords = Nothing
Set p_clsParameters = Nothing
Set p_clsSizer = Nothing
Set p_colKeywords = Nothing
Set p_dictKeywordsWithTitle = Nothing
Set p_nodeMouseDown = Nothing
Set p_nodeCopied = Nothing
Set p_nodeCut = Nothing
Set p_DOMNode = Nothing
AddRemoveKeywordsFormGoingAway
Unload frmAddRemoveKeywords
Unload frmFind
Unload frmImporter
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
If (p_blnCreating Or p_blnUpdating) Then
MsgBox "You are in the middle of creating or updating an entry. " & _
"Please finish or cancel first.", vbOKOnly
Cancel = True
End If
End Sub
Private Sub Form_Activate()
On Error GoTo LErrorHandler
p_SetSizingInfo
Exit Sub
LErrorHandler:
g_ErrorInfo.SetInfoAndDump "Form_Activate"
End Sub
Private Sub Form_Resize()
On Error GoTo LErrorHandler
p_clsSizer.Resize
Exit Sub
LErrorHandler:
g_ErrorInfo.SetInfoAndDump "Form_Resize"
End Sub
Private Sub mnuFileOpenDatabase_Click()
Dim strDatabase As String
On Error GoTo LErrorHandler
dlgCommon.CancelError = True
dlgCommon.Flags = cdlOFNHideReadOnly
dlgCommon.Filter = MDB_FILE_FILTER_C
dlgCommon.ShowOpen
strDatabase = dlgCommon.FileName
g_AuthDatabase.SetDatabase strDatabase
p_SetTitle strDatabase
cmdRefresh_Click
' Clear the cached list of all keywords from the old database
AddRemoveKeywordsFormGoingAway
Unload frmAddRemoveKeywords
' frmImporter may have an HHK with KIDs from the old database
' associated with Taxonomy entries.
Unload frmImporter
p_blnDatabaseOpen = True
LEnd:
Exit Sub
LErrorHandler:
Select Case Err.Number
Case cdlCancel
' Nothing. The user cancelled.
Case errDatabaseVersionIncompatible
p_blnDatabaseOpen = False
DisplayDatabaseVersionError
Case errAuthoringGroupNotPresent
p_blnDatabaseOpen = False
DisplayAuthoringGroupError
Case Else
p_blnDatabaseOpen = False
g_ErrorInfo.SetInfoAndDump "mnuFileOpenDatabase_Click"
End Select
GoTo LEnd
End Sub
Private Sub mnuToolsSetFont_Click()
On Error GoTo LErrorHandler
dlgCommon.CancelError = True
dlgCommon.Flags = cdlCFBoth Or cdlCFEffects
dlgCommon.ShowFont
Set g_Font = New StdFont
g_Font.Name = dlgCommon.FontName
g_Font.Size = dlgCommon.FontSize
g_Font.Bold = dlgCommon.FontBold
g_Font.Italic = dlgCommon.FontItalic
g_Font.Underline = dlgCommon.FontUnderline
g_Font.Strikethrough = dlgCommon.FontStrikethru
g_FontColor = dlgCommon.Color
SetFont Me, g_Font, g_FontColor
Exit Sub
LErrorHandler:
' User pressed Cancel button.
Exit Sub
End Sub
Private Sub mnuFileExportHHT_Click()
Dim DOMNode As MSXML2.IXMLDOMNode
Set DOMNode = treTaxonomy.Nodes(KEY_PREFIX_C & ROOT_TID_C).Tag
p_ExportHHT DOMNode
End Sub
Private Sub mnuFileImportHHT_Click()
On Error GoTo LErrorHandler
Dim strFileName As String
Dim Response As VbMsgBoxResult
Response = MsgBox("Are you sure that you want to do this? " & _
"This operation could create a lot of new Nodes and Topics " & _
"throughout the Taxonomy tree.", _
vbOKCancel + vbDefaultButton2 + vbExclamation)
If (Response <> vbOK) Then
Exit Sub
End If
dlgCommon.CancelError = True
dlgCommon.Flags = cdlOFNHideReadOnly
dlgCommon.Filter = XML_FILE_FILTER_C
dlgCommon.ShowOpen
strFileName = dlgCommon.FileName
Me.Enabled = False
p_clsHHT.ImportHHT strFileName
cmdRefresh_Click
LEnd:
Me.Enabled = True
Exit Sub
LErrorHandler:
Select Case Err.Number
Case cdlCancel
' Nothing. The user cancelled.
Case errDatabaseVersionIncompatible
DisplayDatabaseVersionError
Case errAuthoringGroupNotPresent
DisplayAuthoringGroupError
Case Else
g_ErrorInfo.SetInfoAndDump "mnuFileImportHHT_Click"
End Select
GoTo LEnd
End Sub
Private Sub mnuFileExit_Click()
Unload Me
End Sub
Private Sub mnuEditFind_Click()
On Error GoTo LErrorHandler
frmFind.Show vbModeless
Exit Sub
LErrorHandler:
g_ErrorInfo.SetInfoAndDump "mnuEditFind_Click"
End Sub
Private Sub mnuEditCopy_Click()
On Error GoTo LErrorHandler
Set p_nodeCopied = treTaxonomy.SelectedItem
Set p_nodeCut = Nothing
Exit Sub
LErrorHandler:
g_ErrorInfo.SetInfoAndDump "mnuEditCopy_Click"
End Sub
Private Sub mnuEditCut_Click()
On Error GoTo LErrorHandler
Set p_nodeCut = treTaxonomy.SelectedItem
Set p_nodeCopied = Nothing
Exit Sub
LErrorHandler:
g_ErrorInfo.SetInfoAndDump "mnuEditCut_Click"
End Sub
Private Sub mnuEditPaste_Click()
On Error GoTo LErrorHandler
If (Not p_nodeCopied Is Nothing) Then
p_CreateTaxonomyEntries p_nodeCopied.Tag, treTaxonomy.SelectedItem, True
ElseIf (Not p_nodeCut Is Nothing) Then
p_ChangeParent p_nodeCut, treTaxonomy.SelectedItem
Set p_nodeCut = Nothing
p_DisableEditPaste
End If
Exit Sub
LErrorHandler:
g_ErrorInfo.SetInfoAndDump "mnuEditPaste_Click"
End Sub
Private Sub mnuEditCopyKeywords_Click()
On Error GoTo LErrorHandler
p_strKeywords = XMLGetAttribute(treTaxonomy.SelectedItem.Tag, HHT_keywords_C)
p_EnableEditPasteKeywords
Exit Sub
LErrorHandler:
g_ErrorInfo.SetInfoAndDump "mnuEditCopyKeywords_Click"
End Sub
Private Sub mnuEditPasteKeywords_Click()
On Error Resume Next
Dim Node As Node
Dim blnDisableEditPasteKeywords As Boolean
Dim intTID As Long
If (p_blnCreating Or p_blnUpdating) Then
MsgBox "You are in the middle of creating or updating an entry. " & _
"Please finish or cancel first.", vbOKOnly
Exit Sub
End If
blnDisableEditPasteKeywords = True
For Each Node In treTaxonomy.Nodes
If Node.Checked Then
Err.Clear
p_SetKeywords Node.Tag
If (Err.Number <> 0) Then
blnDisableEditPasteKeywords = False
Err.Clear
Else
Node.Checked = False
End If
End If
Next
If (blnDisableEditPasteKeywords) Then
p_DisableEditPasteKeywords
p_strKeywords = ""
Else
MsgBox "Not all Nodes/Topics could be updated.", vbOKOnly
End If
intTID = XMLGetAttribute(treTaxonomy.SelectedItem.Tag, HHT_tid_C)
' The UI must show the new keywords that were associated.
Highlight intTID
End Sub
Private Sub mnuEditStopSigns_Click()
frmStopSigns.Show vbModal
End Sub
Private Sub mnuEditStopWords_Click()
frmStopWords.Show vbModal
End Sub
Private Sub mnuEditKeywords_Click()
frmKeywords.Show vbModal
End Sub
Private Sub mnuEditSynonymSets_Click()
frmSynonymSets.Show vbModal
End Sub
Private Sub mnuToolsCreateHHTandCAB_Click()
p_blnNoHHTStatus = True
frmHHT.Show vbModal
p_blnNoHHTStatus = False
End Sub
Private Sub mnuToolsFilterBySKU_Click()
frmFilterSKU.SetSKUs p_enumFilterSKUs
frmFilterSKU.Show vbModal
End Sub
Private Sub mnuToolsImporter_Click()
frmImporter.Show vbModeless
End Sub
Private Sub mnuToolsParameters_Click()
frmParameters.Show vbModal
End Sub
Private Sub mnuToolsPropagateKeywords_Click()
On Error GoTo LErrorHandler
Dim T0 As Date
Dim T1 As Date
Dim strStatusText As String
strStatusText = p_GetStatusText(SBPANEL_DATABASE)
Me.MousePointer = vbHourglass
Me.Enabled = False
T0 = Now
p_SetStatusText SBPANEL_DATABASE, "Propagating keywords..."
p_clsTaxonomy.PropagateKeywords
p_SetStatusText SBPANEL_DATABASE, strStatusText
T1 = Now
Debug.Print "mnuToolsPropagateKeywords_Click: " & FormatTime(T0, T1)
cmdRefresh_Click
LEnd:
Me.Enabled = True
Me.MousePointer = vbDefault
Exit Sub
LErrorHandler:
p_SetStatusText SBPANEL_DATABASE, strStatusText
Select Case Err.Number
Case E_FAIL
DisplayDatabaseLockedError
Case errDatabaseVersionIncompatible
DisplayDatabaseVersionError
Case Else:
g_ErrorInfo.SetInfoAndDump "mnuToolsPropagateKeywords_Click"
End Select
GoTo LEnd
End Sub
Private Sub mnuRightClickCopy_Click()
mnuEditCopy_Click
End Sub
Private Sub mnuRightClickCut_Click()
mnuEditCut_Click
End Sub
Private Sub mnuRightClickPaste_Click()
mnuEditPaste_Click
End Sub
Private Sub mnuRightClickCopyKeywords_Click()
mnuEditCopyKeywords_Click
End Sub
Private Sub mnuRightClickPasteKeywords_Click()
mnuEditPasteKeywords_Click
End Sub
Private Sub mnuRightClickCreateNode_Click()
cmdCreateGroup_Click
End Sub
Private Sub mnuRightClickCreateTopic_Click()
cmdCreateLeaf_Click
End Sub
Private Sub mnuRightClickDelete_Click()
cmdDelete_Click
End Sub
Private Sub mnuRightClickKeywordify_Click()
On Error GoTo LErrorHandler
Dim DOMNode As MSXML2.IXMLDOMNode
Dim intTID As Long
Dim T0 As Date
Dim T1 As Date
Dim strStatusText As String
Dim Response As VbMsgBoxResult
strStatusText = p_GetStatusText(SBPANEL_DATABASE)
Response = MsgBox("Are you sure that you want to create Keywords from Titles of the " & _
"Node/Topic and its descendents?", _
vbOKCancel + vbDefaultButton2)
If (Response <> vbOK) Then
Exit Sub
End If
Me.MousePointer = vbHourglass
Me.Enabled = False
Set DOMNode = treTaxonomy.SelectedItem.Tag
intTID = XMLGetAttribute(DOMNode, HHT_tid_C)
T0 = Now
p_clsTaxonomy.KeywordifyTitles intTID
T1 = Now
Debug.Print "mnuRightClickKeywordify_Click: " & FormatTime(T0, T1)
p_SetStatusText SBPANEL_DATABASE, strStatusText
mnuToolsPropagateKeywords_Click
LEnd:
Me.Enabled = True
Me.MousePointer = vbDefault
Exit Sub
LErrorHandler:
p_SetStatusText SBPANEL_DATABASE, strStatusText
Select Case Err.Number
Case E_FAIL
DisplayDatabaseLockedError
Case errDatabaseVersionIncompatible
DisplayDatabaseVersionError
Case Else:
g_ErrorInfo.SetInfoAndDump "mnuRightClickKeywordify_Click"
End Select
GoTo LEnd
End Sub
Private Sub mnuRightClickExport_Click()
p_ExportHHT p_nodeMouseDown.Tag
End Sub
Private Sub mnuHelpContents_Click()
Dim strCmd As String
strCmd = HELP_EXE_C & " " & App.Path & "\" & HELP_FILE_NAME_C
Shell strCmd, vbNormalFocus
End Sub
Private Sub mnuHelpAbout_Click()
frmAbout.Show vbModal
End Sub
Private Sub chkVisible_Click()
If (Not p_blnSettingControls) Then
p_UserChangedSomethingForCurrentNode
End If
End Sub
Private Sub chkSubSite_Click()
If (Not p_blnSettingControls) Then
p_UserChangedSomethingForCurrentNode
End If
End Sub
Private Sub cboLocInclude_Change()
If (Not p_blnSettingControls) Then
p_UserChangedSomethingForCurrentNode
End If
End Sub
Private Sub p_clsTaxonomy_ReportStatus(ByVal strStatus As String, blnCancel As Boolean)
p_SetStatusText SBPANEL_DATABASE, strStatus
DoEvents
End Sub
Private Sub p_clsHHT_ReportStatus(ByVal strStatus As String, blnCancel As Boolean)
If (Not p_blnNoHHTStatus) Then
p_SetStatusText SBPANEL_DATABASE, strStatus
End If
DoEvents
End Sub
Private Sub txtTitle_Change()
On Error GoTo LErrorHandler
Dim Node As Node
If (p_blnSettingControls) Then
Exit Sub
End If
p_UserChangedSomethingForCurrentNode
If (p_blnCreating) Then
Set Node = treTaxonomy.Nodes(CREATE_KEY_C)
Node.Text = txtTitle
ElseIf (p_blnUpdating) Then
Set Node = treTaxonomy.Nodes(MODIFY_KEY_C)
Node.Text = txtTitle
End If
Exit Sub
LErrorHandler:
g_ErrorInfo.SetInfoAndDump "txtTitle_Change"
End Sub
Private Sub txtDescription_Change()
If (Not p_blnSettingControls) Then
p_UserChangedSomethingForCurrentNode
End If
End Sub
Private Sub cboNavModel_Click()
If (Not p_blnSettingControls) Then
p_UserChangedSomethingForCurrentNode
End If
End Sub
Private Sub cboNavModel_Change()
If (Not p_blnSettingControls) Then
p_UserChangedSomethingForCurrentNode
End If
End Sub
Private Sub cboType_Click()
If (Not p_blnSettingControls) Then
p_UserChangedSomethingForCurrentNode
End If
End Sub
Private Sub cboType_Change()
If (Not p_blnSettingControls) Then
p_UserChangedSomethingForCurrentNode
End If
End Sub
Private Sub txtURI_Change()
If (Not p_blnSettingControls) Then
p_UserChangedSomethingForCurrentNode
End If
End Sub
Private Sub txtIconURI_Change()
If (Not p_blnSettingControls) Then
p_UserChangedSomethingForCurrentNode
End If
End Sub
Private Sub txtComments_Change()
If (Not p_blnSettingControls) Then
p_UserChangedSomethingForCurrentNode
End If
End Sub
Private Sub txtEntry_Change()
If (Not p_blnSettingControls) Then
p_UserChangedSomethingForCurrentNode
End If
End Sub
Private Sub chkStandard_Click()
If (Not p_blnSettingControls) Then
p_UserChangedSomethingForCurrentNode
End If
End Sub
Private Sub chkProfessional_Click()
If (Not p_blnSettingControls) Then
p_UserChangedSomethingForCurrentNode
End If
End Sub
Private Sub chkProfessional64_Click()
If (Not p_blnSettingControls) Then
p_UserChangedSomethingForCurrentNode
End If
End Sub
Private Sub chkWindowsMillennium_Click()
If (Not p_blnSettingControls) Then
p_UserChangedSomethingForCurrentNode
End If
End Sub
Private Sub chkServer_Click()
If (Not p_blnSettingControls) Then
p_UserChangedSomethingForCurrentNode
End If
End Sub
Private Sub chkAdvancedServer_Click()
If (Not p_blnSettingControls) Then
p_UserChangedSomethingForCurrentNode
End If
End Sub
Private Sub chkDataCenterServer_Click()
If (Not p_blnSettingControls) Then
p_UserChangedSomethingForCurrentNode
End If
End Sub
Private Sub chkAdvancedServer64_Click()
If (Not p_blnSettingControls) Then
p_UserChangedSomethingForCurrentNode
End If
End Sub
Private Sub chkDataCenterServer64_Click()
If (Not p_blnSettingControls) Then
p_UserChangedSomethingForCurrentNode
End If
End Sub
Private Sub treTaxonomy_Collapse(ByVal Node As MSComctlLib.Node)
If (Node = treTaxonomy.SelectedItem) Then
treTaxonomy_NodeClick Node
End If
End Sub
Private Sub treTaxonomy_NodeClick(ByVal Node As MSComctlLib.Node)
On Error GoTo LErrorHandler
Dim blnUpdateControls As Boolean
Dim DOMNode As MSXML2.IXMLDOMNode
Dim intAG As Long
If (p_blnCreating Or p_blnUpdating) Then
' The user wants to go to a different Group/Leaf.
' Assume that he wants to save his changes.
p_SaveClicked blnUpdateControls
If (Not blnUpdateControls) Then
Exit Sub
End If
End If
If (p_NodeDeleted(Node)) Then
' If we start creating a node X, and then Create it by right clicking
' on it, then we will come here. The info on the RHS is up to date.
' So it is OK to simply exit.
Exit Sub
End If
Set DOMNode = Node.Tag
p_UpdateRHSControls DOMNode
Set treTaxonomy.SelectedItem = Node
If (p_IsLeaf(Node)) Then
p_DisableCreate
p_DisableEditPaste
p_DisableSubSite
p_DisableEditEntry
p_DisableNavModel
Else
p_EnableCreate
p_EnableSubSite
p_EnableNavModel
p_EnableEditEntry
If (Not p_nodeCut Is Nothing) Then
p_EnableEditPaste
ElseIf (Not p_nodeCopied Is Nothing) Then
p_EnableEditPaste
End If
End If
intAG = XMLGetAttribute(DOMNode, HHT_authoringgroup_C)
If (intAG = p_intAuthoringGroup) Then
p_EnableNodeDetailsExceptIndividualSKUs
Else
p_DisableNodeDetails
p_DisableDelete
p_DisableEditCut
End If
If (p_IsRoot(Node)) Then
p_DisableDelete
p_DisableEditCopy
p_DisableEditCut
p_DisableAddRemoveAndKeywordsCombo
Else
p_EnableEditCopy
If (intAG = p_intAuthoringGroup) Then
p_EnableDelete
p_EnableEditCut
p_EnableAddRemoveAndKeywordsCombo
End If
End If
Exit Sub
LErrorHandler:
g_ErrorInfo.SetInfoAndDump "treTaxonomy_NodeClick"
End Sub
Private Sub mnuMoveAbove_Click()
p_Move p_nodeMouseDown, treTaxonomy.DropHighlight, True
End Sub
Private Sub mnuMoveBelow_Click()
p_Move p_nodeMouseDown, treTaxonomy.DropHighlight, False
End Sub
Private Sub mnuMoveInside_Click()
p_ChangeParent p_nodeMouseDown, treTaxonomy.DropHighlight
End Sub
Private Sub p_PopupMoveMenu(i_Node As Node)
mnuMoveInside.Visible = True
mnuMoveAbove.Visible = True
mnuMoveBelow.Visible = True
If (p_IsLeaf(i_Node)) Then
mnuMoveInside.Visible = False
ElseIf (p_IsRoot(i_Node)) Then
mnuMoveAbove.Visible = False
mnuMoveBelow.Visible = False
End If
PopupMenu mnuMove
End Sub
Private Sub treTaxonomy_DragDrop(Source As Control, x As Single, y As Single)
On Error GoTo LErrorHandler
Dim nodeCurrent As Node
Dim Response As VbMsgBoxResult
Dim enumSKUs As SKU_E
Dim intParentTID As Long
Set nodeCurrent = treTaxonomy.DropHighlight
If (Not (nodeCurrent Is Nothing)) Then
If (Not p_nodeMouseDown Is Nothing) Then
If (p_nodeMouseDown.Key <> nodeCurrent.Key) Then
If (p_blnCtrlMouseDown) Then
If (Not p_IsLeaf(nodeCurrent)) Then
Response = MsgBox("Are you sure that you want to create " & _
"a copy of this Node or Topic?", _
vbOKCancel + vbDefaultButton1)
If (Response = vbOK) Then
p_CreateTaxonomyEntries p_nodeMouseDown.Tag, nodeCurrent, _
True
End If
End If
Else
p_PopupMoveMenu nodeCurrent
End If
End If
ElseIf (Not (p_DOMNode Is Nothing)) Then
If (p_blnCreating Or p_blnUpdating) Then
MsgBox "You are in the middle of creating or updating an entry. " & _
"Please finish or cancel first.", vbOKOnly
ElseIf (p_IsLeaf(nodeCurrent)) Then
MsgBox "Please drop over a Node, not a Topic.", vbOKOnly
Else
enumSKUs = frmImporter.GetSelectedSKUs
intParentTID = XMLGetAttribute(nodeCurrent.Tag, HHT_tid_C)
p_ReplaceTaxonomySubtree p_DOMNode, intParentTID, enumSKUs, True
Set p_DOMNode = Nothing
End If
End If
End If
Set treTaxonomy.DropHighlight = Nothing
Set p_nodeMouseDown = Nothing
Set p_DOMNode = Nothing
p_blnCtrlMouseDown = False
p_blnDragging = False
tmrScrollDuringDrag.Enabled = False
Exit Sub
LErrorHandler:
g_ErrorInfo.SetInfoAndDump "treTaxonomy_DragDrop"
End Sub
Private Sub treTaxonomy_DragOver(Source As Control, x As Single, y As Single, State As Integer)
On Error GoTo LErrorHandler
Dim nodeCurrent As Node
If (p_blnDragging) Then
If (y > 0 And y < 800) Then
'scroll up
p_blnScrollUp = True
tmrScrollDuringDrag.Enabled = True
ElseIf (y > (treTaxonomy.Height - 800) And y < treTaxonomy.Height) Then
'scroll down
p_blnScrollUp = False
tmrScrollDuringDrag.Enabled = True
Else
tmrScrollDuringDrag.Enabled = False
End If
Set nodeCurrent = treTaxonomy.HitTest(x, y)
If (nodeCurrent Is Nothing) Then
Exit Sub
End If
If (p_blnCtrlMouseDown And p_IsLeaf(nodeCurrent)) Then
Exit Sub
End If
Set treTaxonomy.DropHighlight = nodeCurrent
'nodeCurrent.Expanded = True Users hated this.
End If
Exit Sub
LErrorHandler:
g_ErrorInfo.SetInfoAndDump "treTaxonomy_DragOver"
End Sub
Private Sub treTaxonomy_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
If (Not p_blnCreating And Not p_blnUpdating) Then
If (treTaxonomy.Checkboxes) Then
Exit Sub
End If
Set p_nodeMouseDown = treTaxonomy.HitTest(x, y)
If (p_nodeMouseDown Is Nothing) Then
Exit Sub
End If
treTaxonomy_NodeClick p_nodeMouseDown
If (p_IsRoot(p_nodeMouseDown)) Then
Set p_nodeMouseDown = Nothing
End If
If (Not (p_nodeMouseDown Is Nothing)) Then
If (Shift = vbCtrlMask) Then
p_blnCtrlMouseDown = True
Else
p_blnCtrlMouseDown = False
End If
End If
End If
End Sub
Private Sub treTaxonomy_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
On Error GoTo LErrorHandler
If ((Not p_blnCreating And Not p_blnUpdating) And _
(Button = vbLeftButton) And _
(Not (p_nodeMouseDown Is Nothing))) Then
p_blnDragging = True
treTaxonomy.DragIcon = p_nodeMouseDown.CreateDragImage
treTaxonomy.Drag vbBeginDrag
End If
Exit Sub
LErrorHandler:
' If a node is selected, and then the user clicks on mnuFileOpenDatabase,
' and double clicks a database, this event fires. We get the exception "This item's
' control has been deleted".
End Sub
Public Sub BeginDrag( _
ByVal i_DOMNode As MSXML2.IXMLDOMNode, _
ByVal i_blnHHK As Boolean _
)
' Something is being dragged over from the frmImporter form.
Set p_nodeMouseDown = Nothing
p_blnCtrlMouseDown = False
Set p_DOMNode = i_DOMNode
p_blnHHKDragDrop = i_blnHHK
If (Not i_DOMNode Is Nothing) Then
p_blnDragging = True
Else
p_blnDragging = False
End If
End Sub
Private Sub treTaxonomy_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
tmrScrollDuringDrag.Enabled = False
If (Not p_blnCreating And Not p_blnUpdating) Then
Set p_nodeMouseDown = treTaxonomy.HitTest(x, y)
If (p_nodeMouseDown Is Nothing) Then
Exit Sub
End If
If (Button = vbRightButton) Then
Set treTaxonomy.SelectedItem = p_nodeMouseDown
PopupMenu mnuRightClick
End If
End If
End Sub
Private Sub Form_DragOver(Source As Control, x As Single, y As Single, State As Integer)
If Source.Name = "treTaxonomy" Then
tmrScrollDuringDrag.Enabled = False
End If
End Sub
Private Sub tmrScrollDuringDrag_Timer()
If (p_blnScrollUp) Then
' Send a WM_VSCROLL message 0 is up and 1 is down
SendMessage treTaxonomy.hwnd, 277&, 0&, vbNull
Else
'Scroll Down
SendMessage treTaxonomy.hwnd, 277&, 1&, vbNull
End If
End Sub
Private Sub tmrRefresh_Timer()
' Auto refresh every 30 min because we cache the database.
Static intTicks As Long
intTicks = intTicks + 1
If (intTicks <> 100) Then
Exit Sub
End If
intTicks = 0
If (p_blnUpdating Or p_blnCreating) Then
Exit Sub
End If
If (Not p_blnDatabaseOpen) Then
Exit Sub
End If
' cmdRefresh_Click
End Sub
Private Sub cmdCreateGroup_Click()
On Error GoTo LErrorHandler
p_CreateNode True
Exit Sub
LErrorHandler:
g_ErrorInfo.SetInfoAndDump "cmdCreateGroup_Click"
End Sub
Private Sub cmdCreateLeaf_Click()
On Error GoTo LErrorHandler
p_CreateNode False
Exit Sub
LErrorHandler:
g_ErrorInfo.SetInfoAndDump "cmdCreateLeaf_Click"
End Sub
Private Sub cmdDelete_Click()
On Error GoTo LErrorHandler
Dim nodeCurrent As Node
Dim strTitle As String
Dim str1 As String
Dim str2 As String
Dim Response As VbMsgBoxResult
Dim dtmModifiedTime As Date
Dim intTID As Long
Dim DOMNodeParent As MSXML2.IXMLDOMNode
Dim strStatusText As String
strStatusText = p_GetStatusText(SBPANEL_DATABASE)
If (p_blnCreating Or p_blnUpdating) Then
GoTo LEnd
End If
Set nodeCurrent = treTaxonomy.SelectedItem
strTitle = txtTitle
If (p_IsLeaf(nodeCurrent)) Then
str1 = "topic """
str2 = """"
Else
str1 = "node """
str2 = """ and all its children"
End If
Response = MsgBox("Are you sure that you want to permanently delete " & _
str1 & strTitle & str2 & "?", vbOKCancel + vbDefaultButton2)
If (Response <> vbOK) Then
GoTo LEnd
End If
Me.Enabled = False
dtmModifiedTime = XMLGetAttribute(nodeCurrent.Tag, HHT_modifiedtime_C)
intTID = XMLGetAttribute(nodeCurrent.Tag, HHT_tid_C)
p_clsTaxonomy.Delete intTID, dtmModifiedTime
Set DOMNodeParent = nodeCurrent.Tag.parentNode
DOMNodeParent.removeChild nodeCurrent.Tag
treTaxonomy.Nodes.Remove treTaxonomy.SelectedItem.Key
treTaxonomy_NodeClick treTaxonomy.SelectedItem
LEnd:
Me.Enabled = True
p_SetStatusText SBPANEL_DATABASE, strStatusText
Exit Sub
LErrorHandler:
Select Case Err.Number
Case errNodeOrTopicAlreadyModified
MsgBox "Someone else already modified this entry. " & _
"You need to Refresh the database and then try again. " & _
"This prevents you from accidentally overwriting something " & _
"the other person entered.", _
vbExclamation + vbOKOnly
Case E_FAIL
DisplayDatabaseLockedError
Case errDatabaseVersionIncompatible
DisplayDatabaseVersionError
Case errNotPermittedForAuthoringGroup, errAuthoringGroupDiffers, errAuthoringGroupNotPresent
DisplayAuthoringGroupError
Case Else:
g_ErrorInfo.SetInfoAndDump "cmdDelete_Click"
End Select
GoTo LEnd
End Sub
Private Sub cmdRefresh_Click()
On Error GoTo LErrorHandler
Dim DOMNode As MSXML2.IXMLDOMNode
Dim intTID As Long
p_intAuthoringGroup = p_clsParameters.AuthoringGroup
If (treTaxonomy.SelectedItem Is Nothing) Then
intTID = ROOT_TID_C
Else
intTID = XMLGetAttribute(treTaxonomy.SelectedItem.Tag, HHT_tid_C)
End If
Me.MousePointer = vbHourglass
p_InitializeDataStructures DOMNode
p_Refresh DOMNode
p_SetStatusText SBPANEL_DATABASE, "Database last read at: " & Now
If (p_NodeExists(intTID)) Then
treTaxonomy_NodeClick treTaxonomy.Nodes(KEY_PREFIX_C & intTID)
Else
treTaxonomy_NodeClick treTaxonomy.Nodes(KEY_PREFIX_C & ROOT_TID_C)
End If
LEnd:
Me.MousePointer = vbDefault
Exit Sub
LErrorHandler:
Me.Enabled = True
Select Case Err.Number
Case errAuthoringGroupNotPresent
DisplayAuthoringGroupError
Case Else
g_ErrorInfo.SetInfoAndDump "cmdRefresh_Click"
End Select
GoTo LEnd
End Sub
Private Sub cmdURI_Click()
frmURI.SetOldURI txtURI
frmURI.Show vbModal
End Sub
Private Sub cmdEditEntry_Click()
Dim Response As VbMsgBoxResult
If (Not p_blnCreating) Then
Response = MsgBox("Are you sure that you want to change this ENTRY? " & _
"Changing the ENTRY does not change the TITLE, " & _
"but it does change the identifier that others may be using " & _
"to reference this topic. If you really want to change this ENTRY, " & _
"please notify everybody who is linking to this topic so they can " & _
"update their hyperlink.", _
vbOKCancel + vbDefaultButton2 + vbExclamation)
If (Response <> vbOK) Then
p_DisableEntry
Exit Sub
End If
End If
p_EnableEntry
End Sub
Private Sub cmdNavigateLink_Click()
On Error GoTo LErrorHandler
Dim strBrokenLinkDir As String
Dim strVendor As String
Dim strURI As String
Dim Browser As HTMLDocument
strBrokenLinkDir = p_GetBrokenLinkDir(cboNavigateLink.ItemData(cboNavigateLink.ListIndex))
strVendor = p_clsParameters.Value(VENDOR_STRING_C) & ""
LinkValid strBrokenLinkDir, strVendor, txtURI, strURI
Set Browser = New HTMLDocument
Browser.url = strURI
Exit Sub
LErrorHandler:
Select Case Err.Number
Case errNotConfiguredForNavigateLink
MsgBox "Please verify that you've selected the correct SKU. " & _
"If the SKU is correct, the database needs to be configured " & _
"to point to the BrokenLinkWorkingDir.", _
vbExclamation Or vbOKOnly
Case Else
g_ErrorInfo.SetInfoAndDump "cmdNavigateLink_Click"
End Select
End Sub
Public Function GetNavigateLinkURI(i_intListIndex As Long) As String
On Error GoTo LErrorHandler
Dim strBrokenLinkDir As String
Dim strVendor As String
If (txtURI = "") Then
Exit Function
End If
strBrokenLinkDir = p_GetBrokenLinkDir(cboNavigateLink.ItemData(i_intListIndex))
strVendor = p_clsParameters.Value(VENDOR_STRING_C) & ""
LinkValid strBrokenLinkDir, strVendor, txtURI, GetNavigateLinkURI
Exit Function
LErrorHandler:
Select Case Err.Number
Case errNotConfiguredForNavigateLink
MsgBox "Please verify that you've selected the correct SKU. " & _
"If the SKU is correct, the database needs to be configured " & _
"to point to the BrokenLinkWorkingDir.", _
vbExclamation Or vbOKOnly
Case Else
g_ErrorInfo.SetInfoAndDump "GetNavigateLinkURI"
End Select
End Function
Private Sub cmdAddRemove_Click()
On Error GoTo LErrorHandler
Dim Node As Node
Set Node = treTaxonomy.SelectedItem
If (Node Is Nothing) Then
Exit Sub
End If
frmAddRemoveKeywords.SetKeywords p_dictKeywordsWithTitle
frmAddRemoveKeywords.SetTitle txtTitle, p_IsLeaf(Node)
If (txtURI <> "") Then
frmAddRemoveKeywords.LinkNavigable True
Else
frmAddRemoveKeywords.LinkNavigable False
End If
If (Not p_blnAddRemoveKeywordsOpen) Then
frmAddRemoveKeywords.Show vbModeless
p_blnAddRemoveKeywordsOpen = True
End If
Exit Sub
LErrorHandler:
g_ErrorInfo.SetInfoAndDump "cmdAddRemove_Click"
End Sub
Private Sub cboKeywords_KeyPress(KeyAscii As Integer)
On Error GoTo LErrorHandler
Dim strKeyword As String
Dim intIndex As Long
Dim intKID As Long
Dim Response As VbMsgBoxResult
If (KeyAscii <> Asc(vbCr)) Then
Exit Sub
End If
strKeyword = RemoveExtraSpaces(cboKeywords.Text)
cboKeywords.Text = ""
For intIndex = 0 To cboKeywords.ListCount
If (LCase$(strKeyword) = LCase$(cboKeywords.List(intIndex))) Then
Exit Sub
End If
Next
intKID = p_clsKeywords.GetKIDOfKeyword(strKeyword)
If (intKID = INVALID_ID_C) Then
Response = MsgBox( _
"The keyword """ & strKeyword & """ doesn't exist. Do you want to create it?", _
vbOKCancel + vbDefaultButton1)
If (Response = vbCancel) Then
Exit Sub
End If
End If
intKID = p_clsKeywords.Create(strKeyword)
p_dictKeywordsWithTitle.Add intKID, strKeyword
If (Not CollectionContainsKey(p_colKeywords, intKID)) Then
p_colKeywords.Add strKeyword, CStr(intKID)
End If
p_SetKeywordsList
p_UserChangedSomethingForCurrentNode
Exit Sub
LErrorHandler:
Select Case Err.Number
Case errContainsGarbageChar
MsgBox "The Keyword " & strKeyword & " contains garbage characters.", _
vbExclamation + vbOKOnly
Case errContainsStopSign
MsgBox "The Keyword " & strKeyword & " contains a Stop Sign.", _
vbExclamation + vbOKOnly
Case errContainsStopWord
MsgBox "The Keyword " & strKeyword & " contains a Stop Word.", _
vbExclamation + vbOKOnly
Case errContainsOperatorShortcut
MsgBox "The Keyword " & strKeyword & " contains an operator shortcut.", _
vbExclamation + vbOKOnly
Case errContainsVerbalOperator
MsgBox "The Keyword " & strKeyword & " contains a verbal operator.", _
vbExclamation + vbOKOnly
Case errContainsQuote
MsgBox "The Keyword " & strKeyword & " contains a quote.", _
vbExclamation + vbOKOnly
Case errTooLong
MsgBox "The Keyword " & strKeyword & " is too long", _
vbExclamation + vbOKOnly
Case E_FAIL
DisplayDatabaseLockedError
Case errDatabaseVersionIncompatible
DisplayDatabaseVersionError
Case Else
g_ErrorInfo.SetInfoAndDump "cboKeywords_KeyPress"
End Select
End Sub
Private Sub cmdSave_Click()
On Error GoTo LErrorHandler
Dim blnUpdateControls As Boolean
p_SaveClicked blnUpdateControls
Exit Sub
LErrorHandler:
g_ErrorInfo.SetInfoAndDump "cmdSave_Click"
End Sub
Private Sub cmdCancel_Click()
On Error GoTo LErrorHandler
Dim Node As Node
If (p_blnCreating) Then
p_DeleteNodeBeingCreated
p_SetModeCreating False
ElseIf (p_blnUpdating) Then
p_SetModeUpdating False
End If
treTaxonomy_NodeClick treTaxonomy.SelectedItem
Exit Sub
LErrorHandler:
g_ErrorInfo.SetInfoAndDump "cmdCancel_Click"
End Sub
Private Sub p_SetBrokenLinkAttribute( _
ByVal i_enumSKU As SKU_E, _
ByRef i_strBrokenLinkDir As String, _
ByRef i_strVendor As String, _
ByRef i_strBrokenLinkAttribute As String, _
ByRef u_DOMNode As MSXML2.IXMLDOMNode _
)
Dim enumSKUs As SKU_E
Dim strURI As String
Dim strNewURI As String
Dim DOMNode As MSXML2.IXMLDOMNode
Dim strTitle As String
enumSKUs = XMLGetAttribute(u_DOMNode, HHT_skus_C) And _
XMLGetAttribute(u_DOMNode, HHT_allowedskus_C)
strTitle = XMLGetAttribute(u_DOMNode, HHT_TITLE_C)
strURI = XMLGetAttribute(u_DOMNode, HHT_URI_C)
p_SetStatusText SBPANEL_DATABASE, "Evaluating " & strTitle
If ((i_enumSKU And enumSKUs) = 0) Then
XMLSetAttribute u_DOMNode, i_strBrokenLinkAttribute, "0"
Exit Sub
End If
If (LinkValid(i_strBrokenLinkDir, i_strVendor, strURI, strNewURI)) Then
XMLSetAttribute u_DOMNode, i_strBrokenLinkAttribute, "0"
Else
XMLSetAttribute u_DOMNode, i_strBrokenLinkAttribute, "1"
End If
If (Not (u_DOMNode.firstChild Is Nothing)) Then
For Each DOMNode In u_DOMNode.childNodes
p_SetBrokenLinkAttribute i_enumSKU, i_strBrokenLinkDir, i_strVendor, _
i_strBrokenLinkAttribute, DOMNode
Next
End If
End Sub
Private Sub p_ComputeBrokenLinkAttributes( _
ByVal i_enumSearchTarget As SEARCH_TARGET_E _
)
On Error GoTo LErrorHandler
Dim DOMNodeRoot As MSXML2.IXMLDOMNode
Dim strStatusText As String
Dim enumSKU As SKU_E
Dim strBrokenLinkDir As String
Dim strVendor As String
Dim strBrokenLinkAttribute As String
strStatusText = p_GetStatusText(SBPANEL_DATABASE)
Set DOMNodeRoot = treTaxonomy.Nodes(KEY_PREFIX_C & ROOT_TID_C).Tag
strVendor = p_clsParameters.Value(VENDOR_STRING_C) & ""
If (i_enumSearchTarget And ST_BROKEN_LINK_WINME_E) Then
enumSKU = SKU_WINDOWS_MILLENNIUM_E
strBrokenLinkAttribute = HHT_brokenlinkwinme_C
strBrokenLinkDir = p_GetBrokenLinkDir(enumSKU)
p_SetBrokenLinkAttribute enumSKU, strBrokenLinkDir, strVendor, strBrokenLinkAttribute, _
DOMNodeRoot
ElseIf (i_enumSearchTarget And ST_BROKEN_LINK_STD_E) Then
enumSKU = SKU_STANDARD_E
strBrokenLinkAttribute = HHT_brokenlinkstd_C
strBrokenLinkDir = p_GetBrokenLinkDir(enumSKU)
p_SetBrokenLinkAttribute enumSKU, strBrokenLinkDir, strVendor, strBrokenLinkAttribute, _
DOMNodeRoot
ElseIf (i_enumSearchTarget And ST_BROKEN_LINK_PRO_E) Then
enumSKU = SKU_PROFESSIONAL_E
strBrokenLinkAttribute = HHT_brokenlinkpro_C
strBrokenLinkDir = p_GetBrokenLinkDir(enumSKU)
p_SetBrokenLinkAttribute enumSKU, strBrokenLinkDir, strVendor, strBrokenLinkAttribute, _
DOMNodeRoot
ElseIf (i_enumSearchTarget And ST_BROKEN_LINK_PRO64_E) Then
enumSKU = SKU_PROFESSIONAL_64_E
strBrokenLinkAttribute = HHT_brokenlinkpro64_C
strBrokenLinkDir = p_GetBrokenLinkDir(enumSKU)
p_SetBrokenLinkAttribute enumSKU, strBrokenLinkDir, strVendor, strBrokenLinkAttribute, _
DOMNodeRoot
ElseIf (i_enumSearchTarget And ST_BROKEN_LINK_SRV_E) Then
enumSKU = SKU_SERVER_E
strBrokenLinkAttribute = HHT_brokenlinksrv_C
strBrokenLinkDir = p_GetBrokenLinkDir(enumSKU)
p_SetBrokenLinkAttribute enumSKU, strBrokenLinkDir, strVendor, strBrokenLinkAttribute, _
DOMNodeRoot
ElseIf (i_enumSearchTarget And ST_BROKEN_LINK_ADV_E) Then
enumSKU = SKU_ADVANCED_SERVER_E
strBrokenLinkAttribute = HHT_brokenlinkadv_C
strBrokenLinkDir = p_GetBrokenLinkDir(enumSKU)
p_SetBrokenLinkAttribute enumSKU, strBrokenLinkDir, strVendor, strBrokenLinkAttribute, _
DOMNodeRoot
ElseIf (i_enumSearchTarget And ST_BROKEN_LINK_ADV64_E) Then
enumSKU = SKU_ADVANCED_SERVER_64_E
strBrokenLinkAttribute = HHT_brokenlinkadv64_C
strBrokenLinkDir = p_GetBrokenLinkDir(enumSKU)
p_SetBrokenLinkAttribute enumSKU, strBrokenLinkDir, strVendor, strBrokenLinkAttribute, _
DOMNodeRoot
ElseIf (i_enumSearchTarget And ST_BROKEN_LINK_DAT_E) Then
enumSKU = SKU_DATA_CENTER_SERVER_E
strBrokenLinkAttribute = HHT_brokenlinkdat_C
strBrokenLinkDir = p_GetBrokenLinkDir(enumSKU)
p_SetBrokenLinkAttribute enumSKU, strBrokenLinkDir, strVendor, strBrokenLinkAttribute, _
DOMNodeRoot
ElseIf (i_enumSearchTarget And ST_BROKEN_LINK_DAT64_E) Then
enumSKU = SKU_DATA_CENTER_SERVER_64_E
strBrokenLinkAttribute = HHT_brokenlinkdat64_C
strBrokenLinkDir = p_GetBrokenLinkDir(enumSKU)
p_SetBrokenLinkAttribute enumSKU, strBrokenLinkDir, strVendor, strBrokenLinkAttribute, _
DOMNodeRoot
End If
LDone:
p_SetStatusText SBPANEL_DATABASE, strStatusText
Exit Sub
LErrorHandler:
Select Case Err.Number
Case errNotConfiguredForNavigateLink
MsgBox "Please verify that you've selected the correct SKU. " & _
"If the SKU is correct, the database needs to be configured " & _
"to point to the BrokenLinkWorkingDir.", _
vbExclamation Or vbOKOnly
End Select
GoTo LDone
End Sub
Private Function p_GetBrokenLinkXPathQuery( _
ByVal i_enumSearchTarget As SEARCH_TARGET_E _
) As String
Dim str As String
Dim strQuery As String
strQuery = "attribute::" & HHT_tid_C & "!=""" & INVALID_ID_C & """"
If (i_enumSearchTarget And ST_BROKEN_LINK_WINME_E) Then
str = "attribute::" & HHT_brokenlinkwinme_C & "=""1"""
strQuery = strQuery & " and " & str
End If
If (i_enumSearchTarget And ST_BROKEN_LINK_STD_E) Then
str = "attribute::" & HHT_brokenlinkstd_C & "=""1"""
strQuery = strQuery & " and " & str
End If
If (i_enumSearchTarget And ST_BROKEN_LINK_PRO_E) Then
str = "attribute::" & HHT_brokenlinkpro_C & "=""1"""
strQuery = strQuery & " and " & str
End If
If (i_enumSearchTarget And ST_BROKEN_LINK_PRO64_E) Then
str = "attribute::" & HHT_brokenlinkpro64_C & "=""1"""
strQuery = strQuery & " and " & str
End If
If (i_enumSearchTarget And ST_BROKEN_LINK_SRV_E) Then
str = "attribute::" & HHT_brokenlinksrv_C & "=""1"""
strQuery = strQuery & " and " & str
End If
If (i_enumSearchTarget And ST_BROKEN_LINK_ADV_E) Then
str = "attribute::" & HHT_brokenlinkadv_C & "=""1"""
strQuery = strQuery & " and " & str
End If
If (i_enumSearchTarget And ST_BROKEN_LINK_ADV64_E) Then
str = "attribute::" & HHT_brokenlinkadv64_C & "=""1"""
strQuery = strQuery & " and " & str
End If
If (i_enumSearchTarget And ST_BROKEN_LINK_DAT_E) Then
str = "attribute::" & HHT_brokenlinkdat_C & "=""1"""
strQuery = strQuery & " and " & str
End If
If (i_enumSearchTarget And ST_BROKEN_LINK_DAT64_E) Then
str = "attribute::" & HHT_brokenlinkdat64_C & "=""1"""
strQuery = strQuery & " and " & str
End If
p_GetBrokenLinkXPathQuery = strQuery
End Function
Private Function p_GetXPathAttributeString( _
ByVal i_strAttributeName As String, _
ByVal i_strStringToFind As String _
) As String
p_GetXPathAttributeString = "attribute::" & i_strAttributeName & _
"[contains(translate(., 'ABCDEFGHIJKLMNOPQRSTUVWXYZ', 'abcdefghijklmnopqrstuvwxyz')," & _
"""" & i_strStringToFind & """ )]"
End Function
Private Function p_GetXPathQuery( _
ByVal i_strStringToFind As String, _
ByVal i_enumSearchTarget As SEARCH_TARGET_E _
) As String
Dim strQuery As String
Dim str As String
strQuery = "descendant::TAXONOMY_ENTRY["
str = "attribute::" & HHT_tid_C & "!=""" & INVALID_ID_C & """"
strQuery = strQuery & str
If (i_enumSearchTarget And _
(ST_TITLE_E Or _
ST_DESCRIPTION_E Or _
ST_URI_E Or _
ST_COMMENTS_E Or _
ST_BASE_FILE_E)) Then
strQuery = strQuery & " and ("
strQuery = strQuery & p_GetXPathAttributeString(HHT_basefile_C, "!!!An impossible string!!!")
If (i_enumSearchTarget And ST_TITLE_E) Then
str = p_GetXPathAttributeString(HHT_TITLE_C, i_strStringToFind)
strQuery = strQuery & " or " & str
End If
If (i_enumSearchTarget And ST_DESCRIPTION_E) Then
str = p_GetXPathAttributeString(HHT_DESCRIPTION_C, i_strStringToFind)
strQuery = strQuery & " or " & str
End If
If (i_enumSearchTarget And ST_URI_E) Then
str = p_GetXPathAttributeString(HHT_URI_C, i_strStringToFind)
strQuery = strQuery & " or " & str
End If
If (i_enumSearchTarget And ST_COMMENTS_E) Then
str = p_GetXPathAttributeString(HHT_comments_C, i_strStringToFind)
strQuery = strQuery & " or " & str
End If
If (i_enumSearchTarget And ST_BASE_FILE_E) Then
str = p_GetXPathAttributeString(HHT_basefile_C, i_strStringToFind)
strQuery = strQuery & " or " & str
End If
strQuery = strQuery & ")"
End If
If (i_enumSearchTarget And ST_SELF_AUTHORING_GROUP_E) Then
str = "attribute::" & HHT_authoringgroup_C & "=""" & p_intAuthoringGroup & """"
strQuery = strQuery & " and " & str
End If
If (i_enumSearchTarget And ST_NODES_WITHOUT_KEYWORDS_E) Then
str = "attribute::" & HHT_keywords_C & "="""" and "
str = str & "attribute::" & HHT_leaf_C & "=""False"""
strQuery = strQuery & " and " & str
End If
If (i_enumSearchTarget And ST_TOPICS_WITHOUT_KEYWORDS_E) Then
str = "attribute::" & HHT_keywords_C & "="""" and "
str = str & "attribute::" & HHT_leaf_C & "=""True"""
strQuery = strQuery & " and " & str
End If
If (i_enumSearchTarget And _
(ST_BROKEN_LINK_WINME_E Or _
ST_BROKEN_LINK_STD_E Or _
ST_BROKEN_LINK_PRO_E Or _
ST_BROKEN_LINK_PRO64_E Or _
ST_BROKEN_LINK_SRV_E Or _
ST_BROKEN_LINK_ADV_E Or _
ST_BROKEN_LINK_ADV64_E Or _
ST_BROKEN_LINK_DAT_E Or _
ST_BROKEN_LINK_DAT64_E)) Then
p_ComputeBrokenLinkAttributes i_enumSearchTarget
str = p_GetBrokenLinkXPathQuery(i_enumSearchTarget)
strQuery = strQuery & " and " & str
End If
strQuery = strQuery & "]"
p_GetXPathQuery = strQuery
End Function
Public Function Find( _
ByVal i_strStringToFind As String, _
ByVal i_enumSearchTarget As SEARCH_TARGET_E _
) As MSXML2.IXMLDOMNodeList
Dim str As String
Dim DOMNodeRoot As MSXML2.IXMLDOMNode
Dim DOMDocument As MSXML2.DOMDocument
Dim strQuery As String
str = LCase$(i_strStringToFind)
strQuery = p_GetXPathQuery(str, i_enumSearchTarget)
Set DOMNodeRoot = treTaxonomy.Nodes(KEY_PREFIX_C & ROOT_TID_C).Tag
Set DOMDocument = DOMNodeRoot.ownerDocument
DOMDocument.setProperty "SelectionLanguage", "XPath"
Set Find = DOMNodeRoot.selectNodes(strQuery)
End Function
Public Sub Highlight( _
ByVal i_intTID As Long _
)
Dim Node As Node
If (Not p_NodeExists(i_intTID)) Then
MsgBox "The Node or Topic no longer exists", vbOKOnly
Exit Sub
End If
Set Node = treTaxonomy.Nodes(KEY_PREFIX_C & i_intTID)
Node.EnsureVisible
treTaxonomy_NodeClick Node
Set treTaxonomy.SelectedItem = Node
End Sub
Public Sub SetURI(ByVal i_strURI As String)
txtURI = i_strURI
End Sub
Public Sub SetKeywords(ByVal i_dictKeywordsWithTitle As Scripting.Dictionary)
On Error GoTo LErrorHandler
Dim intKID As Variant
p_dictKeywordsWithTitle.RemoveAll
For Each intKID In i_dictKeywordsWithTitle.Keys
p_dictKeywordsWithTitle.Add intKID, i_dictKeywordsWithTitle(intKID)
If (Not CollectionContainsKey(p_colKeywords, intKID)) Then
p_colKeywords.Add i_dictKeywordsWithTitle(intKID), CStr(intKID)
End If
Next
p_SetKeywordsList
p_UserChangedSomethingForCurrentNode
Exit Sub
LErrorHandler:
g_ErrorInfo.SetInfoAndRaiseError "SetKeywords"
End Sub
Public Sub AddRemoveKeywordsFormGoingAway()
p_blnAddRemoveKeywordsOpen = False
End Sub
Public Sub SetSKUs(i_enumSKUs As SKU_E)
On Error GoTo LErrorHandler
Dim T0 As Date
Dim T1 As Date
If (p_enumFilterSKUs <> i_enumSKUs) Then
p_enumFilterSKUs = i_enumSKUs
p_StrikeoutUnselectedSKUs
T0 = Now
p_UpdateSubTree ROOT_TID_C, ALL_SKUS_C
T1 = Now
Debug.Print "SetSKUs: " & FormatTime(T0, T1)
End If
Exit Sub
LErrorHandler:
g_ErrorInfo.SetInfoAndRaiseError "SetSKUs"
End Sub
Private Function p_IsLeaf(i_Node As Node) As Boolean
If ((i_Node.Image = IMAGE_LEAF_E) Or (i_Node.Image = IMAGE_BAD_LEAF_E) Or _
(i_Node.Image = IMAGE_FOREIGN_LEAF_E)) Then
p_IsLeaf = True
Else
p_IsLeaf = False
End If
End Function
Private Function p_IsRoot(i_Node As Node) As Boolean
If (i_Node.Parent Is Nothing) Then
p_IsRoot = True
Else
p_IsRoot = False
End If
End Function
Private Function p_NodeDeleted(i_Node As Node) As Boolean
Dim Node As Node
On Error GoTo LErrorHandler
Set Node = i_Node.Parent
p_NodeDeleted = False
Exit Function
LErrorHandler:
p_NodeDeleted = True
End Function
Private Function p_NodeExists(i_intTID As Long) As Boolean
Dim Node As Node
If (p_blnUpdating) Then
Set Node = treTaxonomy.Nodes(MODIFY_KEY_C)
If (XMLGetAttribute(Node.Tag, HHT_tid_C) = i_intTID) Then
p_NodeExists = True
Exit Function
End If
End If
On Error GoTo LErrorHandler
Set Node = treTaxonomy.Nodes(KEY_PREFIX_C & i_intTID)
p_NodeExists = True
Exit Function
LErrorHandler:
p_NodeExists = False
End Function
Private Sub p_UserChangedSomethingForCurrentNode()
On Error GoTo LErrorHandler
If (p_blnCreating Or p_blnUpdating) Then
Exit Sub
End If
p_SetModeUpdating True
Exit Sub
LErrorHandler:
g_ErrorInfo.SetInfoAndDump "p_UserChangedSomethingForCurrentNode"
End Sub
Private Sub p_SetLastModified( _
ByRef i_DOMNode As MSXML2.IXMLDOMNode _
)
Dim strLastModified As String
strLastModified = "Modified by " & XMLGetAttribute(i_DOMNode, HHT_username_C) & _
" on " & XMLGetAttribute(i_DOMNode, HHT_modifiedtime_C)
lblLastModified.Caption = strLastModified
End Sub
Private Sub p_UpdateRHSControls( _
ByRef i_DOMNode As MSXML2.IXMLDOMNode _
)
On Error GoTo LErrorHandler
Dim enumSKUs As SKU_E
Dim intAllowedSKUs As Long
Dim enumAllowedSKUs As SKU_E
Dim intIndex As Long
Dim arrKIDs() As String
Dim intKID As Long
Dim strKeyword As String
Dim intType As Long
Dim blnSettingControls As Boolean
blnSettingControls = p_blnSettingControls
p_blnSettingControls = True
txtTitle = XMLGetAttribute(i_DOMNode, HHT_TITLE_C)
txtDescription = XMLGetAttribute(i_DOMNode, HHT_DESCRIPTION_C)
txtURI = XMLGetAttribute(i_DOMNode, HHT_URI_C)
txtIconURI = XMLGetAttribute(i_DOMNode, HHT_ICONURI_C)
txtComments = XMLGetAttribute(i_DOMNode, HHT_comments_C)
txtEntry = XMLGetAttribute(i_DOMNode, HHT_ENTRY_C)
p_DisableEntry
p_SetLastModified i_DOMNode
chkVisible.Value = IIf(XMLGetAttribute(i_DOMNode, HHT_VISIBLE_C), 1, 0)
If (XMLGetAttribute(i_DOMNode, HHT_leaf_C)) Then
p_DisableSubSite
p_DisableNavModel
p_DisableEditEntry
Else
p_EnableSubSite
p_EnableNavModel
p_EnableEditEntry
End If
chkSubSite.Value = IIf(XMLGetAttribute(i_DOMNode, HHT_SUBSITE_C), 1, 0)
p_SetTypeComboIndex -1
intType = XMLGetAttribute(i_DOMNode, HHT_TYPE_C)
For intIndex = 0 To cboType.ListCount - 1
If (cboType.ItemData(intIndex) = intType) Then
p_SetTypeComboIndex intIndex
Exit For
End If
Next
p_SetNavModelCombo XMLGetAttribute(i_DOMNode, HHT_NAVIGATIONMODEL_C)
p_SetLocIncludeCombo XMLGetAttribute(i_DOMNode, HHT_locinclude_C)
p_SetSKUs XMLGetAttribute(i_DOMNode, HHT_skus_C), _
XMLGetAttribute(i_DOMNode, HHT_allowedskus_C)
If (txtURI <> "") Then
p_EnableNavigateLink
Else
p_DisableNavigateLink
End If
arrKIDs = Split(XMLGetAttribute(i_DOMNode, HHT_keywords_C), " ")
p_dictKeywordsWithTitle.RemoveAll
' This loop is time consuming and sometimes causes a couple of seconds delay.
' This mostly happens when there are a lot of KIDs of deleted keywords.
For intIndex = LBound(arrKIDs) To UBound(arrKIDs)
If (arrKIDs(intIndex) <> "") Then
intKID = arrKIDs(intIndex)
If (CollectionContainsKey(p_colKeywords, intKID)) Then
p_dictKeywordsWithTitle.Add intKID, p_colKeywords(CStr(intKID))
Else
' It is possible that Keyword propagation (for same URI) has gotten
' us new KIDs for which we don't have any Keyword.
p_clsKeywords.GetKeyword intKID, strKeyword
If (strKeyword <> "") Then
p_colKeywords.Add strKeyword, CStr(intKID)
p_dictKeywordsWithTitle.Add intKID, strKeyword
End If
End If
End If
Next
p_SetKeywordsList
' Reset it to the state it was in when this function was called.
p_blnSettingControls = blnSettingControls
If (p_blnAddRemoveKeywordsOpen) Then
cmdAddRemove_Click
End If
Exit Sub
LErrorHandler:
p_blnSettingControls = blnSettingControls
g_ErrorInfo.SetInfoAndRaiseError "p_UpdateRHSControls"
End Sub
Private Sub p_SetSKUs(i_enumSelectedSKUs As SKU_E, i_enumAllowedSKUs As SKU_E)
p_ClearSKUs
p_DisableSKUs
If (i_enumAllowedSKUs And SKU_STANDARD_E) Then
chkStandard.Enabled = True
If (i_enumSelectedSKUs And SKU_STANDARD_E) Then
chkStandard.Value = 1
End If
End If
If (i_enumAllowedSKUs And SKU_PROFESSIONAL_E) Then
chkProfessional.Enabled = True
If (i_enumSelectedSKUs And SKU_PROFESSIONAL_E) Then
chkProfessional.Value = 1
End If
End If
If (i_enumAllowedSKUs And SKU_PROFESSIONAL_64_E) Then
chkProfessional64.Enabled = True
If (i_enumSelectedSKUs And SKU_PROFESSIONAL_64_E) Then
chkProfessional64.Value = 1
End If
End If
If (i_enumAllowedSKUs And SKU_WINDOWS_MILLENNIUM_E) Then
chkWindowsMillennium.Enabled = True
If (i_enumSelectedSKUs And SKU_WINDOWS_MILLENNIUM_E) Then
chkWindowsMillennium.Value = 1
End If
End If
If (i_enumAllowedSKUs And SKU_SERVER_E) Then
chkServer.Enabled = True
If (i_enumSelectedSKUs And SKU_SERVER_E) Then
chkServer.Value = 1
End If
End If
If (i_enumAllowedSKUs And SKU_ADVANCED_SERVER_E) Then
chkAdvancedServer.Enabled = True
If (i_enumSelectedSKUs And SKU_ADVANCED_SERVER_E) Then
chkAdvancedServer.Value = 1
End If
End If
If (i_enumAllowedSKUs And SKU_DATA_CENTER_SERVER_E) Then
chkDataCenterServer.Enabled = True
If (i_enumSelectedSKUs And SKU_DATA_CENTER_SERVER_E) Then
chkDataCenterServer.Value = 1
End If
End If
If (i_enumAllowedSKUs And SKU_ADVANCED_SERVER_64_E) Then
chkAdvancedServer64.Enabled = True
If (i_enumSelectedSKUs And SKU_ADVANCED_SERVER_64_E) Then
chkAdvancedServer64.Value = 1
End If
End If
If (i_enumAllowedSKUs And SKU_DATA_CENTER_SERVER_64_E) Then
chkDataCenterServer64.Enabled = True
If (i_enumSelectedSKUs And SKU_DATA_CENTER_SERVER_64_E) Then
chkDataCenterServer64.Value = 1
End If
End If
End Sub
Private Function p_GetSelectedSKUs() As SKU_E
Dim enumSelectedSKUs As SKU_E
If (chkStandard.Value = 1) Then
enumSelectedSKUs = enumSelectedSKUs Or SKU_STANDARD_E
End If
If (chkProfessional.Value = 1) Then
enumSelectedSKUs = enumSelectedSKUs Or SKU_PROFESSIONAL_E
End If
If (chkProfessional64.Value = 1) Then
enumSelectedSKUs = enumSelectedSKUs Or SKU_PROFESSIONAL_64_E
End If
If (chkWindowsMillennium.Value = 1) Then
enumSelectedSKUs = enumSelectedSKUs Or SKU_WINDOWS_MILLENNIUM_E
End If
If (chkServer.Value = 1) Then
enumSelectedSKUs = enumSelectedSKUs Or SKU_SERVER_E
End If
If (chkAdvancedServer.Value = 1) Then
enumSelectedSKUs = enumSelectedSKUs Or SKU_ADVANCED_SERVER_E
End If
If (chkDataCenterServer.Value = 1) Then
enumSelectedSKUs = enumSelectedSKUs Or SKU_DATA_CENTER_SERVER_E
End If
If (chkAdvancedServer64.Value = 1) Then
enumSelectedSKUs = enumSelectedSKUs Or SKU_ADVANCED_SERVER_64_E
End If
If (chkDataCenterServer64.Value = 1) Then
enumSelectedSKUs = enumSelectedSKUs Or SKU_DATA_CENTER_SERVER_64_E
End If
p_GetSelectedSKUs = enumSelectedSKUs
End Function
Private Function p_GetSelectedNavModel() As Long
If (cboNavModel.ListIndex = -1) Then
p_GetSelectedNavModel = NAVMODEL_DEFAULT_NUM_C
Else
p_GetSelectedNavModel = cboNavModel.ItemData(cboNavModel.ListIndex)
End If
End Function
Private Function p_GetSelectedType() As Long
If (cboType.ListIndex = -1) Then
p_GetSelectedType = 0
Else
p_GetSelectedType = cboType.ItemData(cboType.ListIndex)
End If
End Function
Private Function p_GetSelectedLocInclude() As String
p_GetSelectedLocInclude = cboLocInclude.Text
End Function
Private Sub p_SetNodeColor( _
ByRef i_Node As Node, _
ByRef i_DOMNode As MSXML2.IXMLDOMNode _
)
Dim enumSKUs As SKU_E
Dim blnVisible As Boolean
Dim blnSubSite As Boolean
enumSKUs = XMLGetAttribute(i_DOMNode, HHT_skus_C) And _
XMLGetAttribute(i_DOMNode, HHT_allowedskus_C)
blnVisible = XMLGetAttribute(i_DOMNode, HHT_VISIBLE_C)
blnSubSite = XMLGetAttribute(i_DOMNode, HHT_SUBSITE_C)
If ((p_enumFilterSKUs And enumSKUs) = 0) Then
i_Node.ForeColor = vbWhite
i_Node.BackColor = vbWhite
Else
If (blnVisible) Then
i_Node.ForeColor = vbBlack
Else
i_Node.ForeColor = &HB0B0B0
End If
End If
If (blnSubSite) Then
i_Node.Bold = True
Else
i_Node.Bold = False
End If
End Sub
Private Sub p_SetNodeImage( _
ByRef i_Node As Node, _
ByRef i_DOMNode As MSXML2.IXMLDOMNode _
)
Dim blnLeaf As Boolean
Dim intAG As Long
blnLeaf = XMLGetAttribute(i_DOMNode, HHT_leaf_C)
intAG = XMLGetAttribute(i_DOMNode, HHT_authoringgroup_C)
If (intAG <> p_intAuthoringGroup) Then
If (blnLeaf) Then
i_Node.Image = IMAGE_FOREIGN_LEAF_E
Else
i_Node.Image = IMAGE_FOREIGN_GROUP_E
End If
Exit Sub
End If
If (blnLeaf) Then
i_Node.Image = IMAGE_LEAF_E
Else
i_Node.Image = IMAGE_GROUP_E
End If
End Sub
Private Sub p_DeleteNodeBeingCreated()
On Error GoTo LErrorHandler
treTaxonomy.Nodes.Remove CREATE_KEY_C
Exit Sub
LErrorHandler:
g_ErrorInfo.SetInfoAndRaiseError "p_DeleteNodeBeingCreated"
End Sub
Private Sub p_SetModeCreating(i_bln As Boolean)
On Error GoTo LErrorHandler
If (i_bln And Not p_blnCreating) Then
p_blnCreating = True
p_DisableCreate
p_DisableDelete
p_DisableRefresh
p_EnableSaveCancel
p_SetStatusText SBPANEL_MODE, "Creating Node/Topic"
ElseIf (Not i_bln And p_blnCreating) Then
p_blnCreating = False
p_EnableRefresh
p_DisableSaveCancel
p_SetStatusText SBPANEL_MODE, ""
End If
Exit Sub
LErrorHandler:
g_ErrorInfo.SetInfoAndRaiseError "p_SetModeCreating"
End Sub
Private Sub p_SetModeUpdating(i_bln As Boolean)
On Error GoTo LErrorHandler
Dim Node As Node
If (i_bln And Not p_blnUpdating) Then
p_blnUpdating = True
treTaxonomy.SelectedItem.Key = MODIFY_KEY_C
p_DisableCreate
p_DisableDelete
p_DisableRefresh
p_EnableSaveCancel
p_SetStatusText SBPANEL_MODE, "Modifying Node/Topic"
ElseIf (Not i_bln And p_blnUpdating) Then
p_blnUpdating = False
p_EnableRefresh
Set Node = treTaxonomy.Nodes(MODIFY_KEY_C)
Node.Key = KEY_PREFIX_C & XMLGetAttribute(Node.Tag, HHT_tid_C)
Node.Text = XMLGetAttribute(Node.Tag, HHT_TITLE_C)
p_DisableSaveCancel
p_SetStatusText SBPANEL_MODE, ""
End If
Exit Sub
LErrorHandler:
g_ErrorInfo.SetInfoAndRaiseError "p_SetModeUpdating"
End Sub
Private Sub p_ExportHHT( _
ByRef i_DOMNode As MSXML2.IXMLDOMNode _
)
On Error GoTo LErrorHandler
Dim strFileName As String
Dim DOMNode As MSXML2.IXMLDOMNode
Dim strStatusText As String
strStatusText = p_GetStatusText(SBPANEL_DATABASE)
dlgCommon.CancelError = True
dlgCommon.Flags = cdlOFNHideReadOnly
dlgCommon.Filter = XML_FILE_FILTER_C
dlgCommon.ShowSave
strFileName = Trim$(dlgCommon.FileName)
If (strFileName = "") Then
Exit Sub
End If
Me.Enabled = False
p_clsHHT.ExportHHT strFileName
LEnd:
Me.Enabled = True
p_SetStatusText SBPANEL_DATABASE, strStatusText
Exit Sub
LErrorHandler:
Select Case Err.Number
Case cdlCancel
' Nothing. The user cancelled.
Case Else
g_ErrorInfo.SetInfoAndDump "p_ExportHHT"
End Select
GoTo LEnd
End Sub
Private Sub p_CreateNode(i_blnGroupNode As Boolean)
On Error GoTo LErrorHandler
Dim DOMNode As MSXML2.IXMLDOMNode
Dim nodeNew As Node
Dim strParentKey As String
Dim intParentTID As Long
Dim enumSelectedSKUs As SKU_E
If (p_blnCreating Or p_blnUpdating) Then
Exit Sub
End If
p_SetModeCreating True
Set DOMNode = treTaxonomy.SelectedItem.Tag
intParentTID = XMLGetAttribute(DOMNode, HHT_tid_C)
strParentKey = KEY_PREFIX_C & intParentTID
Set nodeNew = treTaxonomy.Nodes.Add(strParentKey, tvwChild, CREATE_KEY_C)
Set nodeNew.Tag = DOMNode
If (i_blnGroupNode) Then
nodeNew.Image = IMAGE_GROUP_E
p_EnableSubSite
p_EnableNavModel
p_EnableEditEntry
Else
nodeNew.Image = IMAGE_LEAF_E
p_DisableSubSite
p_DisableNavModel
p_DisableEditEntry
End If
Set treTaxonomy.SelectedItem = nodeNew
nodeNew.EnsureVisible
p_DisableUnselectedSKUs
p_EnableNodeDetailsExceptIndividualSKUs
p_EnableNavigateLink
p_EnableAddRemoveAndKeywordsCombo
chkSubSite.Value = 0
p_SetNavModelCombo NAVMODEL_DEFAULT_STR_C
enumSelectedSKUs = p_GetSelectedSKUs
p_SetSKUs enumSelectedSKUs, enumSelectedSKUs
txtTitle = ""
txtDescription = ""
txtURI = ""
txtIconURI = ""
txtComments = ""
txtEntry = ""
lblLastModified = ""
txtTitle.SetFocus
p_dictKeywordsWithTitle.RemoveAll
p_SetKeywordsList
Exit Sub
LErrorHandler:
g_ErrorInfo.SetInfoAndRaiseError "p_CreateNode"
End Sub
Private Sub p_ReplaceTaxonomySubtree( _
ByVal u_DOMNode As MSXML2.IXMLDOMNode, _
ByVal i_intParentTID As Long, _
ByVal i_enumSKUs As SKU_E, _
ByVal i_blnFastImport As Boolean _
)
Dim DOMNode As MSXML2.IXMLDOMNode
Dim T0 As Date
Dim T1 As Date
T0 = Now
If (u_DOMNode.nodeName = HHT_TAXONOMY_ENTRIES_C) Then
If (Not (u_DOMNode.firstChild Is Nothing)) Then
For Each DOMNode In u_DOMNode.childNodes
p_ReplaceTaxonomySubtree2 DOMNode, i_intParentTID, i_enumSKUs, i_blnFastImport
Next
End If
ElseIf (u_DOMNode.nodeName = HHT_TAXONOMY_ENTRY_C) Then
p_ReplaceTaxonomySubtree2 u_DOMNode, i_intParentTID, i_enumSKUs, i_blnFastImport
End If
T1 = Now
Debug.Print "p_ReplaceTaxonomySubtree: " & FormatTime(T0, T1)
End Sub
Private Sub p_SetTypeSKUsLeafLocIncludeVisibleSubSite( _
ByVal u_DOMNode As MSXML2.IXMLDOMNode, _
ByVal i_enumSKUs As SKU_E, _
ByRef i_strLocInclude As String _
)
Dim DOMNode As MSXML2.IXMLDOMNode
Dim blnHasChildren As Boolean
If (XMLGetAttribute(u_DOMNode, HHT_TYPE_C) = "") Then
XMLSetAttribute u_DOMNode, HHT_TYPE_C, 0
End If
XMLSetAttribute u_DOMNode, HHT_skus_C, i_enumSKUs
If (Not u_DOMNode.firstChild Is Nothing) Then
blnHasChildren = True
End If
If (XMLGetAttribute(u_DOMNode, HHT_leaf_C) = "") Then
XMLSetAttribute u_DOMNode, HHT_leaf_C, IIf(blnHasChildren, False, True)
End If
XMLSetAttribute u_DOMNode, HHT_locinclude_C, i_strLocInclude
If (XMLGetAttribute(u_DOMNode, HHT_VISIBLE_C) = "") Then
XMLSetAttribute u_DOMNode, HHT_VISIBLE_C, CStr(True)
End If
If (XMLGetAttribute(u_DOMNode, HHT_SUBSITE_C) = "") Then
XMLSetAttribute u_DOMNode, HHT_SUBSITE_C, CStr(False)
End If
If (blnHasChildren) Then
For Each DOMNode In u_DOMNode.childNodes
p_SetTypeSKUsLeafLocIncludeVisibleSubSite DOMNode, i_enumSKUs, i_strLocInclude
Next
End If
End Sub
Private Sub p_ReplaceTaxonomySubtree2( _
ByVal u_DOMNode As MSXML2.IXMLDOMNode, _
ByVal i_intParentTID As Long, _
ByVal i_enumSKUs As SKU_E, _
ByVal i_blnFastImport As Boolean _
)
On Error GoTo LErrorHandler
Dim strStatusText As String
Dim NodeParent As Node
Dim strLocInclude As String
Me.MousePointer = vbHourglass
Me.Enabled = False
strStatusText = p_GetStatusText(SBPANEL_DATABASE)
' For some reason, if nodeParent is passed in to p_ReplaceTaxonomySubtree2
' from treTaxonomy_DragDrop, we get the error "The items's control has been
' deleted" after about 20 min of processing. So we pass in the TID instead.
Set NodeParent = treTaxonomy.Nodes(KEY_PREFIX_C & i_intParentTID)
p_SetStatusText SBPANEL_DATABASE, "Creating new Nodes/Topics..."
strLocInclude = XMLGetAttribute(NodeParent.Tag, HHT_locinclude_C)
p_SetTypeSKUsLeafLocIncludeVisibleSubSite u_DOMNode, i_enumSKUs, strLocInclude
p_CreateTaxonomyEntries u_DOMNode, NodeParent, i_blnFastImport
LEnd:
Me.Enabled = True
Me.MousePointer = vbDefault
p_SetStatusText SBPANEL_DATABASE, strStatusText
Exit Sub
LErrorHandler:
g_ErrorInfo.SetInfoAndDump "p_ReplaceTaxonomySubtree2"
GoTo LEnd
End Sub
Private Sub p_SaveClicked( _
ByRef o_blnUpdateControls As Boolean _
)
Dim str As String
Dim intError As Long
Dim bln As Boolean
Dim intTID As Long
If (p_blnUpdating) Then
intTID = XMLGetAttribute(treTaxonomy.Nodes(MODIFY_KEY_C).Tag, HHT_tid_C)
If (intTID = ROOT_TID_C) Then
p_SetModeUpdating False
o_blnUpdateControls = True
Exit Sub
End If
End If
o_blnUpdateControls = False
str = RemoveExtraSpaces(txtTitle)
If (str = "") Then
MsgBox "Title cannot be blank", vbExclamation Or vbOKOnly
txtTitle.SetFocus
Exit Sub
End If
If (p_blnCreating) Then
bln = p_CreateTaxonomy
ElseIf (p_blnUpdating) Then
bln = p_UpdateTaxonomy
End If
o_blnUpdateControls = bln
End Sub
Private Function p_GetAllowedSKUs( _
ByRef i_DOMNodeParent As MSXML2.IXMLDOMNode _
) As SKU_E
p_GetAllowedSKUs = XMLGetAttribute(i_DOMNodeParent, HHT_allowedskus_C) And _
XMLGetAttribute(i_DOMNodeParent, HHT_skus_C)
End Function
Private Function p_CreateTaxonomy() As Boolean
On Error GoTo LErrorHandler
Dim intSelectedSKUs As Long
Dim intParentTID As Long
Dim Node As Node
Dim blnLeaf As Boolean
Dim blnVisible As Boolean
Dim blnSubSite As Boolean
Dim strTitle As String
Dim strDescription As String
Dim strURI As String
Dim strIconURI As String
Dim intTID As Long
Dim intType As Long
Dim intNavModel As Long
Dim strLocInclude As String
Dim strKeywords As String
Dim DOMNodeParent As MSXML2.IXMLDOMNode
Dim DOMNode As MSXML2.IXMLDOMNode
Dim ModifiedDOMNodes As MSXML2.IXMLDOMNode
Dim NodeParent As Node
Dim enumAllowedSKUs As SKU_E
p_CreateTaxonomy = False
Set Node = treTaxonomy.Nodes(CREATE_KEY_C)
Set DOMNodeParent = Node.Tag
intParentTID = XMLGetAttribute(DOMNodeParent, HHT_tid_C)
intSelectedSKUs = p_GetSelectedSKUs
If (p_IsLeaf(Node)) Then
blnLeaf = True
Else
blnLeaf = False
End If
strTitle = RemoveExtraSpaces(txtTitle)
strDescription = RemoveExtraSpaces(txtDescription)
strURI = RemoveExtraSpaces(txtURI)
strIconURI = RemoveExtraSpaces(txtIconURI)
blnVisible = IIf((chkVisible.Value = 0), False, True)
blnSubSite = IIf((chkSubSite.Value = 0), False, True)
intType = p_GetSelectedType
strLocInclude = p_GetSelectedLocInclude
intNavModel = p_GetSelectedNavModel
strKeywords = p_GetKeywords
p_clsTaxonomy.Create strTitle, strDescription, intType, intNavModel, strURI, strIconURI, _
intSelectedSKUs, blnLeaf, intParentTID, strLocInclude, blnVisible, blnSubSite, _
strKeywords, "", txtComments, txtEntry, DOMNodeParent.ownerDocument, DOMNode, _
ModifiedDOMNodes
p_SetModeCreating False
intTID = XMLGetAttribute(DOMNode, HHT_tid_C)
DOMNodeParent.appendChild DOMNode
treTaxonomy.Nodes.Remove CREATE_KEY_C
enumAllowedSKUs = p_GetAllowedSKUs(DOMNodeParent)
Set NodeParent = treTaxonomy.Nodes(KEY_PREFIX_C & intParentTID)
p_CreateTree DOMNode, NodeParent, enumAllowedSKUs
p_CreateTaxonomy = True
p_UpdateTIDs ModifiedDOMNodes
' The UI must show the new keywords that were associated by p_clsTaxonomy.Create
Highlight intTID
LEnd:
Exit Function
LErrorHandler:
Select Case Err.Number
Case errContainsGarbageChar
MsgBox "The Title " & strTitle & _
" or the Description " & strDescription & _
" contains garbage characters", _
vbExclamation + vbOKOnly
Case errTooLong
MsgBox "The Title " & strTitle & " is too long", _
vbExclamation + vbOKOnly
Case E_FAIL
DisplayDatabaseLockedError
Case errDatabaseVersionIncompatible
DisplayDatabaseVersionError
Err.Raise Err.Number
Case errAuthoringGroupNotPresent
DisplayAuthoringGroupError
Case Else
g_ErrorInfo.SetInfoAndRaiseError "p_CreateTaxonomy"
End Select
GoTo LEnd
End Function
Private Sub p_SetKeywords( _
ByRef i_DOMNode As MSXML2.IXMLDOMNode _
)
Dim intTID As Long
Dim strURI As String
Dim DOMNodeNew As MSXML2.IXMLDOMNode
Dim ModifiedDOMNodes As MSXML2.IXMLDOMNode
Dim dtmModifiedTime As Date
intTID = XMLGetAttribute(i_DOMNode, HHT_tid_C)
strURI = XMLGetAttribute(i_DOMNode, HHT_URI_C)
dtmModifiedTime = XMLGetAttribute(i_DOMNode, HHT_modifiedtime_C)
p_clsTaxonomy.SetKeywords intTID, strURI, p_strKeywords, dtmModifiedTime, _
i_DOMNode.ownerDocument, DOMNodeNew, ModifiedDOMNodes
If (Not DOMNodeNew Is Nothing) Then
' If nothing changed, then DOMNodeNew will be Nothing.
XMLCopyAttributes DOMNodeNew, i_DOMNode
End If
If (Not ModifiedDOMNodes Is Nothing) Then
p_UpdateTIDs ModifiedDOMNodes
End If
End Sub
Private Function p_UpdateTaxonomy() As Boolean
On Error GoTo LErrorHandler
Dim intSelectedSKUs As Long
Dim intTID As Long
Dim Node As Node
Dim blnVisible As Boolean
Dim blnSubSite As Boolean
Dim strTitle As String
Dim strDescription As String
Dim strURI As String
Dim strIconURI As String
Dim intType As Long
Dim intNavModel As Long
Dim strLocInclude As String
Dim strKeywords As String
Dim strOriginalKeywords As String
Dim strDeletedKeywords As String
Dim DOMNode As MSXML2.IXMLDOMNode
Dim DOMNodeNew As MSXML2.IXMLDOMNode
Dim ModifiedDOMNodes As MSXML2.IXMLDOMNode
Dim dtmModifiedTime As Date
Dim enumSKUsOld As SKU_E
p_UpdateTaxonomy = False
Set Node = treTaxonomy.Nodes(MODIFY_KEY_C)
Set DOMNode = Node.Tag
intTID = XMLGetAttribute(DOMNode, HHT_tid_C)
intSelectedSKUs = p_GetSelectedSKUs
blnVisible = IIf((chkVisible.Value = 0), False, True)
blnSubSite = IIf((chkSubSite.Value = 0), False, True)
strTitle = RemoveExtraSpaces(txtTitle)
strDescription = RemoveExtraSpaces(txtDescription)
strURI = RemoveExtraSpaces(txtURI)
strIconURI = RemoveExtraSpaces(txtIconURI)
intType = p_GetSelectedType
intNavModel = p_GetSelectedNavModel
strLocInclude = p_GetSelectedLocInclude
strKeywords = p_GetKeywords
strOriginalKeywords = XMLGetAttribute(DOMNode, HHT_keywords_C)
strDeletedKeywords = p_GetDeletedKeywords(strOriginalKeywords, strKeywords)
dtmModifiedTime = XMLGetAttribute(DOMNode, HHT_modifiedtime_C)
p_clsTaxonomy.Update intTID, strTitle, strDescription, intType, intNavModel, strURI, _
strIconURI, intSelectedSKUs, strLocInclude, blnVisible, blnSubSite, strKeywords, _
strDeletedKeywords, txtComments, txtEntry, dtmModifiedTime, _
DOMNode.ownerDocument, DOMNodeNew, ModifiedDOMNodes
enumSKUsOld = XMLGetAttribute(DOMNode, HHT_skus_C)
If (Not DOMNodeNew Is Nothing) Then
' If nothing changed, then DOMNodeNew will be Nothing.
' p_SetModeUpdating will set the title. Make sure that it is correct.
XMLCopyAttributes DOMNodeNew, DOMNode
End If
p_SetModeUpdating False
p_UpdateTaxonomy = True
If (intSelectedSKUs <> enumSKUsOld) Then
p_UpdateSubTree intTID, XMLGetAttribute(DOMNode, HHT_allowedskus_C)
End If
If (Not ModifiedDOMNodes Is Nothing) Then
p_UpdateTIDs ModifiedDOMNodes
End If
p_SetNodeColor Node, DOMNode
' The UI must show the new keywords that were associated by p_clsTaxonomy.Update
Highlight intTID
LEnd:
Exit Function
LErrorHandler:
Select Case Err.Number
Case errContainsGarbageChar
MsgBox "The Title " & strTitle & _
" or the Description " & strDescription & _
" contains garbage characters", _
vbExclamation + vbOKOnly
Case errTooLong
MsgBox "The Title " & strTitle & " is too long", _
vbExclamation + vbOKOnly
Case errNodeOrTopicAlreadyModified
MsgBox "Someone else already modified this entry. " & _
"You need to Cancel your entry, Refresh the database and then " & _
"re-enter your changes. " & _
"This prevents you from accidentally overwriting something " & _
"the other person entered. " & _
"Tip: Before cancelling your changes, copy them to Notepad.", _
vbExclamation + vbOKOnly
Case E_FAIL
DisplayDatabaseLockedError
Case errDatabaseVersionIncompatible
DisplayDatabaseVersionError
Err.Raise Err.Number
Case errNotPermittedForAuthoringGroup, errAuthoringGroupDiffers, errAuthoringGroupNotPresent
DisplayAuthoringGroupError
Case Else
g_ErrorInfo.SetInfoAndRaiseError "p_UpdateTaxonomy"
End Select
GoTo LEnd
End Function
Private Sub p_UpdateTIDs( _
ByRef i_ModifiedDOMNodes As MSXML2.IXMLDOMNode _
)
Dim DOMNodes As MSXML2.IXMLDOMNode
Dim DOMNode As MSXML2.IXMLDOMNode
Dim intTID As Long
Dim intParentTID As Long
Dim intOrderUnderParent As Long
Dim enumSKUs As SKU_E
Dim Node As Node
Dim DOMNodeOld As MSXML2.IXMLDOMNode
Dim intParentTIDOld As Long
Dim intOrderUnderParentOld As Long
Dim enumSKUsOld As SKU_E
Dim blnRefresh As Boolean
Dim strTitle As String
Set DOMNodes = XMLFindFirstNode(i_ModifiedDOMNodes, HHT_TAXONOMY_ENTRIES_C)
If (Not DOMNodes.firstChild Is Nothing) Then
For Each DOMNode In DOMNodes.childNodes
intTID = XMLGetAttribute(DOMNode, HHT_tid_C)
If (Not p_NodeExists(intTID)) Then
GoTo LForEnd
End If
intParentTID = XMLGetAttribute(DOMNode, HHT_parenttid_C)
intOrderUnderParent = XMLGetAttribute(DOMNode, HHT_orderunderparent_C)
enumSKUs = XMLGetAttribute(DOMNode, HHT_skus_C)
Set Node = treTaxonomy.Nodes(KEY_PREFIX_C & intTID)
Set DOMNodeOld = Node.Tag
intParentTIDOld = XMLGetAttribute(DOMNodeOld, HHT_parenttid_C)
intOrderUnderParentOld = XMLGetAttribute(DOMNodeOld, HHT_orderunderparent_C)
enumSKUsOld = XMLGetAttribute(DOMNodeOld, HHT_skus_C)
If ((intParentTID <> intParentTIDOld) Or _
(intOrderUnderParent <> intOrderUnderParentOld)) Then
blnRefresh = True
Exit For
End If
XMLCopyAttributes DOMNode, DOMNodeOld
strTitle = XMLGetAttribute(DOMNode, HHT_TITLE_C)
Node.Text = strTitle
If (enumSKUs <> enumSKUsOld) Then
p_UpdateSubTree intTID, XMLGetAttribute(DOMNode, HHT_allowedskus_C)
End If
LForEnd:
Next
End If
If (blnRefresh) Then
cmdRefresh_Click
End If
End Sub
Private Sub p_CreateTaxonomyEntries( _
ByRef i_DOMNode As MSXML2.IXMLDOMNode, _
ByRef i_nodeParent As Node, _
ByVal i_blnFast As Boolean _
)
On Error GoTo LErrorHandler
Dim intParentTID As Long
Dim DOMNodeParent As MSXML2.IXMLDOMNode
Dim enumAllowedSKUs As SKU_E
Dim DOMDoc As MSXML2.DOMDocument
Dim DOMNode As MSXML2.IXMLDOMNode
If (p_blnCreating Or p_blnUpdating) Then
Exit Sub
End If
Set DOMNodeParent = i_nodeParent.Tag
intParentTID = XMLGetAttribute(DOMNodeParent, HHT_tid_C)
Set DOMDoc = New MSXML2.DOMDocument
Set DOMNode = HhtPreamble(DOMDoc, True)
XMLCopyDOMTree i_DOMNode, DOMNode
Set DOMNode = XMLFindFirstNode(DOMNode, HHT_TAXONOMY_ENTRY_C)
p_clsTaxonomy.CreateTaxonomyEntries DOMNode, intParentTID, i_blnFast
enumAllowedSKUs = p_GetAllowedSKUs(DOMNodeParent)
DOMNodeParent.appendChild DOMNode
p_CreateTree DOMNode, i_nodeParent, enumAllowedSKUs
LEnd:
Exit Sub
LErrorHandler:
Select Case Err.Number
Case E_FAIL
DisplayDatabaseLockedError
Case errDatabaseVersionIncompatible
DisplayDatabaseVersionError
Err.Raise Err.Number
Case errAuthoringGroupNotPresent
DisplayAuthoringGroupError
Case Else
g_ErrorInfo.SetInfoAndRaiseError "p_CreateTaxonomyEntries"
End Select
GoTo LEnd
End Sub
Private Sub p_Move(i_Node As Node, i_nodeRef As Node, i_blnAbove As Boolean)
On Error GoTo LErrorHandler
Dim DOMNode As MSXML2.IXMLDOMNode
Dim DOMNodeRef As MSXML2.IXMLDOMNode
Dim DOMNodeNewParent As MSXML2.IXMLDOMNode
Dim intTID As Long
Dim intRefTID As Long
Dim dtmModifiedTime As Date
Dim intNewParentTID As Long
Dim NodeNewParent As Node
Dim enumAllowedSKUs As SKU_E
Dim intOrderUnderParent As Long
If (p_blnCreating Or p_blnUpdating) Then
Exit Sub
End If
Set DOMNode = i_Node.Tag
Set DOMNodeRef = i_nodeRef.Tag
intTID = XMLGetAttribute(DOMNode, HHT_tid_C)
intRefTID = XMLGetAttribute(DOMNodeRef, HHT_tid_C)
dtmModifiedTime = XMLGetAttribute(DOMNode, HHT_modifiedtime_C)
p_clsTaxonomy.Move intTID, intRefTID, i_blnAbove, dtmModifiedTime, intOrderUnderParent
intNewParentTID = XMLGetAttribute(DOMNodeRef, HHT_parenttid_C)
XMLSetAttribute DOMNode, HHT_modifiedtime_C, Now
XMLSetAttribute DOMNode, HHT_parenttid_C, intNewParentTID
XMLSetAttribute DOMNode, HHT_orderunderparent_C, intOrderUnderParent
Set DOMNodeNewParent = treTaxonomy.Nodes(KEY_PREFIX_C & intNewParentTID).Tag
DOMNode.parentNode.removeChild DOMNode
DOMNodeNewParent.insertBefore DOMNode, DOMNodeRef
treTaxonomy.Nodes.Remove i_Node.Key
enumAllowedSKUs = p_GetAllowedSKUs(DOMNodeNewParent)
p_CreateTree DOMNode, i_nodeRef.Parent, enumAllowedSKUs, _
i_nodeRef, i_blnAbove
treTaxonomy_NodeClick treTaxonomy.SelectedItem
LEnd:
Exit Sub
LErrorHandler:
Select Case Err.Number
Case errRefNodeCannotBeDescendent
MsgBox "A Node cannot move above or below a descendent Node", _
vbExclamation + vbOKOnly
Case errNodeOrTopicAlreadyModified
MsgBox "Someone else already modified this entry. " & _
"You need to Refresh the database and then try again. " & _
"This prevents you from accidentally overwriting something " & _
"the other person entered.", _
vbExclamation + vbOKOnly
Case E_FAIL
DisplayDatabaseLockedError
Case errDatabaseVersionIncompatible
DisplayDatabaseVersionError
Err.Raise Err.Number
Case errNotPermittedForAuthoringGroup, errAuthoringGroupDiffers, errAuthoringGroupNotPresent
DisplayAuthoringGroupError
Case Else
g_ErrorInfo.SetInfoAndRaiseError "p_Move"
End Select
GoTo LEnd
End Sub
Private Sub p_ChangeParent(i_Node As Node, i_nodeParent As Node)
On Error GoTo LErrorHandler
Dim DOMNode As MSXML2.IXMLDOMNode
Dim intTID As Long
Dim intOldParentTID As Long
Dim intNewParentTID As Long
Dim dtmModifiedTime As Date
Dim DOMNodeNewParent As MSXML2.IXMLDOMNode
Dim NodeNewParent As Node
Dim enumAllowedSKUs As SKU_E
Dim intOrderUnderParent As Long
If (p_blnCreating Or p_blnUpdating) Then
Exit Sub
End If
Set DOMNode = i_Node.Tag
Set DOMNodeNewParent = i_nodeParent.Tag
intTID = XMLGetAttribute(DOMNode, HHT_tid_C)
intOldParentTID = XMLGetAttribute(i_Node.Parent.Tag, HHT_tid_C)
intNewParentTID = XMLGetAttribute(DOMNodeNewParent, HHT_tid_C)
dtmModifiedTime = XMLGetAttribute(DOMNode, HHT_modifiedtime_C)
Set NodeNewParent = treTaxonomy.Nodes(KEY_PREFIX_C & intNewParentTID)
If (intOldParentTID = intNewParentTID) Then
Exit Sub
End If
p_clsTaxonomy.MoveInto intTID, intNewParentTID, dtmModifiedTime, intOrderUnderParent
XMLSetAttribute DOMNode, HHT_modifiedtime_C, Now
XMLSetAttribute DOMNode, HHT_parenttid_C, intNewParentTID
XMLSetAttribute DOMNode, HHT_orderunderparent_C, intOrderUnderParent
DOMNode.parentNode.removeChild DOMNode
DOMNodeNewParent.appendChild DOMNode
treTaxonomy.Nodes.Remove i_Node.Key
enumAllowedSKUs = p_GetAllowedSKUs(DOMNodeNewParent)
p_CreateTree DOMNode, NodeNewParent, enumAllowedSKUs
treTaxonomy_NodeClick treTaxonomy.SelectedItem
LEnd:
Exit Sub
LErrorHandler:
Select Case Err.Number
Case errRefNodeCannotBeDescendent
MsgBox "A Node cannot be a child of a descendent Node", _
vbExclamation + vbOKOnly
Case errParentCannotBeLeaf
MsgBox "A Node cannot be a child of a Topic", _
vbExclamation + vbOKOnly
Case errNodeOrTopicAlreadyModified
MsgBox "Someone else already modified this entry. " & _
"You need to Refresh the database and then try again. " & _
"This prevents you from accidentally overwriting something " & _
"the other person entered.", _
vbExclamation + vbOKOnly
Case E_FAIL
DisplayDatabaseLockedError
Case errDatabaseVersionIncompatible
DisplayDatabaseVersionError
Err.Raise Err.Number
Case errNotPermittedForAuthoringGroup, errAuthoringGroupDiffers, errAuthoringGroupNotPresent
DisplayAuthoringGroupError
Case Else
g_ErrorInfo.SetInfoAndRaiseError "p_ChangeParent"
End Select
GoTo LEnd
End Sub
Private Function p_GetKeywords() As String
Dim intKID As Variant
p_GetKeywords = " "
For Each intKID In p_dictKeywordsWithTitle.Keys
p_GetKeywords = p_GetKeywords & intKID & " "
Next
If (p_GetKeywords = " ") Then
p_GetKeywords = ""
End If
End Function
Private Function p_GetDeletedKeywords( _
ByVal strOldKeywords As String, _
ByVal strNewKeywords As String _
) As String
Dim arrOldKIDs() As String
Dim arrNewKIDs() As String
Dim intIndex1 As Long
Dim intIndex2 As Long
Dim blnFound As Boolean
p_GetDeletedKeywords = " "
arrOldKIDs = Split(strOldKeywords, " ")
arrNewKIDs = Split(strNewKeywords, " ")
For intIndex1 = LBound(arrOldKIDs) To UBound(arrOldKIDs)
blnFound = False
intIndex2 = LBound(arrNewKIDs)
Do While (intIndex2 <= UBound(arrNewKIDs))
If (arrOldKIDs(intIndex1) = arrNewKIDs(intIndex2)) Then
blnFound = True
Exit Do
End If
intIndex2 = intIndex2 + 1
Loop
If (Not blnFound) Then
p_GetDeletedKeywords = p_GetDeletedKeywords & arrOldKIDs(intIndex1) & " "
End If
Next
End Function
Private Sub p_UpdateSubTree( _
ByVal i_intTID As Long, _
ByVal i_enumAllowedSKUs As SKU_E _
)
Dim Node As Node
Dim DOMNode As MSXML2.IXMLDOMNode
Dim ChildDOMNode As MSXML2.IXMLDOMNode
Dim enumAllowedSKUs As SKU_E
Dim intTID As Long
Set Node = treTaxonomy.Nodes(KEY_PREFIX_C & i_intTID)
Set DOMNode = Node.Tag
If (i_intTID <> ROOT_TID_C) Then
XMLSetAttribute DOMNode, HHT_allowedskus_C, i_enumAllowedSKUs
p_SetNodeImage Node, DOMNode
p_SetNodeColor Node, DOMNode
enumAllowedSKUs = i_enumAllowedSKUs And XMLGetAttribute(DOMNode, HHT_skus_C)
Else
enumAllowedSKUs = i_enumAllowedSKUs
End If
' Now update the descendents
If (Not DOMNode.firstChild Is Nothing) Then
For Each ChildDOMNode In DOMNode.childNodes
intTID = XMLGetAttribute(ChildDOMNode, HHT_tid_C)
p_UpdateSubTree intTID, enumAllowedSKUs
Next
End If
End Sub
Private Sub p_CreateTree( _
ByRef u_DOMNode As MSXML2.IXMLDOMNode, _
ByRef i_Node As Node, _
ByVal i_enumAllowedSKUs As SKU_E, _
Optional ByRef i_nodeRef As Node = Nothing, _
Optional ByRef i_blnAbove As Boolean _
)
On Error GoTo LErrorHandler
Dim DOMNode As MSXML2.IXMLDOMNode
Dim Node As Node
Dim strTitle As String
Dim strKey As String
Dim enumAllowedSKUs As SKU_E
Dim intRelationship As Long
If (u_DOMNode.nodeName = HHT_TAXONOMY_ENTRY_C) Then
strTitle = XMLGetAttribute(u_DOMNode, HHT_TITLE_C)
strKey = KEY_PREFIX_C & XMLGetAttribute(u_DOMNode, HHT_tid_C)
XMLSetAttribute u_DOMNode, HHT_allowedskus_C, i_enumAllowedSKUs
If (i_Node Is Nothing) Then
Set Node = treTaxonomy.Nodes.Add(Key:=strKey, Text:=strTitle)
Node.Expanded = True
Else
If (i_nodeRef Is Nothing) Then
Set Node = treTaxonomy.Nodes.Add(i_Node, tvwChild, strKey, strTitle)
Else
If (i_blnAbove) Then
intRelationship = tvwPrevious
Else
intRelationship = tvwNext
End If
Set Node = treTaxonomy.Nodes.Add(i_nodeRef.Key, intRelationship, strKey, _
strTitle)
End If
End If
Set Node.Tag = u_DOMNode
p_SetNodeColor Node, u_DOMNode
p_SetNodeImage Node, u_DOMNode
enumAllowedSKUs = i_enumAllowedSKUs And XMLGetAttribute(u_DOMNode, HHT_skus_C)
Else
Set Node = i_Node
enumAllowedSKUs = i_enumAllowedSKUs
End If
If (Not (u_DOMNode.firstChild Is Nothing)) Then
For Each DOMNode In u_DOMNode.childNodes
p_CreateTree DOMNode, Node, enumAllowedSKUs
Next
End If
LEnd:
Exit Sub
LErrorHandler:
g_ErrorInfo.SetInfoAndRaiseError "p_CreateTree"
GoTo LEnd
End Sub
Private Sub p_InitializeDataStructures( _
ByRef o_DOMNode As MSXML2.IXMLDOMNode _
)
' Put a Me.Enabled = True in the error handler that will handle errors
' that happen here.
Dim T0 As Date
Dim T1 As Date
Dim DOMDoc As MSXML2.DOMDocument
Me.Enabled = False
T0 = Now
Set p_colKeywords = New Collection
p_SetStatusText SBPANEL_DATABASE, "Reading Keywords from Database..."
p_clsKeywords.GetAllKeywordsColl p_colKeywords
p_SetStatusText SBPANEL_DATABASE, "Reading Taxonomy from Database..."
Set DOMDoc = p_clsTaxonomy.GetTaxonomyInXml
p_SetStatusText SBPANEL_DATABASE, ""
Set o_DOMNode = XMLFindFirstNode(DOMDoc, HHT_TAXONOMY_ENTRY_C)
T1 = Now
Debug.Print "p_InitializeDataStructures: " & FormatTime(T0, T1)
Me.Enabled = True
End Sub
Private Sub p_Refresh( _
ByRef i_DOMNode As MSXML2.IXMLDOMNode _
)
' Put a Me.Enabled = True in the error handler that will handle errors
' that happen here.
Dim T0 As Date
Dim T1 As Date
Me.Enabled = False
T0 = Now
If (p_blnCreating Or p_blnUpdating) Then
Exit Sub
End If
p_ClearTreeView
p_ClearNodeDetails
p_DisableEditPaste
p_DisableEditPasteKeywords
p_InitializeTypeCombo
p_EnableTaxonomyAndSomeMenus
p_EnableRefresh
p_EnableNodeDetailsExceptIndividualSKUs
p_SetStatusText SBPANEL_DATABASE, "Creating Taxonomy tree..."
p_CreateTree i_DOMNode, Nothing, ALL_SKUS_C
p_SetStatusText SBPANEL_DATABASE, ""
T1 = Now
Debug.Print "p_Refresh: " & FormatTime(T0, T1)
Me.Enabled = True
End Sub
Private Sub p_SetKeywordsList()
On Error GoTo LErrorHandler
Dim intKID As Variant
cboKeywords.Clear
For Each intKID In p_dictKeywordsWithTitle
cboKeywords.AddItem p_colKeywords(CStr(intKID))
Next
Exit Sub
LErrorHandler:
g_ErrorInfo.SetInfoAndRaiseError "p_SetKeywordsList"
End Sub
Private Function p_GetStatusText(i_enumPanel As STATUS_BAR_PANEL_E) As String
p_GetStatusText = staInfo.Panels(i_enumPanel).Text
End Function
Private Sub p_SetStatusText(i_enumPanel As STATUS_BAR_PANEL_E, i_strText As String)
staInfo.Panels(i_enumPanel).Text = i_strText
End Sub
Private Sub p_SetNavModelCombo(i_strNavModel As String)
Dim strNavModel As String
Dim intIndex As Long
If (i_strNavModel = "") Then
strNavModel = NAVMODEL_DEFAULT_STR_C
Else
strNavModel = i_strNavModel
End If
For intIndex = 0 To cboNavModel.ListCount - 1
If (cboNavModel.List(intIndex) = strNavModel) Then
cboNavModel.ListIndex = intIndex
Exit For
End If
Next
End Sub
Private Sub p_InitializeNavModelCombo()
cboNavModel.Clear
cboNavModel.AddItem NAVMODEL_DEFAULT_STR_C
cboNavModel.ItemData(cboNavModel.NewIndex) = NAVMODEL_DEFAULT_NUM_C
cboNavModel.AddItem NAVMODEL_SERVER_STR_C
cboNavModel.ItemData(cboNavModel.NewIndex) = NAVMODEL_SERVER_NUM_C
cboNavModel.AddItem NAVMODEL_DESKTOP_STR_C
cboNavModel.ItemData(cboNavModel.NewIndex) = NAVMODEL_DESKTOP_NUM_C
End Sub
Private Sub p_SetLocIncludeCombo(i_strLocInclude As String)
Dim intIndex As Long
Dim blnExistingLocInclude As Boolean
p_InitializeLocIncludeCombo
For intIndex = LBound(LocIncludes) To UBound(LocIncludes)
If (i_strLocInclude = LocIncludes(intIndex)) Then
blnExistingLocInclude = True
End If
Next
If (Not blnExistingLocInclude) Then
cboLocInclude.AddItem i_strLocInclude, UBound(LocIncludes) + 1
End If
cboLocInclude.Text = i_strLocInclude
End Sub
Private Sub p_InitializeLocIncludeCombo()
Dim intIndex As Long
InitializeLocIncludes
cboLocInclude.Clear
For intIndex = LBound(LocIncludes) To UBound(LocIncludes)
cboLocInclude.AddItem LocIncludes(intIndex), intIndex
Next
End Sub
Private Sub p_SetTypeComboIndex(i_intIndex As Long)
cboType.ListIndex = i_intIndex
End Sub
Private Sub p_InitializeTypeCombo()
On Error GoTo LErrorHandler
Dim arrTypes() As Variant
Dim intIndex As Long
' Initialize the Types Combo Box
arrTypes = p_clsTaxonomy.GetTypes
cboType.Clear
For intIndex = 0 To UBound(arrTypes)
cboType.AddItem arrTypes(intIndex)(1), intIndex
cboType.ItemData(cboType.NewIndex) = arrTypes(intIndex)(0)
Next
Exit Sub
LErrorHandler:
Select Case Err.Number
Case errDatabaseVersionIncompatible
DisplayDatabaseVersionError
Err.Raise Err.Number
Case Else
g_ErrorInfo.SetInfoAndRaiseError "p_InitializeTypeCombo"
End Select
End Sub
Private Function p_GetBrokenLinkDir( _
ByVal i_enumSKU As SKU_E _
) As String
p_GetBrokenLinkDir = p_clsParameters.Value(BROKEN_LINK_WORKING_DIR_C & Hex(i_enumSKU)) & ""
If (p_GetBrokenLinkDir = "") Then
Err.Raise errNotConfiguredForNavigateLink
End If
End Function
Private Sub p_InitializeTaxonomyTree()
Dim nodeNew As Node
Set treTaxonomy.ImageList = ilsIcons
treTaxonomy.HideSelection = False
treTaxonomy.LabelEdit = tvwManual
' The problem with FullRowSelect is that if you click on the far right side of
' a row, it will be highlighted, but NodeClick will not be called.
' treTaxonomy.FullRowSelect = True
End Sub
Private Sub p_ClearTreeView()
' Remove the root. Does garbage collection caused the other nodes to be removed?
If (treTaxonomy.Nodes.Count > 0) Then
treTaxonomy.Nodes.Remove 1
End If
End Sub
Private Sub p_EnableTaxonomyAndSomeMenus()
mnuEdit.Enabled = True
mnuTools.Enabled = True
mnuFileExportHHT.Enabled = True
mnuFileImportHHT.Enabled = True
lblTaxonomy.Enabled = True
treTaxonomy.Enabled = True
End Sub
Private Sub p_DisableTaxonomyAndSomeMenus()
mnuEdit.Enabled = False
mnuTools.Enabled = False
mnuFileExportHHT.Enabled = False
mnuFileImportHHT.Enabled = False
lblTaxonomy.Enabled = False
treTaxonomy.Enabled = False
End Sub
Private Sub p_EnableCreate()
cmdCreateGroup.Enabled = True
cmdCreateLeaf.Enabled = True
mnuRightClickCreateNode.Enabled = True
mnuRightClickCreateTopic.Enabled = True
End Sub
Private Sub p_DisableCreate()
cmdCreateGroup.Enabled = False
cmdCreateLeaf.Enabled = False
mnuRightClickCreateNode.Enabled = False
mnuRightClickCreateTopic.Enabled = False
End Sub
Private Sub p_EnableDelete()
cmdDelete.Enabled = True
mnuRightClickDelete.Enabled = True
End Sub
Private Sub p_DisableDelete()
cmdDelete.Enabled = False
mnuRightClickDelete.Enabled = False
End Sub
Private Sub p_EnableRefresh()
cmdRefresh.Enabled = True
End Sub
Private Sub p_DisableRefresh()
cmdRefresh.Enabled = False
End Sub
Private Sub p_EnableNavModel()
lblNavModel.Enabled = True
cboNavModel.Enabled = True
End Sub
Private Sub p_DisableNavModel()
lblNavModel.Enabled = False
cboNavModel.Enabled = False
End Sub
Private Sub p_EnableSubSite()
chkSubSite.Enabled = True
End Sub
Private Sub p_DisableSubSite()
chkSubSite.Enabled = False
End Sub
Private Sub p_EnableEditEntry()
cmdEditEntry.Enabled = True
End Sub
Private Sub p_DisableEditEntry()
cmdEditEntry.Enabled = False
End Sub
Private Sub p_EnableEntry()
txtEntry.Locked = False
End Sub
Private Sub p_DisableEntry()
txtEntry.Locked = True
End Sub
Private Sub p_EnableNodeDetailsExceptIndividualSKUs()
chkVisible.Enabled = True
lblLocInclude.Enabled = True
cboLocInclude.Enabled = True
lblTitle.Enabled = True
lblDescription.Enabled = True
lblURI.Enabled = True
cmdURI.Enabled = True
lblIconURI.Enabled = True
lblType.Enabled = True
lblComments.Enabled = True
lblEntry.Enabled = True
txtTitle.Locked = False
txtDescription.Locked = False
txtURI.Locked = False
txtIconURI.Locked = False
cboType.Enabled = True
txtComments.Locked = False
fraSKU.Enabled = True
lblKeywords.Enabled = True
cboKeywords.Enabled = True
lblLastModified.Enabled = True
End Sub
Private Sub p_DisableNodeDetails()
chkVisible.Enabled = False
lblLocInclude.Enabled = False
cboLocInclude.Enabled = False
chkSubSite.Enabled = False
p_DisableNavModel
lblTitle.Enabled = False
lblDescription.Enabled = False
lblURI.Enabled = False
cmdURI.Enabled = False
lblIconURI.Enabled = False
lblType.Enabled = False
lblComments.Enabled = False
lblEntry.Enabled = False
p_DisableEditEntry
txtTitle.Locked = True
txtDescription.Locked = True
txtURI.Locked = True
txtIconURI.Locked = True
cboType.Enabled = False
txtComments.Locked = True
p_DisableEntry
chkVisible.Enabled = False
fraSKU.Enabled = False
p_DisableSKUs
lblKeywords.Enabled = False
cboKeywords.Enabled = False
lblLastModified.Enabled = False
p_DisableAddRemoveAndKeywordsCombo
p_DisableNavigateLink
End Sub
Private Sub p_EnableNavigateLink()
lblNavigateLink.Enabled = True
cboNavigateLink.Enabled = True
cmdNavigateLink.Enabled = True
End Sub
Private Sub p_DisableNavigateLink()
lblNavigateLink.Enabled = False
cboNavigateLink.Enabled = False
cmdNavigateLink.Enabled = False
End Sub
Private Sub p_EnableAddRemoveAndKeywordsCombo()
cmdAddRemove.Enabled = True
cboKeywords.Enabled = True
End Sub
Private Sub p_DisableAddRemoveAndKeywordsCombo()
cmdAddRemove.Enabled = False
cboKeywords.Enabled = False
End Sub
Private Sub p_ClearNodeDetails()
Dim blnSettingControls As Boolean
blnSettingControls = p_blnSettingControls
p_blnSettingControls = True
txtTitle = ""
txtDescription = ""
txtURI = ""
txtIconURI = ""
txtComments = ""
txtEntry = ""
lblLastModified = ""
p_SetTypeComboIndex -1
chkVisible.Value = 0
chkSubSite.Value = 0
p_SetNavModelCombo NAVMODEL_DEFAULT_NUM_C
p_ClearSKUs
cboKeywords.Clear
' Reset it to the state it was in when this function was called.
p_blnSettingControls = blnSettingControls
End Sub
Private Sub p_EnableSKUs()
chkStandard.Enabled = True
chkProfessional.Enabled = True
chkProfessional64.Enabled = True
chkWindowsMillennium.Enabled = True
chkServer.Enabled = True
chkAdvancedServer.Enabled = True
chkDataCenterServer.Enabled = True
chkAdvancedServer64.Enabled = True
chkDataCenterServer64.Enabled = True
End Sub
Private Sub p_DisableSKUs()
chkStandard.Enabled = False
chkProfessional.Enabled = False
chkProfessional64.Enabled = False
chkWindowsMillennium.Enabled = False
chkServer.Enabled = False
chkAdvancedServer.Enabled = False
chkDataCenterServer.Enabled = False
chkAdvancedServer64.Enabled = False
chkDataCenterServer64.Enabled = False
End Sub
Private Sub p_ClearSKUs()
chkStandard.Value = 0
chkProfessional.Value = 0
chkProfessional64.Value = 0
chkWindowsMillennium.Value = 0
chkServer.Value = 0
chkAdvancedServer.Value = 0
chkDataCenterServer.Value = 0
chkAdvancedServer64.Value = 0
chkDataCenterServer64.Value = 0
End Sub
Private Sub p_StrikeoutUnselectedSKUs()
chkStandard.Font.Strikethrough = _
IIf((p_enumFilterSKUs And SKU_STANDARD_E), False, True)
chkProfessional.Font.Strikethrough = _
IIf((p_enumFilterSKUs And SKU_PROFESSIONAL_E), False, True)
chkProfessional64.Font.Strikethrough = _
IIf((p_enumFilterSKUs And SKU_PROFESSIONAL_64_E), False, True)
chkWindowsMillennium.Font.Strikethrough = _
IIf((p_enumFilterSKUs And SKU_WINDOWS_MILLENNIUM_E), False, True)
chkServer.Font.Strikethrough = _
IIf((p_enumFilterSKUs And SKU_SERVER_E), False, True)
chkAdvancedServer.Font.Strikethrough = _
IIf((p_enumFilterSKUs And SKU_ADVANCED_SERVER_E), False, True)
chkDataCenterServer.Font.Strikethrough = _
IIf((p_enumFilterSKUs And SKU_DATA_CENTER_SERVER_E), False, True)
chkAdvancedServer64.Font.Strikethrough = _
IIf((p_enumFilterSKUs And SKU_ADVANCED_SERVER_64_E), False, True)
chkDataCenterServer64.Font.Strikethrough = _
IIf((p_enumFilterSKUs And SKU_DATA_CENTER_SERVER_64_E), False, True)
End Sub
Private Sub p_DisableUnselectedSKUs()
If (chkStandard.Value = 0) Then
chkStandard.Enabled = False
End If
If (chkProfessional.Value = 0) Then
chkProfessional.Enabled = False
End If
If (chkProfessional64.Value = 0) Then
chkProfessional64.Enabled = False
End If
If (chkWindowsMillennium.Value = 0) Then
chkWindowsMillennium.Enabled = False
End If
If (chkServer.Value = 0) Then
chkServer.Enabled = False
End If
If (chkAdvancedServer.Value = 0) Then
chkAdvancedServer.Enabled = False
End If
If (chkDataCenterServer.Value = 0) Then
chkDataCenterServer.Enabled = False
End If
If (chkAdvancedServer64.Value = 0) Then
chkAdvancedServer64.Enabled = False
End If
If (chkDataCenterServer64.Value = 0) Then
chkDataCenterServer64.Enabled = False
End If
End Sub
Private Sub p_EnableSaveCancel()
cmdSave.Enabled = True
cmdCancel.Enabled = True
cmdCancel.Cancel = True
End Sub
Private Sub p_DisableSaveCancel()
cmdSave.Enabled = False
cmdCancel.Enabled = False
cmdCancel.Cancel = False
End Sub
Private Sub p_EnableEditCopy()
mnuEditCopy.Enabled = True
mnuRightClickCopy.Enabled = True
End Sub
Private Sub p_DisableEditCopy()
mnuEditCopy.Enabled = False
mnuRightClickCopy.Enabled = False
End Sub
Private Sub p_EnableEditCut()
mnuEditCut.Enabled = True
mnuRightClickCut.Enabled = True
End Sub
Private Sub p_DisableEditCut()
mnuEditCut.Enabled = False
mnuRightClickCut.Enabled = False
End Sub
Private Sub p_EnableEditPaste()
mnuEditPaste.Enabled = True
mnuRightClickPaste.Enabled = True
End Sub
Private Sub p_DisableEditPaste()
mnuEditPaste.Enabled = False
mnuRightClickPaste.Enabled = False
End Sub
Private Sub p_EnableEditPasteKeywords()
mnuEditPasteKeywords.Enabled = True
mnuRightClickPasteKeywords.Enabled = True
p_AddCheckboxesToTree
End Sub
Private Sub p_DisableEditPasteKeywords()
mnuEditPasteKeywords.Enabled = False
mnuRightClickPasteKeywords.Enabled = False
p_RemoveCheckboxesFromTree
End Sub
Private Sub p_DisableEverything()
p_DisableTaxonomyAndSomeMenus
p_DisableCreate
p_DisableDelete
p_DisableRefresh
p_DisableNodeDetails
p_DisableAddRemoveAndKeywordsCombo
p_DisableNavigateLink
p_DisableSaveCancel
End Sub
Private Sub p_AddCheckboxesToTree()
treTaxonomy.Checkboxes = True
End Sub
Private Sub p_RemoveCheckboxesFromTree()
treTaxonomy.Checkboxes = False
End Sub
Private Sub p_SetTitle( _
ByVal i_strDatabase As String _
)
frmMain.Caption = "Production Tool (" & i_strDatabase & ")"
End Sub
Private Sub p_SetSizingInfo()
Static blnInfoSet As Boolean
If (blnInfoSet) Then
Exit Sub
End If
p_clsSizer.AddControl treTaxonomy
Set p_clsSizer.ReferenceControl(DIM_HEIGHT_E) = frmMain
Set p_clsSizer.ReferenceControl(DIM_WIDTH_E) = frmMain
p_clsSizer.Operation(DIM_WIDTH_E) = OP_MULTIPLY_E
p_clsSizer.AddControl cmdCreateGroup
Set p_clsSizer.ReferenceControl(DIM_TOP_E) = treTaxonomy
p_clsSizer.ReferenceDimension(DIM_TOP_E) = DIM_BOTTOM_E
p_clsSizer.AddControl cmdCreateLeaf
Set p_clsSizer.ReferenceControl(DIM_TOP_E) = cmdCreateGroup
p_clsSizer.AddControl cmdDelete
Set p_clsSizer.ReferenceControl(DIM_TOP_E) = cmdCreateGroup
p_clsSizer.AddControl cmdRefresh
Set p_clsSizer.ReferenceControl(DIM_TOP_E) = cmdCreateGroup
p_clsSizer.AddControl lblLocInclude
Set p_clsSizer.ReferenceControl(DIM_LEFT_E) = frmMain
p_clsSizer.ReferenceDimension(DIM_LEFT_E) = DIM_WIDTH_E
p_clsSizer.AddControl cboLocInclude
Set p_clsSizer.ReferenceControl(DIM_LEFT_E) = lblLocInclude
p_clsSizer.AddControl lblTitle
Set p_clsSizer.ReferenceControl(DIM_LEFT_E) = treTaxonomy
p_clsSizer.ReferenceDimension(DIM_LEFT_E) = DIM_RIGHT_E
p_clsSizer.AddControl txtTitle
Set p_clsSizer.ReferenceControl(DIM_LEFT_E) = lblTitle
Set p_clsSizer.ReferenceControl(DIM_RIGHT_E) = frmMain
p_clsSizer.ReferenceDimension(DIM_RIGHT_E) = DIM_WIDTH_E
p_clsSizer.AddControl chkVisible
Set p_clsSizer.ReferenceControl(DIM_LEFT_E) = txtTitle
p_clsSizer.AddControl chkSubSite
Set p_clsSizer.ReferenceControl(DIM_LEFT_E) = txtTitle
p_clsSizer.AddControl lblNavModel
Set p_clsSizer.ReferenceControl(DIM_LEFT_E) = txtTitle
p_clsSizer.AddControl cboNavModel
Set p_clsSizer.ReferenceControl(DIM_LEFT_E) = txtTitle
p_clsSizer.AddControl lblDescription
Set p_clsSizer.ReferenceControl(DIM_LEFT_E) = txtTitle
p_clsSizer.AddControl txtDescription
Set p_clsSizer.ReferenceControl(DIM_LEFT_E) = txtTitle
Set p_clsSizer.ReferenceControl(DIM_RIGHT_E) = txtTitle
p_clsSizer.AddControl lblType
Set p_clsSizer.ReferenceControl(DIM_LEFT_E) = txtTitle
p_clsSizer.AddControl cboType
Set p_clsSizer.ReferenceControl(DIM_LEFT_E) = txtTitle
Set p_clsSizer.ReferenceControl(DIM_RIGHT_E) = txtTitle
p_clsSizer.AddControl lblURI
Set p_clsSizer.ReferenceControl(DIM_LEFT_E) = txtTitle
p_clsSizer.AddControl txtURI
Set p_clsSizer.ReferenceControl(DIM_LEFT_E) = txtTitle
Set p_clsSizer.ReferenceControl(DIM_RIGHT_E) = txtTitle
p_clsSizer.AddControl cmdURI
Set p_clsSizer.ReferenceControl(DIM_LEFT_E) = txtTitle
p_clsSizer.ReferenceDimension(DIM_LEFT_E) = DIM_RIGHT_E
p_clsSizer.AddControl lblIconURI
Set p_clsSizer.ReferenceControl(DIM_LEFT_E) = txtTitle
p_clsSizer.AddControl txtIconURI
Set p_clsSizer.ReferenceControl(DIM_LEFT_E) = txtTitle
Set p_clsSizer.ReferenceControl(DIM_RIGHT_E) = txtTitle
p_clsSizer.AddControl lblComments
Set p_clsSizer.ReferenceControl(DIM_LEFT_E) = txtTitle
p_clsSizer.AddControl txtComments
Set p_clsSizer.ReferenceControl(DIM_LEFT_E) = txtTitle
Set p_clsSizer.ReferenceControl(DIM_RIGHT_E) = txtTitle
p_clsSizer.AddControl lblEntry
Set p_clsSizer.ReferenceControl(DIM_LEFT_E) = txtTitle
p_clsSizer.AddControl txtEntry
Set p_clsSizer.ReferenceControl(DIM_LEFT_E) = txtTitle
Set p_clsSizer.ReferenceControl(DIM_RIGHT_E) = txtTitle
p_clsSizer.AddControl cmdEditEntry
Set p_clsSizer.ReferenceControl(DIM_LEFT_E) = txtTitle
p_clsSizer.ReferenceDimension(DIM_LEFT_E) = DIM_RIGHT_E
p_clsSizer.AddControl lblNavigateLink
Set p_clsSizer.ReferenceControl(DIM_LEFT_E) = txtTitle
p_clsSizer.AddControl cboNavigateLink
Set p_clsSizer.ReferenceControl(DIM_LEFT_E) = txtTitle
Set p_clsSizer.ReferenceControl(DIM_RIGHT_E) = frmMain
p_clsSizer.ReferenceDimension(DIM_RIGHT_E) = DIM_WIDTH_E
p_clsSizer.AddControl cmdNavigateLink
Set p_clsSizer.ReferenceControl(DIM_LEFT_E) = txtTitle
p_clsSizer.ReferenceDimension(DIM_LEFT_E) = DIM_RIGHT_E
p_clsSizer.AddControl fraSKU
Set p_clsSizer.ReferenceControl(DIM_LEFT_E) = txtTitle
Set p_clsSizer.ReferenceControl(DIM_RIGHT_E) = txtTitle
p_clsSizer.AddControl chkServer
Set p_clsSizer.ReferenceControl(DIM_LEFT_E) = fraSKU
p_clsSizer.ReferenceDimension(DIM_LEFT_E) = DIM_WIDTH_E
p_clsSizer.Operation(DIM_LEFT_E) = OP_MULTIPLY_E
p_clsSizer.AddControl chkAdvancedServer
Set p_clsSizer.ReferenceControl(DIM_LEFT_E) = chkServer
p_clsSizer.AddControl chkDataCenterServer
Set p_clsSizer.ReferenceControl(DIM_LEFT_E) = chkServer
p_clsSizer.AddControl chkAdvancedServer64
Set p_clsSizer.ReferenceControl(DIM_LEFT_E) = chkServer
p_clsSizer.AddControl chkDataCenterServer64
Set p_clsSizer.ReferenceControl(DIM_LEFT_E) = chkServer
p_clsSizer.AddControl lblKeywords
Set p_clsSizer.ReferenceControl(DIM_LEFT_E) = txtTitle
p_clsSizer.AddControl cmdAddRemove
Set p_clsSizer.ReferenceControl(DIM_LEFT_E) = txtTitle
p_clsSizer.ReferenceDimension(DIM_LEFT_E) = DIM_RIGHT_E
p_clsSizer.AddControl cboKeywords
Set p_clsSizer.ReferenceControl(DIM_LEFT_E) = txtTitle
Set p_clsSizer.ReferenceControl(DIM_RIGHT_E) = txtTitle
Set p_clsSizer.ReferenceControl(DIM_HEIGHT_E) = frmMain
p_clsSizer.AddControl cmdSave
Set p_clsSizer.ReferenceControl(DIM_TOP_E) = cmdCreateGroup
Set p_clsSizer.ReferenceControl(DIM_LEFT_E) = frmMain
p_clsSizer.ReferenceDimension(DIM_LEFT_E) = DIM_WIDTH_E
p_clsSizer.AddControl cmdCancel
Set p_clsSizer.ReferenceControl(DIM_TOP_E) = cmdCreateGroup
Set p_clsSizer.ReferenceControl(DIM_LEFT_E) = cmdSave
p_clsSizer.AddControl lblLastModified
Set p_clsSizer.ReferenceControl(DIM_TOP_E) = cmdCreateGroup
Set p_clsSizer.ReferenceControl(DIM_LEFT_E) = cmdCreateGroup
Set p_clsSizer.ReferenceControl(DIM_RIGHT_E) = cmdSave
blnInfoSet = True
End Sub
Private Sub p_SetToolTips()
chkVisible.ToolTipText = "Controls whether the user can navigate to the Node/Topic using the Taxonomy."
chkSubSite.ToolTipText = "Indicates whether this node is a subsite, or appears on the flyout menu."
lblNavModel.ToolTipText = "Determines which navigation model will be used for the node."
cboNavModel.ToolTipText = lblNavModel.ToolTipText
lblLocInclude.ToolTipText = "Indicates localization preferences for the topic."
cboLocInclude.ToolTipText = lblLocInclude.ToolTipText
lblTitle.ToolTipText = "The title as it will appear in the taxonomy tree."
txtTitle.ToolTipText = lblTitle.ToolTipText
lblDescription.ToolTipText = "A description of the node or topic."
txtDescription.ToolTipText = lblDescription.ToolTipText
lblType.ToolTipText = "The category of the title, to be used for search categories."
cboType.ToolTipText = lblType.ToolTipText
lblURI.ToolTipText = "Uniform Resource Indicator. This is the address of the file."
txtURI.ToolTipText = lblURI.ToolTipText
lblIconURI.ToolTipText = "The path to the icon that is displayed in the Desktop navigation model."
txtIconURI.ToolTipText = lblIconURI.ToolTipText
lblComments.ToolTipText = "Additional comment about the node or topic."
txtComments.ToolTipText = lblComments.ToolTipText
lblEntry.ToolTipText = "Used by other files to link to this topic. It is not recommended that this field be changed after it has been set."
txtEntry.ToolTipText = lblEntry.ToolTipText
lblNavigateLink.ToolTipText = "Select a valid SKU to view the content of the selected topic."
cboNavigateLink.ToolTipText = lblNavigateLink.ToolTipText
fraSKU.ToolTipText = "Select which platforms this node or topic applies to. " & _
"Child nodes or topics will inherit only the boxes checked for the parent " & _
"node or topic."
cboKeywords.ToolTipText = "These are the keywords associated with selected node."
End Sub
Reference in a new issue View git blame Copy permalink