Tuesday, October 20, 2015

Preventing Problems With Worksheet Renaming

Preventing Problems With Worksheet Renaming



ThisWorkbook.VBProject.VBComponents("Sheet1").Name = "SummarySheet"



Renames the object value of the worksheet. Comes in handy and streamlines the code.



I suspect VBA needs programmatic access to teh project model which can be solved here:



''RESOLUTION

''For any Automation client to be able to access the VBA object model programmatically, the user running the code must explicitly

''grant access. To turn on access, the user must follow these steps.

''

''Office 2003 and Office XP

''Open the Office 2003 or Office XP application in question. On the Tools menu, click Macro, and

''then click Security to open the Macro Security dialog box.

''

''On the Trusted Sources tab, click to select the Trust access to Visual Basic Project check box to turn on access.

''Click OK to apply the setting. You may need to restart the application for the code to run properly if you automate from a

''Component Object Model (COM) add-in or template.

''

''Office 2007

''Open the 2007 Microsoft Office system application in question. Click the Microsoft Office button, and then click Application Options.

''Click the Trust Center tab, and then click Trust Center Settings.

''Click the Macro Settings tab, click to select the Trust access to the VBA project object model check box, and then click OK.



''Click OK.

Monday, October 19, 2015

Folder Maker and shortcut creater AND REcurse Checker

MODULE FOLDER MAKER

Option Explicit
Private fso As New FileSystemObject

Dim RecurseCheck As New recurselimit

Dim WSH As WshShell

Public Sub CreateFolderStructure()
    Set WSH = CreateObject("WScript.Shell")    ''WshShell
    ''Set lnk = CreateObject("WScript.Shell")    ''As WshShortcut

    RecurseCreateFolders "00-ROOT"   ''entry point iis to pass name of root sheet to recursive process
    
    ''Set lnk = Nothing
    Set WSH = Nothing
    MsgBox "DONE"
    
End Sub

Private Sub RecurseCreateFolders(ByVal strWSSub As String, Optional ByVal strFPpfix As String) '', Optional FN As String, Optional XCUT As String)
Dim lastrow As Integer
Dim I
Dim strFP As String
    If strWSSub <> "00-ROOT" And RecurseCheck.LimitReached(strWSSub) Then Exit Sub
    
    If strFPpfix > "" Then
        If Right(strFPpfix, 1) <> "\" Then
            strFP = strFPpfix & "\"
        End If
    End If
    
    If Not WorksheetExists(strWSSub) Then Exit Sub

    ''get number of rows on sheet
    lastrow = GETLastCellRange(ActiveWorkbook.Worksheets(strWSSub).Range("$a:$A")).Row
    For I = 2 To lastrow
        strFP = strFPpfix & ActiveWorkbook.Worksheets(strWSSub).Cells(I, 1).Value & "\"
        
        CreateFolder strFP
        CreateShortcut strFPpfix, strFP, strclean(ActiveWorkbook.Worksheets(strWSSub).Cells(I, 2).Value)
        If ActiveWorkbook.Worksheets(strWSSub).Cells(I, 3).Value > "" Then ''subfolder tab should exist
            RecurseCreateFolders ActiveWorkbook.Worksheets(strWSSub).Cells(I, 3).Value, strFP
        End If
    Next I
    
    strFPpfix = ""
End Sub

Private Function WorksheetExists(ByVal WorksheetName As String) As Boolean
    On Error Resume Next
    WorksheetExists = (Sheets(WorksheetName).name <> "")
    On Error GoTo 0
End Function

Private Sub testCreateFolder()
    CreateFolder "C:\temp\foo\bar\deep"
End Sub
Private Sub CreateFolder(FP As String)
Dim x, I, fpp
    x = Split(FP, "\")
    fpp = x(0)
    For I = 1 To UBound(x)
        If x(I) > "" Then
            fpp = fpp & "\" & x(I)
            If Not fso.FolderExists(fpp) Then fso.CreateFolder (fpp)
        End If
    Next I
End Sub

'''''''''''''''''-------------------------------------------------------------------------------------------------------
Private Sub testLink()
    Call CreateShortcut("C:\Users\RON_ALLEN\Desktop", "C:\Users\RON_ALLEN\Desktop\FILE-STRUCTURES", "TEST XMIND FILE LINK")
End Sub
'''''''''''''''''-------------------------------------------------------------------------------------------------------
Private Sub CreateShortcut(ByVal PlacementFilePath As String, ByVal TargetFilePath As String, ByVal ShortcutName As String)
''PlacementFilePath     ="C:\Users\RON_ALLEN\Desktop"
''TargetFilePath        = "C:\Users\RON_ALLEN\Desktop\FILE-STRUCTURES"
''ShortcutName          ="TEST XMIND FILE LINK"

''Dim WSH As WshShell
Dim lnk As WshShortcut
Dim strXName As String
Dim oFolder As Folder

ShortcutName = strclean(ShortcutName)

Dim StartIn As String
    Set lnk = Nothing
    On Error GoTo Proc_Err

    Set oFolder = fso.GetFolder(TargetFilePath)

    StartIn = oFolder.Path
    
    'Do While Right(StartIn, 1) <> "\" And Len(StartIn) > 3
    '    StartIn = Left(StartIn, Len(StartIn) - 1)
    'Loop
    'StartIn = Left(StartIn, Len(StartIn))
        
    If PlacementFilePath = "" Then PlacementFilePath = oFolder.ParentFolder.Path
    
    'Do While Right(PlacementFilePath, 1) <> "\" And Len(PlacementFilePath) > 3
    '    PlacementFilePath = Left(PlacementFilePath, Len(PlacementFilePath) - 1)
    'Loop
   
    'Set WSH = CreateObject("WScript.Shell")
    strXName = Trim(Left(PlacementFilePath & "\" & ShortcutName, 128)) & ".lnk"
    Set lnk = WSH.CreateShortcut(strXName)
    
    lnk.TargetPath = TargetFilePath
    lnk.Arguments = StartIn
    ''comment:
    lnk.Description = ""
    lnk.Description = Trim(Left("Created with shortcut generator: " & ShortcutName, 200))
    'lnk.HotKey = ""
    'lnk.IconLocation = ""
    'lnk.WindowStyle = "1"
    lnk.WorkingDirectory = StartIn
    lnk.Save
    'Clean up
    
Proc_Exit:
    On Error GoTo 0
    Set lnk = Nothing
    ''Set WSH = Nothing
    Exit Sub
  
Proc_Err:
    MsgBox Err.Description, , _
        "ERROR " & Err.Number _
        & "   CreateShortcut "
    Stop
    Resume Proc_Exit
    Resume
    
End Sub
Private Function strclean(Str As String) As String
Dim I As Integer
Dim x As String
    For I = 1 To Len(Str)
        x = Mid(Str, I, 1)
        Select Case x
            Case "A" To "Z", "a" To "z", "_", " ", "0" To "9"     '''Characters to keep ''skip "-" to check for double "--"
                strclean = strclean & x
            Case Else
                If Right(strclean, 1) <> "-" Then strclean = strclean & "-" ''Characters else sub with a dash
        End Select
    Next I
End Function
Private Function GETLastCellWorksheet(objWrkSheet As Worksheet) As Range
    ''uses search to find last used cell in a sheet
    Set GETLastCellWorksheet = GETLastCellRange(objWrkSheet.Cells)
End Function

Private Function GETLastCellRange(objRange As Range) As Range
    ''uses search to find last used cell in a range
    Set GETLastCellRange = objRange.Find(What:="*", After:=objRange.Cells(1, 1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
    If GETLastCellRange Is Nothing Then ''empty workbook
        Set GETLastCellRange = objRange.Cells(1, 1)
    End If
End Function

''''''--------------------------------------------------------
''''SHEET MAKER MODULE
''''''--------------------------------------------------------
Option Explicit
Public strTabValidate As String
Public Const strTabRoot = "00-ROOT"            ''Special starting folder
Public Const strSubfolder = "Subfolders Tab"   ''Special column to look for in formatting
Public Const strFName = "Folder Name (Short-no spaces, use dashes)"
Public Const strFXCUT = "Folder Shortcut Name (Long name)"

Sub UpdateSheets()
    UpdateSheetFormatsAndValidation
End Sub
Sub UpdateSheetFormatsAndValidation(Optional ws As Worksheet)
    If ws Is Nothing Then
        For Each ws In ThisWorkbook.Worksheets
            Validate_SUBFOLDERS_TAB ws
            FormatSheet ws
        Next ws
    Else
        Validate_SUBFOLDERS_TAB ws
        FormatSheet ws
        For Each ws In ThisWorkbook.Worksheets
            Validate_SUBFOLDERS_TAB ws
        Next ws
    End If
End Sub

Sub Validate_SUBFOLDERS_TAB(ws As Worksheet)

    If ws Is Nothing Then Exit Sub
        
    Dim Target As Range
    Dim xws As Worksheet
    Dim strCurVal As String
    Dim I As Integer
    
    
    strTabValidate = ""
    
    For Each xws In ThisWorkbook.Worksheets
        If Not (xws.name Like strTabRoot Or xws.name Like ws.name) Then
            strTabValidate = xws.name & "," & strTabValidate
        End If
    Next xws
    
    If strTabValidate > "" Then
        strTabValidate = Left(strTabValidate, Len(strTabValidate) - 1)    'remove trailing comma
        ''bubble sort
        strTabValidate = BubbleSort(strTabValidate)
    End If


    ws.Unprotect
       
    For I = 1 To GETLastCellWorksheet(ws).Column
        If ws.Cells(1, I).Value = strSubfolder Then Exit For
    Next I
    
    ws.Cells.Validation.Delete
    
    Set Target = ws.Cells(1, I).EntireColumn
    With Target.Validation      ''<<<<<<<<<<
            
        If strTabValidate <> "" Then
            .Delete
            .add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
            xlBetween, Formula1:=strTabValidate
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = "TAB for subfolder structure"
            .ErrorTitle = "Please try again"
            .InputMessage = "Select a tab for a subfolder structure, or leave blank for empty/none"
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = True
        Else
            strTabValidate = " "
            .add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
            xlBetween, Formula1:=strTabValidate
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = "Please add tabs"
            .ErrorTitle = "Please try again"
            .InputMessage = "Add Tabs to Select for a subfolder structure, or leave blank for empty/none"
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = True
        End If
    End With
    
End Sub


Private Function BubbleSort(sTmp) As String

  'cheapo bubble sort
  Dim aTmp, I, j, temp
  aTmp = Split(sTmp, ",")
  For I = UBound(aTmp) - 1 To 0 Step -1
    For j = 0 To I - 1
      If LCase(aTmp(j)) > LCase(aTmp(j + 1)) Then
        temp = aTmp(j + 1)
        aTmp(j + 1) = aTmp(j)
        aTmp(j) = temp
      End If
    Next
  Next
   
  BubbleSort = Join(aTmp, ",")
  
End Function

Sub x()
Dim ws As Worksheet
    Set ws = ActiveWorkbook.Worksheets("NCS")
    'FormatCells ws
    'Validate_SUBFOLDERS_TAB ws
    FormatSheet ws
    'FormatCells ws
End Sub

Sub FormatSheet(ws As Worksheet)
Dim I As Integer

    Dim objButton
    Dim objTarget As Range
    Dim objShp As Shape
    
    ws.Unprotect
    ws.Cells.Locked = False
    ws.Columns.Hidden = False
    
    ws.Cells(1, 1) = strFName
    ws.Cells(1, 2) = strFXCUT
    ws.Cells(1, 3) = strSubfolder
    
    '''''''''''''''''''''''''''''''''''''''''''''''''''''
    '''Format First Row''''''''''''''''''''''''''''''''''
    With ws.Rows("1:1").Font
        .name = "Calibri"
        .FontStyle = "Bold"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    
    '''''''''''''''''''''''''''''''''''''''''''''''''''''
    '''Format First Row''''''''''''''''''''''''''''''''''
    With ws.Rows("1:1").Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark2
        .TintAndShade = -0.499984740745262
        .PatternTintAndShade = 0
    End With
    
    
    With ws.Cells
        .ColumnWidth = 20
        .NumberFormat = "@"
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlTop
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
    For I = 1 To GETLastCellWorksheet(ws).Column
        If ws.Cells(1, I).Value = SheetMaker.strSubfolder Then Exit For
    Next I
    
    With ws.Cells(1, I).EntireColumn
        .ColumnWidth = 20
        .NumberFormat = "@"
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlTop
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
        For I = 1 To GETLastCellWorksheet(ws).Column
        If ws.Cells(1, I).Value = SheetMaker.strFXCUT Then Exit For
    Next I
    
    With ws.Cells(1, I).EntireColumn
        .ColumnWidth = 80
        .NumberFormat = "@"
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlTop
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Application.PrintCommunication = False
    
    
    With ws.PageSetup
        .PrintTitleRows = "$1:$1"      '''<<
        .PrintTitleColumns = ""
    End With

    
    ws.PageSetup.PrintArea = "$a:$D"

    With ws.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.7)
        .RightMargin = Application.InchesToPoints(0.7)
        .TopMargin = Application.InchesToPoints(0.75)
        .BottomMargin = Application.InchesToPoints(0.75)
        .HeaderMargin = Application.InchesToPoints(0.3)
        .FooterMargin = Application.InchesToPoints(0.3)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlPortrait
        .Draft = False
        .PaperSize = xlPaperLetter
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        ''.Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 1
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    
    ws.ResetAllPageBreaks
    
    On Error Resume Next
    Application.PrintCommunication = True
    On Error GoTo 0
    
    ''Add Click to star create Folders
    Set objTarget = ws.Range("$c$1")
    
    If ws.Shapes.count > 0 Then
       ws.Shapes(1).Delete
    End If

    Set objButton = ws.Buttons.add(objTarget.Left + objTarget.Width / 2, objTarget.Top, objTarget.Width / 2, objTarget.Height)
   
    With objButton
        .OnAction = "CreateFolderStructure"
        .Caption = "CreateFolders"
    End With
    
    'Stop
    ws.Activate
    'ws.Columns(Columns(GETLastCellWorksheet(ws).Column + 1), Cells(1, ws.Columns.Count)).EntireColumn.Hidden = True
    ws.Range(Cells(1, GETLastCellWorksheet(ws).Column + 1), Cells(1, ws.Columns.count)).EntireColumn.Hidden = True
    
End Sub

Private Function GETLastCellWorksheet(objWrkSheet As Worksheet) As Range
    ''uses search to find last used cell in a sheet
    Set GETLastCellWorksheet = GETLastCellRange(objWrkSheet.Cells)
End Function

Private Function GETLastCellRange(objRange As Range) As Range
    ''uses search to find last used cell in a range
    Set GETLastCellRange = objRange.Find(What:="*", After:=objRange.Cells(1, 1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
    If GETLastCellRange Is Nothing Then ''empty workbook
        Set GETLastCellRange = objRange.Cells(1, 1)
    End If
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''RECURSE LIMIT CLASS-------------------
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Option Explicit

Private Type xdat
    count As Integer     ' Declare a static array.
    tabname As String
End Type

Public tabname As String
Public TabCount As Integer
Dim Limit As Integer
Public StopTime As Date

Dim x()  As xdat

Public Function LimitReached(strTabReference As String) As Boolean
Dim I As Integer
Dim ub As Integer

StopTimeCheck

ub = -1
On Error Resume Next
ub = UBound(x)
On Error GoTo 0

LimitReached = False

For I = 0 To ub
    If x(I).tabname = strTabReference Then
        x(I).count = x(I).count + 1
        If x(I).count > Limit Then
            LimitReached = True
            'MsgBox "Limit reached"
            Stop
        End If
        Exit Function
    End If
Next I

''new unlisted tab
ReDim Preserve x(I) As xdat
    x(I).tabname = strTabReference
    x(I).count = 1
End Function

Private Sub Class_Initialize()
    Limit = 2
    StopTimeCheck
End Sub

Sub StopTimeCheck()
    If StopTime = 0 Or StopTime < Date + Time Then
        'Stop
        StopTime = Date + Time + 15 / 60 / 60 / 24
        Exit Sub
    End If

End Sub

Thursday, October 15, 2015

Software Inventory Excel VBA

Option Explicit
''original source from
'''http://www.mrexcel.com/forum/excel-questions/535773-list-softwares-installed-excel-using-visual-basic-applications.html
''updated by Ron E. Allen

Private sFileName As String
Private StrComputer As String

Private Const MAX_COMPUTERNAME_LENGTH As Long = 31

Private Declare PtrSafe Function GetComputerName Lib "kernel32" _
Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Public sCompName As String
Public strDomain As String

Sub GetInstalledSoftware()
    'Dim sTitle As String
    Dim s As String
    Dim wsh As New WshShell

    'sTitle = "You are about to retrieve the software installed on your computer."
    'MsgBox sTitle
    
    StrComputer = GetCompName
    If StrComputer = vbNullString Then Exit Sub
    
    StrComputer = Trim(StrComputer)
    If StrComputer = "" Then StrComputer = "."
    sCompName = GetProbedID(StrComputer)
    
    If Len(sCompName) > 0 Then
        sFileName = wsh.SpecialFolders("Desktop") & "\" & sCompName & "_" & GetDTFileName() & "_Software.txt"  ''<<
        s = GetAddRemove(StrComputer)
        Call WriteFile(s, sFileName)
        Do
        DoEvents
        Loop Until Len(Dir(sFileName)) <> 0
        Call AddSheet
        
        Kill sFileName
    End If
    
    MsgBox "Edit lines out of this worksheet if necesary." & vbCr & vbCr & "Use the 'Email as attachment' button in the top-right of this form to send this workbook as an attachment", vbInformation + vbOKOnly, "Please send this information back"
    
End Sub

Private Function GetAddRemove(sComp) As String

  'Function credit to Torgeir Bakken
  Dim cnt, oReg, sBaseKey, iRC, aSubKeys
  Dim sCompName As String
  Const HKLM = &H80000002  'HKEY_LOCAL_MACHINE
  Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
              sComp & "/root/default:StdRegProv")
  sBaseKey = "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\"
  iRC = oReg.EnumKey(HKLM, sBaseKey, aSubKeys)
  Dim sKey, sValue, sTmp, sVersion, sDateValue, sYr, sMth, sDay
  For Each sKey In aSubKeys
    iRC = oReg.GetStringValue(HKLM, sBaseKey & sKey, "DisplayName", sValue)
    If iRC <> 0 Then
      oReg.GetStringValue HKLM, sBaseKey & sKey, "QuietDisplayName", sValue
    End If
    If sValue <> "" Then
      iRC = oReg.GetStringValue(HKLM, sBaseKey & sKey, _
                                "DisplayVersion", sVersion)
      If sVersion <> "" Then
        ''sValue = sValue & vbTab & "Ver: " & sVersion
        sValue = sValue & vbTab & sVersion
      Else
        sValue = sValue & vbTab
      End If
      iRC = oReg.GetStringValue(HKLM, sBaseKey & sKey, _
                                "InstallDate", sDateValue)
      If sDateValue <> "" Then
        sYr = Left(sDateValue, 4)
        sMth = Mid(sDateValue, 5, 2)
        sDay = Right(sDateValue, 2)
        'some Registry entries have improper date format
        On Error Resume Next
        sDateValue = DateSerial(sYr, sMth, sDay)
        On Error GoTo 0
        If sDateValue <> "" Then
          ''sValue = sValue & vbTab & "Installed: " & sDateValue
          sValue = sValue & vbTab & sDateValue
        End If
      End If
      sTmp = sTmp & sValue & vbCrLf ''<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
    cnt = cnt + 1
    End If
  Next
  sTmp = BubbleSort(sTmp)
  sTmp = Prefix(sTmp)   ''<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  
GetAddRemove = sTmp ''<
''  GetAddRemove = "INSTALLED SOFTWARE (" & cnt & ") - " & sCompName & _
''                 " - " & Now() & vbCrLf & vbCrLf & sTmp
End Function

Private Function Prefix(sTmp)
    Dim I, strDate, aTmp
    aTmp = Split(sTmp, vbCrLf)
    strDate = GetDTFileName()
    For I = 1 To UBound(aTmp)
        aTmp(I) = strDomain & vbTab & sCompName & vbTab & strDate & vbTab & aTmp(I)
    Next I
    Prefix = Join(aTmp, vbCrLf)
End Function

Private Function BubbleSort(sTmp) As String

  'cheapo bubble sort
  Dim aTmp, I, j, temp
  aTmp = Split(sTmp, vbCrLf)
  For I = UBound(aTmp) - 1 To 0 Step -1
    For j = 0 To I - 1
      If LCase(aTmp(j)) > LCase(aTmp(j + 1)) Then
        temp = aTmp(j + 1)
        aTmp(j + 1) = aTmp(j)
        aTmp(j) = temp
      End If
    Next
  Next
   
  BubbleSort = Join(aTmp, vbCrLf)
  
End Function

Private Function GetProbedID(sComp) As String

  Dim objWMIService, colItems, objItem
  On Error Resume Next
  Set objWMIService = GetObject("winmgmts:\\" & sComp & "\root\cimv2")
  
If Err.Number = 462 Then MsgBox Err.Description
  Set colItems = objWMIService.ExecQuery("Select SystemName from " & "Win32_NetworkAdapter", , 48)
  For Each objItem In colItems
    GetProbedID = objItem.SystemName
  Next
    
    Set colItems = objWMIService.ExecQuery("Select * from Win32_ComputerSystem", , 48)  ''<<<<
    For Each objItem In colItems
        strDomain = objItem.Domain
        ''objItem.Manufacturer
        ''objItem.Model
    Next
End Function

Private Function GetDTFileName() As String

  Dim sNow, sMth, sDay, sYr, sHr, sMin, ap ''sSec
  sNow = Now
  sMth = Right("0" & Month(sNow), 2)
  sDay = Right("0" & Day(sNow), 2)
  sYr = Right("00" & Year(sNow), 4)
  sHr = Right("0" & Hour(sNow), 2)
  sMin = Right("0" & Minute(sNow), 2)
  If sHr > 11 Then ap = "p" Else ap = "a"
  GetDTFileName = sYr & "-" & sMth & "-" & sDay & "_" & sHr & sMin & ap
  
End Function

Private Function WriteFile(sData, sFileName) As Boolean

  Dim fso As FileSystemObject
  Dim OutFile, bWrite
  bWrite = True
  Set fso = CreateObject("Scripting.FileSystemObject")

    

  On Error Resume Next
  Set OutFile = fso.OpenTextFile(sFileName, 2, True)
  'Possibly need a prompt to close the file and one recursion attempt.
  If Err = 70 Then
    MsgBox "Could not write to file " & sFileName & ", results " & _
                 "not saved." & vbCrLf & vbCrLf & "This is probably " & _
                 "because the file is already open."
    bWrite = False
  ElseIf Err Then
    MsgBox Err & vbCrLf & Err.Description
    bWrite = False
  End If
  On Error GoTo 0
  If bWrite Then
    OutFile.WriteLine (sData)
    OutFile.Close
  End If
  Set fso = Nothing
  Set OutFile = Nothing
  WriteFile = bWrite
  
End Function

Private Sub AddSheet()

    Dim oWS As Worksheet
    Dim strShtName
    
    Dim objButton
    Dim objTarget As Range
    
    strShtName = GetDTFileName & "-" & Trim(Left(StrComputer, 31 - 17))
    
On Error Resume Next
    Set oWS = Worksheets(strShtName)
    If oWS Is Nothing Then Set oWS = Worksheets.Add(After:=Worksheets(Worksheets.Count))
On Error GoTo 0
    With oWS
        ''.Name = "Installed_Software"
        ''.Range("$A$1") = "Computer : " & StrComputer
        ''.Range("a1").Font.Bold = True
        ''.QueryTables.Add(Connection:="TEXT;" & sFileName, Destination:=oWS.Range("$A$2")).Refresh
        .Activate
        .Name = strShtName
        .Range("$A$1") = "Domain"
        .Range("$b$1") = "Computer : " & StrComputer
        .Range("$c$1") = "Run Date"
        .Range("$d$1") = "Software from Add/Remove"
        .Range("$e$1") = "Version"
        .Range("$f$1") = "Install Date"
        
        ''Add sendto button
        Set objTarget = .Range("$g$1")
        objTarget.ColumnWidth = 30
        objTarget.RowHeight = 30
        Set objButton = .Buttons.Add(objTarget.Left, objTarget.Top, objTarget.Width, objTarget.Height)
        With objButton
            .OnAction = "SendAsAttachment"
            .Caption = "Email As Attachment"
        End With
        
        
        .Range("1:1").Font.Bold = True
        .QueryTables.Add(Connection:="TEXT;" & sFileName, Destination:=oWS.Range("$A$2")).Refresh
        .Columns("A:G").AutoFit
    End With
    
    If ActiveWorkbook.Worksheets.Count > 1 Then
        If MsgBox("May the other sheets be deleted to clean up the workbook?", vbCritical + vbYesNo, "Cleanup workbook") = vbYes Then
            Dim I
            Application.DisplayAlerts = False
            For I = ActiveWorkbook.Worksheets.Count To 1 Step -1
                If ActiveWorkbook.Worksheets(I).Name <> oWS.Name And Not (oWS Is Nothing) Then ActiveWorkbook.Worksheets(I).Delete
            Next I
            Application.DisplayAlerts = True
        End If
    End If
End Sub


Private Function GetCompName() As String

    Dim lStrLen As Long
    Dim sString As String
    
    lStrLen = MAX_COMPUTERNAME_LENGTH + 1
    sString = Space(lStrLen)
    GetComputerName sString, lStrLen
    sString = Left(sString, lStrLen)
    GetCompName = sString
    
End Function

''-------------------------------------------------------------------
Const strSendTo = "Specificemail@sspecificDomain.com" ''Email to send info to Sub SendAsAttachment() ' ' SendAsAttachment Macro ' If MsgBox("Does the workbook require editing to exclude any confidential items that should not be shared before sending?", vbExclamation + vbYesNoCancel, "Sendmail Preperation") <> vbNo Then MsgBox "Please edit the document to remove content to remain anonymous. Once complete, press the Sendmail button again to mail the document.", vbOKOnly + vbInformation, "Mailing cancelled" Exit Sub End If MsgBox "No subject or body to the email is required. Excel should open an email with the workbook attached." & vbCr & vbCr & "Please address it to " & strSendTo, vbOKOnly + vbInformation Application.Dialogs(xlDialogSendMail).Show _ arg1:=strSendTo, _ arg2:=GetInstalledSoftware.strDomain & "/" & GetInstalledSoftware.sCompName & " Installed software" End Sub

'''

''----------------------------------------------------------------------------------