VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} DBXWrapMainForm 
   Caption         =   "UserForm1"
   ClientHeight    =   4605
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   7080
   OleObjectBlob   =   "DBXWrapMainForm.frx":0000
   StartUpPosition =   1  'CenterOwner
End
Attribute VB_Name = "DBXWrapMainForm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

'USE WINDOWS API FOR RETURN FOLDER DIALOG
Private Declare Function SHBrowseForFolder _
Lib "shell32.dll" Alias "SHBrowseForFolderA" _
(lpBrowseInfo As BROWSEINFO) As Long

Private Declare Function SHGetPathFromIDList _
Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, ByVal pszPath As String) _
As Long

Private Type BROWSEINFO
  hOwner As Long
  pidlRoot As Long
  pszDisplayName As String
  lpszTitle As String
  ulFlags As Long
  lpfn As Long
  lParam As Long
  iImage As Long
End Type

Private Const MAX_PATH = 2600

'A variable to hold found files from the
'FileFinder method
Private c_Files As Collection
Dim o_TxtStream As TextStream
Dim fso As Scripting.FileSystemObject
Dim myBatchEndTime, myBatchTotalTime, myBatchTimeStart

'//Display the Browse For Folder Dialog ///

Private Function ReturnFolder() As String
  Dim Browser As BROWSEINFO
  Dim lngFolder As Long
  Dim strPath As String
  On Error GoTo Err_Catch
  With Browser
    .hOwner = 0&
    .lpszTitle = "Select Directory to traverse"
    .pszDisplayName = String(MAX_PATH, 0)
  End With
  strPath = String(MAX_PATH, 0)
  lngFolder = SHBrowseForFolder(Browser)
  If lngFolder Then
    SHGetPathFromIDList lngFolder, strPath
    ReturnFolder = Left(strPath, InStr(strPath, _
    vbNullChar) - 1)
  End If
Exit_Here:
  Exit Function
Err_Catch:
  Select Case Err.Number
  'Add your Case selections here
    Case Else
    MsgBox Err.Description
    Resume Exit_Here
  End Select
End Function

'Utility Procedure to search for files

Public Sub FileFinder(StartPath As String, _
Extension As String, GetSubs As Boolean)
  Dim strFileName As String
  Dim cDir As New Collection
  Dim intcnt As Integer
  On Error GoTo Err_Control
  If Len(StartPath) > 0 Then
  If Right(StartPath, 1) <> "\" Then
    StartPath = StartPath & "\"
  End If
  strFileName = Dir(StartPath & "*.*", _
  vbDirectory)
  Do While (strFileName <> "")
  Me.MousePointer = fmMousePointerHourGlass
  'Don't want system files
    If Not strFileName = "." And Not _
    strFileName = ".." Then
      If StrComp(Right(strFileName, 3), Extension, vbTextCompare) = 0 Then
        c_Files.Add StartPath & strFileName
      ElseIf GetAttr(StartPath & strFileName) = vbDirectory Then
        cDir.Add StartPath & strFileName
      Else
        With New FileSystemObject
            If .FolderExists(StartPath & strFileName) Then
                cDir.Add StartPath & strFileName
            End If
        End With
      End If
    End If
    strFileName = Dir
    'allow really big searches
    DoEvents
  Loop
  If GetSubs Then
    If (cDir.Count > 0) Then
      For intcnt = 1 To cDir.Count
        FileFinder cDir(intcnt), Extension, True
      Next intcnt
    End If
  End If
  Me.MousePointer = fmMousePointerDefault
  Set cDir = Nothing
  End If
Exit_Here:
  Exit Sub
Err_Control:
  Select Case Err.Number
  'Add your Case selections here
    Case Else
    MsgBox Err.Description
    Resume Exit_Here
  End Select

End Sub

Private Property Get FileCount() As Long
  FileCount = c_Files.Count
End Property

'Get the path of a file contained in the c_Files collection
Private Function GetFile(ByVal lngID As Long) As String
  On Error GoTo Err_Control
  GetFile = c_Files(lngID)
Exit_Here:
  Exit Function
Err_Control:
  Select Case Err.Number
  'Add your Case selections here
    Case Else
    MsgBox Err.Description
    Resume Exit_Here
  End Select
End Function

Private Sub ResetFiles()
  Set c_Files = New Collection
End Sub

Private Function ParseFileName(strFullPath As String)

Dim lngPos As Long, lngStart As Long
Dim strFileName As String
    lngStart = 1
    Do
        lngPos = InStr(lngStart, strFullPath, "\")
        If lngPos = 0 Then
            strFileName = Right(strFullPath, Len(strFullPath) - lngStart + 1)
        Else
            lngStart = lngPos + 1
        End If
    Loop While lngPos > 0
    
    ParseFileName = strFileName

End Function

Private Sub cmdGetBlockRefs_Click()
myBatchTimeStart = Now
Label4.Caption = ""
Label4.Tag = ""
Dim CntLBox As Integer
Dim i As Integer, k As Integer
Dim col_Brefs As New Collection
Dim genObject As Object
Dim myDBXStarter As ObjectDBXDocument
Dim DbxDoc As AXDBLib.AxDbDocument
Dim DBXBRef As AXDBLib.AcadBlockReference
Dim DBXBAtts
'Ensure ListBox contains list items
    If lst_Files.ListCount >= 1 Then
        'If no selection, choose FIRST list item.
        If lst_Files.ListIndex = -1 Then
            lst_Files.TopIndex = lst_Files.ListIndex
            lst_Files.Selected(0) = True
        End If
        CntLBox = lst_Files.ListCount
        frm_Main.Caption = " Files To Update " & CntLBox
        'Me.Caption = Me.Caption & "  -  Processing " & CntLBox & " files"
        Me.Repaint
        'TextBox1.Text = CntLBox
        'lst_Files.ListIndex = _
         '       lst_Files.ListCount -1
        'WHILE
        Set fso = CreateObject("Scripting.FileSystemObject")
        Label4.Tag = Replace(lst_Files.Text, ParseFileName(lst_Files.Text), "BlockRef_Report.txt", 1, -1, vbTextCompare)
        fso.CreateTextFile Label4.Tag, True, False
        
        Set o_TxtStream = fso.OpenTextFile(Label4.Tag, ForAppending, True, TristateUseDefault)
        'Set o_TxtStream = New Scripting.FileSystemObject
        myBatchTimeStart = Now
        For i = 0 To lst_Files.ListCount - 1
            lst_Files.Selected(i) = True
            'Call PaintPreview(lst_Files.Text)
            'Me.Repaint
            Set myDBXStarter = New ObjectDBXDocument
            If myDBXStarter.OpenDoc(lst_Files.Text) Then
                Set DbxDoc = myDBXStarter.Document
                Set col_Brefs = myDBXStarter.BlockRefs
            End If
            'Read_File_From_ListBox (lst_Files.Text)
            If Not col_Brefs.Count < 1 Then
                o_TxtStream.Write lst_Files.Text & vbCrLf & "Contains the following Block Inserts"
                o_TxtStream.Write vbNullString & vbCrLf
                o_TxtStream.Write "Name" & vbTab & vbTab & vbTab & vbTab & vbTab & vbTab & vbTab & "Layer" & vbCrLf
                o_TxtStream.Write String(66, "=")
                o_TxtStream.Write vbNullString & vbCrLf
                For Each genObject In col_Brefs
                    Set DBXBRef = genObject
                    o_TxtStream.Write DBXBRef.Name & vbTab & vbTab & vbTab & vbTab & DBXBRef.Layer & vbCrLf
                    o_TxtStream.Write vbTab & "Insertion Point (x,y,z): (" & DBXBRef.InsertionPoint(0) & _
                                      "," & DBXBRef.InsertionPoint(1) & "," & DBXBRef.InsertionPoint(2) & ")" & vbCrLf
                    If DBXBRef.HasAttributes Then
                        o_TxtStream.Write vbTab & "The Following Attributes were found:"
                        o_TxtStream.WriteLine
                        o_TxtStream.Write vbTab & vbTab & "Tag" & vbTab & vbTab & "Value" & vbCrLf
                        o_TxtStream.Write vbTab & String(33, "-") & vbCrLf
                        DBXBAtts = DBXBRef.GetAttributes
                        For k = LBound(DBXBAtts) To UBound(DBXBAtts)
                            o_TxtStream.Write vbTab & vbTab & DBXBAtts(k).TagString & vbTab & vbTab & DBXBAtts(k).TextString
                        Next k
                    End If
                    o_TxtStream.Write vbNullString & vbCrLf & vbCrLf
                Next genObject
            End If
            lst_Files.Selected(i) = False
        Next i
    Else
        MsgBox "Please Select some Files!", vbInformation, "Need Files for DBX"
        Exit Sub
    End If
    myBatchEndTime = Now
    myBatchTotalTime = myBatchEndTime - myBatchTimeStart
    myBatchTotalTime = Format$(myBatchTotalTime, "N:Ss")
    'MsgBox myBatchTotalTime
Me.Repaint
Label4.Caption = "Searching Complete!" & vbCrLf & "in " & myBatchTotalTime
Label5.Caption = "Browse to " & Label4.Tag & " to review DBX Block Reference (Insertion) Report."
If o_TxtStream.Line > 1 Then
    'got something here
    o_TxtStream.WriteLine
    o_TxtStream.Write (Label4.Caption)
End If
o_TxtStream.Close
Set o_TxtStream = Nothing
Set fso = Nothing
'Shell Label4.Tag, vbNormalFocus
Label4.Tag = ""
End Sub

Private Sub cmdGetAecEntities_Click()
myBatchTimeStart = Now
Label4.Caption = ""
Label4.Tag = ""
Dim CntLBox As Integer
Dim i As Integer
Dim col_AECs As New Collection
Dim genObject As Object
Dim aecDBXStarter As ObjectDBXAECDocument
Dim DbxDoc As AXDBLib.AxDbDocument
'Ensure ListBox contains list items
    If lst_Files.ListCount >= 1 Then
        'If no selection, choose FIRST list item.
        If lst_Files.ListIndex = -1 Then
            lst_Files.TopIndex = lst_Files.ListIndex
            lst_Files.Selected(0) = True
        End If
        CntLBox = lst_Files.ListCount
        frm_Main.Caption = " Files To Update " & CntLBox
        Me.Repaint
        Set fso = CreateObject("Scripting.FileSystemObject")
        Label4.Tag = Replace(lst_Files.Text, ParseFileName(lst_Files.Text), "AECEntities_Report.txt", 1, -1, vbTextCompare)
        fso.CreateTextFile Label4.Tag, True, False
        Set o_TxtStream = fso.OpenTextFile(Label4.Tag, ForAppending, True, TristateUseDefault)
        myBatchTimeStart = Now
        For i = 0 To lst_Files.ListCount - 1
            lst_Files.Selected(i) = True
            Set aecDBXStarter = New ObjectDBXAECDocument
            If aecDBXStarter.OpenDoc(lst_Files.Text) Then
                Set DbxDoc = aecDBXStarter.Document
                Set col_AECs = aecDBXStarter.aecEnts
            End If
            If col_AECs.Count > 0 Then
                For Each genObject In col_AECs
                o_TxtStream.Write genObject.ObjectName & vbTab & genObject.Handle
                o_TxtStream.WriteLine
                Next genObject
            End If
            lst_Files.Selected(i) = False
        Next i
        'ENDWHILE
    Else
        MsgBox "Please Select some Files!", vbInformation, "Need Files for DBX"
        Exit Sub
    End If
    myBatchEndTime = Now
    myBatchTotalTime = myBatchEndTime - myBatchTimeStart
    myBatchTotalTime = Format$(myBatchTotalTime, "N:Ss")
Me.Repaint
Label4.Caption = "Searching Complete!" & vbCrLf & "in " & myBatchTotalTime
Label5.Caption = "Browse to " & Label4.Tag & " to review DBX Aec Entity Report."
If o_TxtStream.Line > 1 Then
    'got something here
    o_TxtStream.WriteLine
    o_TxtStream.Write (Label4.Caption)
End If
o_TxtStream.Close
Set o_TxtStream = Nothing
Set fso = Nothing
Label4.Tag = ""
End Sub


Private Sub cmdGetXRefs_Click()
myBatchTimeStart = Now
Label4.Caption = ""
Label4.Tag = ""
Dim CntLBox As Integer
Dim i As Integer
Dim col_XBrefs As New Collection
Dim myDBXStarter As ObjectDBXDocument
Dim DbxDoc As AXDBLib.AxDbDocument
Dim myDBX_Xref As AXDBLib.AcadExternalReference
'Ensure ListBox contains list items
    If lst_Files.ListCount >= 1 Then
        'If no selection, choose FIRST list item.
        If lst_Files.ListIndex = -1 Then
            lst_Files.TopIndex = lst_Files.ListIndex
            lst_Files.Selected(0) = True
        End If
        CntLBox = lst_Files.ListCount
        frm_Main.Caption = " Files To Update " & CntLBox
        Me.Repaint
        Set fso = CreateObject("Scripting.FileSystemObject")
        Label4.Tag = Replace(lst_Files.Text, ParseFileName(lst_Files.Text), "XRef_Report.txt", 1, -1, vbTextCompare)
        fso.CreateTextFile Label4.Tag, True, False
        
        Set o_TxtStream = fso.OpenTextFile(Label4.Tag, ForAppending, True, TristateUseDefault)
        'Set o_TxtStream = New Scripting.FileSystemObject
        myBatchTimeStart = Now
        For i = 0 To lst_Files.ListCount - 1
            lst_Files.Selected(i) = True
            Set myDBXStarter = New ObjectDBXDocument
            If myDBXStarter.OpenDoc(lst_Files.Text) Then
                Set DbxDoc = myDBXStarter.Document
                Set col_XBrefs = myDBXStarter.Xrefs
            End If
            'Read_File_From_ListBox (lst_Files.Text)
            If Not col_XBrefs.Count < 1 Then
                o_TxtStream.Write lst_Files.Text & vbCrLf & "Contains the following External References"
                o_TxtStream.Write vbNullString & vbCrLf
                o_TxtStream.Write "Name" & vbTab & vbTab & vbTab & vbTab & vbTab & vbTab & vbTab & "Path" & vbCrLf
                o_TxtStream.Write String(66, "=")
                o_TxtStream.Write vbNullString & vbCrLf
                For Each myDBX_Xref In col_XBrefs
                    o_TxtStream.Write myDBX_Xref.Name & vbTab & vbTab & vbTab & vbTab & myDBX_Xref.Path & vbCrLf
                    o_TxtStream.Write vbTab & "Insertion Point (x,y,z): (" & myDBX_Xref.InsertionPoint(0) & _
                                      "," & myDBX_Xref.InsertionPoint(1) & "," & myDBX_Xref.InsertionPoint(2) & ")" & vbCrLf
                    o_TxtStream.Write vbNullString & vbCrLf & vbCrLf
                Next myDBX_Xref
            End If
            Set col_XBrefs = New Collection
            lst_Files.Selected(i) = False
        Next i
        'ENDWHILE
    Else
        MsgBox "Please Select some Files!", vbInformation, "Need Files for DBX"
        Exit Sub
    End If
    myBatchEndTime = Now
    myBatchTotalTime = myBatchEndTime - myBatchTimeStart
    myBatchTotalTime = Format$(myBatchTotalTime, "N:Ss")
    'MsgBox myBatchTotalTime
Me.Repaint
Label4.Caption = "Searching Complete!" & vbCrLf & "in " & myBatchTotalTime
Label5.Caption = "Browse to " & Label4.Tag & " to review DBX External Reference Report."
If o_TxtStream.Line > 1 Then
    'got something here
    o_TxtStream.WriteLine
    o_TxtStream.Write (Label4.Caption)
End If
o_TxtStream.Close
Set o_TxtStream = Nothing
Set fso = Nothing
'Shell Label4.Tag, vbNormalFocus
Label4.Tag = ""
End Sub

Private Sub UserForm_Activate()
  Dim strBlank As String
  '/Initialize Begins
  Me.Caption = "ObjectDBX Explorer"
  '/Frame 1 Controls
  frm_Main.Caption = " Files To Search "
  lst_Files.Visible = True
  lst_Files.Enabled = True
  cboSelection.AddItem Application.Path
  cboSelection.AddItem "Browse"
  Set c_Files = New Collection
  Label4.Caption = ""
End Sub

Private Sub cboSelection_Click()
  Dim strPath As String
  Dim lngCnt As Long
  Static blnCode As Boolean
  'This keeps the code from
  'Becoming recursive when it
  'Set the Index to a new item
  '(This will fir the click event
  'Again)
  If Not blnCode Then
  If cboSelection.Text = "Browse" Then
    strPath = ReturnFolder
    If Len(strPath) > 0 Then
      cboSelection.AddItem strPath, _
      cboSelection.ListCount - 1
      blnCode = True
      cboSelection.ListIndex = _
      cboSelection.ListCount - 2
    Else
      cboSelection.Text = vbNullString
    End If
  Else
    strPath = cboSelection.Text
  End If
  'Remove all of the old file names
  ResetFiles
  'Change False to true and you can
  'Get files from the sub folders..
  FileFinder strPath, "dwg", True
  lst_Files.Clear
  For lngCnt = 1 To FileCount
    lst_Files.AddItem GetFile(lngCnt)
  Next lngCnt
  Else
    blnCode = Not blnCode
  End If
End Sub

Private Sub Read_File_From_ListBox(CurrentListBoxFile As String)
    Dim dbxStarter As ObjectDBXDocument
    Dim DbxDoc As AXDBLib.AxDbDocument
    Dim blnLockLayr As Boolean
    If Not InStr(1, CurrentListBoxFile, "Recover", vbTextCompare) > 0 Then
        Set dbxStarter = New ObjectDBXDocument
        'Set DbxDoc = GetInterfaceObject("ObjectDBX.AxDbDocument")
        Dim strFileChk As String
        Dim blnChk As Boolean
        Dim objLayout As AcadLayout
        Dim MyBlock As AcadBlock
        Dim msg As String
        Dim o_ent As AcadEntity
        Err.Clear
        On Error GoTo Err_Control
            dbxStarter.OpenDoc (CurrentListBoxFile)
            blnChk = False
        blnLockLayr = False
        On Error Resume Next
        Set DbxDoc = dbxStarter.Document
        For Each objLayout In DbxDoc.Layouts
            Set MyBlock = objLayout.Block
            For Each o_ent In MyBlock
                If TypeOf o_ent Is AcadBlockReference Then
                    If o_ent.Name Like "01-SA*" Then
                        If Not blnChk Then
                            blnChk = True
                            msg = CurrentListBoxFile & " Contains the following SafetySymbols" & vbCrLf & _
                                  String(66, "=") & vbCrLf
                                  msg = msg & o_ent.Name & ": " & RtnSafetySymCategory(o_ent.Name) & vbCrLf
                        Else
                            msg = msg & o_ent.Name & ": " & RtnSafetySymCategory(o_ent.Name) & vbCrLf
                        End If
                    End If
                Else
                    Err.Clear
                End If
            Next o_ent
            If blnChk Then
                'write the results to the file
                o_TxtStream.Write msg
                o_TxtStream.WriteBlankLines (2#)
            End If
        Next objLayout
    End If
Exit_Here:
  Exit Sub
Err_Control:
  Select Case Err.Number
  'Add your Case selections here
    Case Else
    'write the results to the file
    o_TxtStream.Write "Error Encountered Opening " & ParseFileName(CurrentListBoxFile) & _
                      vbCrLf & "Location: " & CurrentListBoxFile & vbCrLf & _
                      "Error: " & Err.Description & vbCrLf & "Error Number: " & Err.Number & _
                      vbCrLf & "This File may have been open or corrupt."
    o_TxtStream.WriteBlankLines (2#)
    'ThisDrawing.Utility.Prompt Err.Description & " with " & CurrentListBoxFile & vbCrLf & _
    '    "Please verify and Process this file manually" & vbCrLf
    'MsgBox Err.Description
    Resume Exit_Here
  End Select
Set DbxDoc = Nothing
End Sub

Public Function RtnSafetySymCategory(ByVal strName As String) As String
    Select Case strName
        Case "01-SA01"
            RtnSafetySymCategory = "Slips and Falls"
        Case "01-SA02"
            RtnSafetySymCategory = "Electrocution"
        Case "01-SA03"
            RtnSafetySymCategory = "Cave-ins"
        Case "01-SA04"
            RtnSafetySymCategory = "Falls from Elevation"
        Case "01-SA05"
            RtnSafetySymCategory = "Struck By/Against/Caught"
        Case "01-SA06"
            RtnSafetySymCategory = "Asphyxiation - Confined Space"
        Case "01-SA07"
            RtnSafetySymCategory = "Demolition Hazard"
        Case "01-SA08"
            RtnSafetySymCategory = "Struck By - Steel Erection"
        Case Else
            RtnSafetySymCategory = "Unknown Symbol..."
    End Select
End Function


Private Sub UserForm_QueryClose(Cancel As _
Integer, CloseMode As Integer)
  On Error GoTo Err_Control
  Set c_Files = Nothing
Exit_Here:
  Exit Sub
Err_Control:
  Select Case Err.Number
  'Add your Case selections here
    Case Else
    MsgBox Err.Description
    Resume Exit_Here
  End Select
End Sub