Attribute VB_Name = "mdlLayerManager"
Public strDataPath, strLineTypePath As String 'Store Global Variable for Layer Data file used to create the new layers
Public blnOWrite As Integer 'Overwrite settings for layers
Public strLayerArray(), strColorArray(), strLineTypeArray() As Variant
Public ThisDrawing As IntelliCAD.Document 'Sets the global variable for IntelliCAD document object (not needed in VBA for IntelliCAD)
Public Sub Main() 'Main Macro to be run from Application
Dim StartTime, EndTime
frmSplash.Visible = True
frmSplash.Refresh
Call GetAppIcad 'Calls IntelliCAD 2000
frmSplash.Refresh
Call ConfigurationSettings 'Configures the App
frmSplash.Refresh
Call InitializeComboBox 'Initilizes the ComboBox
frmSplash.Refresh
Call InitExportLayerList 'Loads Layer list from the current drawing
frmSplash.Refresh
Call MakeList 'Makes a list in the Layer ListBox
'Shows the Splash Screen for 1 second
StartTime = VBA.Timer
EndTime = VBA.Timer
Do Until (0.75 + StartTime) <= EndTime
EndTime = VBA.Timer
Loop
frmSplash.Visible = False
frmMain.Show
End Sub
Public Sub ExportLayerInfo()
Dim intCounter, intFileNum As Integer
Dim strGroupName As String
Dim Layer As IntelliCAD.Layer
intFileNum = FreeFile
intCounter = 0
Set AllLayers = ThisDrawing.Layers
'Checks to see if information is entered
If frmMain.txtGroupName.Text = "" Then
MsgBox "Enter A Group Name"
frmMain.txtGroupName.SetFocus
Exit Sub
End If
'Sets up and shows the Save Dialog Box
frmMain.cdbDialog.DialogTitle = "Open File"
frmMain.cdbDialog.Filter = "Layer Data File *.lmd|*.lmd"
frmMain.cdbDialog.FileName = strDataPath
On Error Resume Next
frmMain.cdbDialog.ShowSave
If Err = 0 Then
  strExportDataPath = frmMain.cdbDialog.FileName
  'Else
 'GoTo LastLine
End If
Open strExportDataPath For Append As intFileNum 'open the file to be appended to
strGroupName = frmMain.txtGroupName.Text
Print #intFileNum, "[" & strGroupName & "]" 'Writes the group name to the file
'Creates the Layer data from the selected items on the ListBox
Do Until intCounter = frmMain.lstExportLayers.ListCount
If frmMain.lstExportLayers.Selected(intCounter) Then 'Validates selected Items
    For Each Layer In AllLayers
        If frmMain.lstExportLayers.List(intCounter) = Layer.Name Then
            Print #intFileNum, Layer.Name & ",", , Layer.Color & ",", Layer.Linetype
        End If
    Next
End If
intCounter = intCounter + 1
Loop
Close intFileNum
frmMain.txtGroupName.Text = "" 'Clears the TextBox
Call SelectlstExport(False) 'Clears the List box selection
Call InitializeComboBox 'Updates the ComboBox
End Sub
Public Sub InitializeComboBox()
Dim intFileNum, intCounter As Integer
Dim strTmpLine, strRightBracket As String
intFileNum = FreeFile
intCounter = 0
frmMain.cmbLayerTypes.Clear 'Resets the ComboBox
'Opens layer data file for ComboBox
Open strDataPath For Input As intFileNum
Do Until EOF(intFileNum)
    Input #intFileNum, strTmpLine
    If VBA.Left(strTmpLine, 1) = "[" And Len(Trim(strTmpLine)) > 0 Then
        strRightBracket = InStr(strTmpLine, "]")
        strTmpLine = Mid(strTmpLine, 2, (strRightBracket - 2))
        frmMain.cmbLayerTypes.AddItem strTmpLine
        intCounter = (intCounter + 1)
    End If
Loop
Close intFileNum
frmMain.cmbLayerTypes.ListIndex = 0
End Sub
Public Sub ImportLayerInfo()
Dim strRightBracket, strTmpLine As String
Dim intFileNum As Integer
intFileNum = FreeFile
'Sets up and shows the Open Dialog Box
frmMain.cdbDialog.DialogTitle = "Open File"
frmMain.cdbDialog.Filter = "Layer Data File *.lmd|*.lmd"
frmMain.cdbDialog.FileName = strDataPath
On Error Resume Next
frmMain.cdbDialog.ShowOpen
If Err = 0 Then
  strDataPath = frmMain.cdbDialog.FileName
End If
frmMain.cmbLayerTypes.Clear
'Opens the user selected file and updates the Layer List
Open strDataPath For Input As intFileNum
Do Until EOF(intFileNum)
    Input #intFileNum, strTmpLine
    If VBA.Left(strTmpLine, 1) = "[" And Len(Trim(strTmpLine)) > 0 Then
        strRightBracket = InStr(strTmpLine, "]")
        strTmpLine = Mid(strTmpLine, 2, (strRightBracket - 2))
        frmMain.cmbLayerTypes.AddItem strTmpLine

    End If
Loop
Close intFileNum
frmMain.cmbLayerTypes.ListIndex = 0
frmMain.lblDataPath.Caption = strDataPath
End Sub
Public Sub ConfigurationSettings()
'The configuration settings are:
'Layer Creation Data file As String
'LineType File As String
'Overwrite the Current Layers As Boolean
Dim intFileNum As Integer
Dim strFileName, IcadAppPath, strResponse As String
intFileNum = FreeFile
blnOWrite = False
On Error Resume Next
IcadAppPath = IntelliCAD.Application.Path
'Opens the configuration file
Open App.Path & "\LayerManager.cfg" For Input As intFileNum
If Err <> 0 Then 'If it doesn't exist then it prompts user for layer data file location
    frmMain.cdbDialog.DialogTitle = "Select Layer Data File"
    frmMain.cdbDialog.Filter = "Layer Data File *.lmd|*.lmd"
    frmMain.cdbDialog.FileName = App.Path & "\*.lmd"
    frmMain.cdbDialog.ShowOpen
    strDataPath = frmMain.cdbDialog.FileName
        'Then it prompts user for layer data file location
    frmMain.cdbDialog.DialogTitle = "Select Linetype File"
    frmMain.cdbDialog.Filter = "Linetype File *.lin|*.lin"
    frmMain.cdbDialog.FileName = IcadAppPath & "\*.lin"
    frmMain.cdbDialog.ShowOpen
    strLineTypePath = frmMain.cdbDialog.FileName
    'Then it Prompts for Overwrite layer settings
    strResponse = MsgBox("Do you want to turn on the overwrite option for existing Layers", vbYesNo)
    If strResponse = vbYes Then   ' User chose Yes.
        blnOWrite = 1
    Else   ' User chose No.
        blnOWrite = 0
    End If
    'Creates the config file and writes the new iformation to it
    Open App.Path & "\LayerManager.cfg" For Output As intFileNum
    Print #intFileNum, strDataPath
    Print #intFileNum, strLineTypePath
    Write #intFileNum, blnOWrite
    Close intFileNum
    Else 'Opens the configuration file and sets the configuration variables
    Input #intFileNum, strDataPath
    Input #intFileNum, strLineTypePath
    Input #intFileNum, blnOWrite
    End If
    Close intFileNum
    'Sends the configration settings to the Form
    frmMain.chkOWrite.Value = blnOWrite
    frmMain.lblDataPath.Caption = strDataPath
    frmMain.lblLineTypePath.Caption = strLineTypePath
End Sub
Public Sub InitExportLayerList()
Dim intTest, intCounter, intTemp As Integer
Dim AllLayers As IntelliCAD.Layers
Dim Layer As IntelliCAD.Layer
Dim strExportLayerArray() As String
ReDim strExportLayerArray(0)
frmMain.lstExportLayers.Clear
Call GetAppIcad ' Calls Function to get or Launch Application and document
Set AllLayers = ThisDrawing.Layers
intCounter = 0
'Qualifies the Layers to be shown as exportable
For Each Layer In AllLayers
    intTest = InStr(Layer.Name, "|")
    If Layer.Name <> "0" And UCase(Layer.Name) <> "DEFPOINTS" And intTest = 0 Then
        If intCounter > UBound(strExportLayerArray) Then
                    ReDim Preserve strExportLayerArray(UBound(strExportLayerArray) + 1)
        End If
        strExportLayerArray(intCounter) = Layer.Name
        intCounter = intCounter + 1
    End If
Next
'Sorts the Export Layer List due to the limitations of VBA's listbox
'It is called Shell Sort after the name of Donald Shell
Dim GapPos As Integer
Dim Swapped As Boolean
Dim tmp As Integer
Dim strTempLayerName As String
GapPos = UBound(strExportLayerArray) \ 2
Do While GapPos <> 0
 Do
  Swapped = False 'Sets the variable to Tell if the order was changed.
  For tmp = 0 To UBound(strExportLayerArray) - GapPos
   'Checks to see if String(tmp + GapPos) is before or after String (tmp) If so it does a swap
   If StrComp(strExportLayerArray(tmp + GapPos), strExportLayerArray(tmp), vbTextCompare) = -1 Then
    'The next three lines swap the layer name
    strTempLayerName = strExportLayerArray(tmp + GapPos)
    strExportLayerArray(tmp + GapPos) = strExportLayerArray(tmp)
    strExportLayerArray(tmp) = strTempLayerName
    Swapped = True
   End If
  Next tmp
 Loop Until Not Swapped
 GapPos = GapPos \ 2
Loop
'End of the Sorting Alogrithm
'Shows the layers in the list box
For intTemp = 0 To UBound(strExportLayerArray)
    If strExportLayerArray(intTemp) <> "" Then
        frmMain.lstExportLayers.AddItem strExportLayerArray(intTemp)
    End If
Next intTemp
End Sub
Public Sub ApplyToConfig()
Dim intFileNum As Integer
intFileNum = FreeFile
Open App.Path & "\LayerManager.cfg" For Output As intFileNum
    Print #intFileNum, strDataPath
    Print #intFileNum, strLineTypePath
    Write #intFileNum, frmMain.chkOWrite.Value
    Close intFileNum
End Sub

Public Sub MakeList()
Dim intFileNum, intCounter, intTemp As Integer
Dim strFileIndex, strRightBracket As String
intFileNum = FreeFile
intCounter = 0
frmMain.lstLayers.Clear
ReDim strLayerArray(0)
ReDim strColorArray(0)
ReDim strLineTypeArray(0)
'Opens the Data Creation File and reads it to create the layer list
Open strDataPath For Input As intFileNum
Do Until strFileIndex = frmMain.cmbLayerTypes.Text
    Input #intFileNum, strFileIndex
    If VBA.Left(strFileIndex, 1) = "[" And Len(Trim(strFileIndex)) > 0 Then
        strRightBracket = InStr(strFileIndex, "]")
        strFileIndex = Mid(strFileIndex, 2, (strRightBracket - 2))
    End If
Loop
    Input #intFileNum, strFileIndex
    'Begins creating a layer list according to the current ComboBox Value
    Do Until VBA.Left(strFileIndex, 1) = "[" Or EOF(intFileNum)
                If intCounter > UBound(strLayerArray) Then
                    ReDim Preserve strLayerArray(UBound(strLayerArray) + 1)
                    ReDim Preserve strColorArray(UBound(strColorArray) + 1)
                    ReDim Preserve strLineTypeArray(UBound(strLineTypeArray) + 1)
                End If
                strLayerArray(intCounter) = strFileIndex
                Input #intFileNum, strColorArray(intCounter)
                Input #intFileNum, strLineTypeArray(intCounter)
                If Not EOF(intFileNum) Then
                    Input #intFileNum, strFileIndex
                    intCounter = 1 + intCounter
                End If
            Loop
    Close intFileNum
'Sorts the Layer List due to the limitations of VBA's listbox
'It is called Shell Sort after the name of Donald Shell
Dim GapPos As Integer
Dim Swapped As Boolean
Dim tmp As Integer
Dim strTempLayerName, strTempLayerColor, strTempLayerLineType As String
GapPos = UBound(strLayerArray) \ 2
Do While GapPos <> 0
 Do
  Swapped = False 'Sets the variable to Tell if the order was changed.
  For tmp = 0 To UBound(strLayerArray) - GapPos
   'Checks to see if String(tmp + GapPos) is before or after String (tmp) If so it does a swap
   If StrComp(strLayerArray(tmp + GapPos), strLayerArray(tmp), vbTextCompare) = -1 Then
    'The next three lines swap the layer name
    strTempLayerName = strLayerArray(tmp + GapPos)
    strLayerArray(tmp + GapPos) = strLayerArray(tmp)
    strLayerArray(tmp) = strTempLayerName
    'The next three lines swap the layer Color
    strTempLayerColor = strColorArray(tmp + GapPos)
    strColorArray(tmp + GapPos) = strColorArray(tmp)
    strColorArray(tmp) = strTempLayerColor
    'The next three lines swap the layer Linetype
    strTempLayerLineType = strLineTypeArray(tmp + GapPos)
    strLineTypeArray(tmp + GapPos) = strLineTypeArray(tmp)
    strLineTypeArray(tmp) = strTempLayerLineType
    Swapped = True
   End If
  Next tmp
 Loop Until Not Swapped
 GapPos = GapPos \ 2
Loop
'End of the Sorting Alogrithm
For intTemp = 0 To UBound(strLayerArray)
    frmMain.lstLayers.AddItem strLayerArray(intTemp)
Next intTemp
End Sub
Public Sub SelectLinetypeFile()
Dim strRightBracket, strTmpLine As String
Dim intFileNum As Integer
intFileNum = FreeFile
'Sets up and shows the Open Dialog Box
frmMain.cdbDialog.DialogTitle = "Open File"
frmMain.cdbDialog.Filter = "Linetype File *.lin|*.lin"
frmMain.cdbDialog.FileName = strLineTypePath
On Error Resume Next
frmMain.cdbDialog.ShowOpen
If Err = 0 Then
  strLineTypePath = frmMain.cdbDialog.FileName
End If
frmMain.lblLineTypePath.Caption = strLineTypePath
End Sub

Public Sub CreateLayers()
Dim intCounter, intProgressCount, intTotalCount, intProgCounter As Integer
Dim blnLayerExist As Boolean
Dim XLayer As IntelliCAD.Layer
Dim AllLayers As IntelliCAD.Layers
Dim XLinetype As IntelliCAD.Linetype
Dim AllLinetypes As IntelliCAD.Linetypes
Call GetAppIcad
Set AllLayers = ThisDrawing.Layers
Set AllLinetypes = ThisDrawing.Linetypes
'This Section Sets the Progress Bar Values
intTotalCount = 0
intProgressCount = 0
Do Until intTotalCount = frmMain.lstLayers.ListCount
If frmMain.lstLayers.Selected(intTotalCount) Then
intProgressCount = intProgressCount + 1
End If
intTotalCount = intTotalCount + 1
Loop
frmMain.prgProg1.Min = 0
frmMain.prgProg1.Max = intProgressCount
frmMain.prgProg1.Value = 0
frmMain.prgProg1.Visible = True
frmMain.lblCreate.Visible = True
'End of Progress Bar Section
intProgCounter = 0
intCounter = 0
'Creates the Layers from the selected items on the ListBox
Do Until intCounter = frmMain.lstLayers.ListCount
If frmMain.lstLayers.Selected(intCounter) Then 'Validates selected Items
    frmMain.lstLayers.Selected(intCounter) = False
    frmMain.Refresh
    intProgCounter = intProgCounter + 1
    frmMain.prgProg1.Value = intProgCounter
    blnLayerExist = False
    For Each XLayer In AllLayers 'Checks Collection of layers to see if it exists
        If XLayer.Name = strLayerArray(intCounter) Then
            blnLayerExist = True
        End If
    Next
    If blnLayerExist = False Then
        ThisDrawing.Layers.Add strLayerArray(intCounter) 'Adds the Layer if it doesn't exist
    End If
    If blnLayerExist = True Then ' begin of layer exist routine
        For Each XLayer In AllLayers
            If XLayer.Name = strLayerArray(intCounter) And frmMain.chkOWrite.Value = 1 Then
                XLayer.Color = strColorArray(intCounter) 'Sets the color of the layer
            End If
        Next
    'Check for need to load the linetype
        AddLine = True
        For Each XLinetype In AllLinetypes
            If XLinetype.Name = strLineTypeArray(intCounter) Then
                AddLine = False
            End If
        Next
        If AddLine = True Then 'Loads the linetype if true
            ThisDrawing.Linetypes.Load strLineTypeArray(intCounter), strLineTypePath
        End If
        For Each XLayer In AllLayers
            If XLayer.Name = strLayerArray(intCounter) And frmMain.chkOWrite.Value = True Then
                XLayer.Linetype = strLineTypeArray(intCounter) 'Sets the linetype of the layer
            End If
            Next
    Else 'end of if layer exist routine begin if it doesn't exist
        For Each XLayer In AllLayers
            If XLayer.Name = strLayerArray(intCounter) Then
                XLayer.Color = strColorArray(intCounter) 'Sets the color of the layer
            End If
        Next
    'Check for need to load the linetype
        AddLine = True
        For Each XLinetype In AllLinetypes
            If XLinetype.Name = strLineTypeArray(intCounter) Then
                AddLine = False
            End If
        Next
        If AddLine = True Then 'Loads the linetype if true
            ThisDrawing.Linetypes.Load strLineTypeArray(intCounter), strLineTypePath
        End If
        For Each XLayer In AllLayers
            If XLayer.Name = strLayerArray(intCounter) Then
                XLayer.Linetype = strLineTypeArray(intCounter) 'Sets the linetype of the layer
            End If
        Next
    End If 'end of if layer doesn't exist routine
End If
intCounter = 1 + intCounter
Loop
frmMain.prgProg1.Visible = False
frmMain.lblCreate.Visible = False
Call InitExportLayerList 'Updates the export layer list
End Sub
Public Function SelectlstLayers(blnSelect As Boolean)
Dim intLCounter, intLCount As Integer
intLCounter = 0
intLCount = frmMain.lstLayers.ListCount
Do Until intLCounter = intLCount
frmMain.lstLayers.Selected(intLCounter) = blnSelect
intLCounter = intLCounter + 1
Loop
End Function
Public Function SelectlstExport(blnSelect As Boolean)
Dim intLCounter, intLCount As Integer
intLCounter = 0
intLCount = frmMain.lstExportLayers.ListCount
Do Until intLCounter = intLCount
frmMain.lstExportLayers.Selected(intLCounter) = blnSelect
intLCounter = intLCounter + 1
Loop
End Function
Public Function InvertlstLayers()
Dim intLCounter, intLCount As Integer
intLCounter = 0
intLCount = frmMain.lstLayers.ListCount
Do Until intLCounter = intLCount
If frmMain.lstLayers.Selected(intLCounter) = True Then
frmMain.lstLayers.Selected(intLCounter) = False
Else
frmMain.lstLayers.Selected(intLCounter) = True
End If
intLCounter = intLCounter + 1
Loop
End Function
Public Function InvertlstExport()
Dim intLCounter, intLCount As Integer
intLCounter = 0
intLCount = frmMain.lstExportLayers.ListCount
Do Until intLCounter = intLCount
If frmMain.lstExportLayers.Selected(intLCounter) = True Then
frmMain.lstExportLayers.Selected(intLCounter) = False
Else
frmMain.lstExportLayers.Selected(intLCounter) = True
End If
intLCounter = intLCounter + 1
Loop
End Function
Public Function GetAppIcad()
'Links to the Application or Launches a new one
On Error Resume Next
Set IcadApp = GetObject(, "icad.application")
If Err <> 0 Then
Set IcadApp = CreateObject("icad.application")
End If
IcadApp.Visible = True
'Links to the current document or creates a new document
On Error Resume Next
Set ThisDrawing = IcadApp.ActiveDocument
If Err <> 0 Then
Set ThisDrawing = IcadApp.Documents.Add
End If
End Function
Public Sub EmailMe()
Dim lngRet As Long
Dim strTo As String
Dim strCC As String
Dim strSubject As String
Dim strBody As String
strTo = "dtrotzjr@inreach.com"
strCC = "dtrotzjr@juno.com"
strSubject = "Layer Manager For IntelliCAD 2000"
strBody = "I would like to be placed on the mailing (via email) list for updates to the Layer Manager"


lngRet = Shell("Start.exe " _
        & "mailto:" & """" & strTo & """" _
        & "?Subject=" & """" & strSubject & """" _
        & "&cc=" & """" & strCC & """" _
        & "&Body=" & """" & strBody & """" _
        & "&File=" & """" & "c:\autoexec.bat" & """" _
        , 0)
End Sub



'Things to do
' Fix Bug when configured *.LMD file is missing
' Fix Bug when two group names match
' Add append to group ability

