Auto Metrics Chart Demo

Sample Chart Demo

auto progress chart
auto progress chart sample
The working, customizeable chart demonstrates "automatic metrics" - it gives you timely reporting with just a quick attachment or a screenshot from the current Test XLS Suite being executed.

click chart thumbnail at right for full screenshot. Download XLS from link[s] above. Downloading from Google will require (a) having and (b) signing in to a Google account.

The Sample Test Suite in left columns will automatically tabulate the
progress summmary and chart on the right. This is done without
pivot tables, to give more flexibility and less maintenance.The benefit is for both individuals AND teams to be able to report whenever asked yet with minimal interruption.

 

vbCommon – Chomp & Nibble

' -- When using a loop to build a string  - you often want to remove leading (nibble) or trailing (chomp) vbCrLf  - (but what about trim()  ?!)

' ────────────────────
Function chomp(somestring)
if len(somestring) >= 1 then 
  while  (asc(right(somestring,1)) <= 13 ) 
'this will eat vbTab chr(9) !!!  
  somestring = left(somestring, len(somestring)-1)
 wend 
end if 
chomp = somestring ' or trim(somestring) 'best used earlier
End Function

' ────────────────────
Function nibble(somestring) 
if len(somestring) >= 1 then 
 while  (asc(left(somestring,1)) <= 13 )  
  somestring = right(somestring, len(somestring)-1) 
 wend
end if
  nibble = somestring ' or trim(somestring)

End Function
' ────────────────────

 

vbCommon – illegal filename chars

' -- remove illegal filename characters - note VBS' dim is different than VBA's

' ─────────────
Function stripBadFileChars(somestring)
dim badchar, xyz 'As String in vba - not vbs

badchar = ":;\|/*?" & chr(34) & chr(26) & vbCrLf & vbTab

for xyz = 1 to len(badchar) 
   somestring = StripCharsFrom(somestring, mid(badchar,xyz,1), "_")
   somestring = replace(somestring, "__", "_")
next ' xyz
   somestring = replace(somestring, "__", "_")

   stripBadFileChars = somestring

End Function ' stripBadFilChars

' ─────────────

vbaCommon – GetEnv (Environment)

 

' ───────

Private Function getENV(strReturn As String)
  'Example ChDir getENV("userprofile") & "\Desktop\"
Dim EnvString, Indx, Msg, PathLen    ' Declare variables.
For Indx = 1 To Len(Environ(Indx)) + 2
    EnvString = Environ(Indx)  ' Get environment
    If UCase(Left(EnvString, Len(strReturn))) = UCase(strReturn) Then
      getENV = Mid(EnvString, Len(strReturn) + 2)
    End If
 Next Indx 'Loop Until EnvString = ""

End Function
' ───────

vbCommon – stripIllegalChars

Private Function stripIllegalChars(strTest As String)
Dim strTemp, testThis As String
Dim kount As Integer

strTemp = ""
strTest = Trim(strTest)
For kount = 1 To Len(strTest)
testThis = Mid(strTest, kount, 1)
If InStr(".|\/?*:<>' ", testThis) > 0 Or Asc(testThis) < 32 Or Asc(testThis) = 34 Or Asc(testThis) > 129 Then
 'strTemp = strTemp & "_"
 Else: strTemp = strTemp & Mid(strTest, kount, 1)
End If
Next kount
stripIllegalChars = IIf(Len(strTemp) < 1, "Missing_Subject" & Int(Rnd(1) * 1000), strTemp)
End Function
' ───────

Outlook – Backup Selected Items

' -- (Non)Functioning Example to demonstrate built-in Outlook *email objects* 
' -- DO NOT RUN without SAFETY test for your target environment and version
' -- requires prior creation of target email folders and CONSTANTS

Const TARGETPATH = "\My Documents\CONSTANTNAME\xEmailArchive\"

Option Explicit
'  ' SUPPLEMENT TO native AUTO ARCHIVE - saves to pre-set folder '  '  '  '  
' ───────
Sub SaveAttachmentsToFolder()
' checks selected messages with attachments
' of a specific type (here file with an "xls" extension) ' and saves them to disk. Saved files are timestamped. The user
' can choose to view the saved files in Windows Explorer.
    On Error GoTo SaveAttachmentsToFolder_err

    Dim myItem As Outlook.Inspector  ' objects from a MicSoft sample routine
    Dim myOlExp As Outlook.Explorer  
    Dim myOlSel As Outlook.Selection 

    Dim ns As NameSpace
          Set ns = GetNamespace("MAPI")
    Dim Inbox As MAPIFolder
        Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    Dim SubFolder As MAPIFolder ' not used
    Dim Item As Object
    
    Dim Atmt As Attachment
    Dim FileName, strSaveToPath As String
    Dim x, i As Integer
    Dim varResponse As VbMsgBoxResult
                'below set statements were for hard coded target email folders
                'Set SubFolder = Inbox.Folders("Sales Reports") ' Enter correct subfolder name.
                'Set myOlSel = Inbox.Folders("Sales Reports") ' Enter correct subfolder name.
                    'For x = 1 To myOlSel.Count 'added
    
    strSaveToPath = getENV("USERPROFILE") & TARGETPATH  'MUST HAVE TRAILING SLASH
    'strSaveToPath = getENV("HOMEPATH") & "\My Documents\TEMP\"
    Set myItem = Application.ActiveInspector
    Set myOlExp = Application.ActiveExplorer
    Set myOlSel = myOlExp.Selection

''''''''''''''
For x = 1 To myOlSel.Count
  
    'For Each Item In myOlSel.Items ''replaced by net for each
      myOlSel.Item(x).Display
        For Each Atmt In myOlSel.Item(x).Attachments
        ' strname = stripIllegalChars(myOlSel.Item(x).Subject)
        ' save if filename has "xls" extension             ' If Right(Atmt.FileName, 3) = "xls" Then
            ' This path must exist! Change folder name as necessary.
            'if debugflag then  MsgBox strSaveToPath & "\" & Atmt.FileName
                FileName = strSaveToPath & _
                 Format(myOlSel.Item(x).CreationTime, "yyyymmdd_hhnnss_") & Atmt.FileName ' & stripIllegalChars(Atmt.FileName) & ".xyz"
                 '   Format(Item.CreationTime, "yyyymmdd_hhnnss_") & Atmt.FileName
                Atmt.SaveAsFile FileName
'
            'End If
        Next Atmt
     myOlSel.Item(x).Close olPromptForSave
    Next x
' Show summary message
  i = myOlSel.Count
    If i > 0 Then
        varResponse = MsgBox("I found " & i & " attached files." _
        & vbCrLf & "I have saved them into the " & strSaveToPath & "." _
        & vbCrLf & vbCrLf & "Would you like to view the files now?" _
        , vbQuestion + vbYesNo, "Finished!")
' Open Windows Explorer to display saved files if user chooses
        If varResponse = vbYes Then '
        '    Shell "Explorer.exe /e,C:\Email Attachments", vbNormalFocus
             Shell "Explorer.exe /e," & strSaveToPath, vbNormalFocus
        End If
    Else
        MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!"
    End If
' Clear memory
SaveAttachmentsToFolder_exit:
    Set Atmt = Nothing
    Set Item = Nothing
    Set ns = Nothing
    Exit Sub
' Handle Errors
SaveAttachmentsToFolder_err:
    MsgBox "An unexpected error has occurred." _
        & vbCrLf & "Please note and report the following information." _
        & vbCrLf & "Macro Name: GetAttachments" _
        & vbCrLf & "Error Number: " & Err.Number _
        & vbCrLf & CONSTANT_FULL_NAME_and_EMAIL ' "Joe Xplsknik - joex@utestme.com" _
        & vbCrLf & "Error Description: " & Err.Description _
        , vbCritical, "Error!"
    Resume SaveAttachmentsToFolder_exit
End Sub

' ───────
Sub SaveSelectedAsHTML()
    Dim myItem As Outlook.Inspector
    Dim myOlExp As Outlook.Explorer  '
    Dim myOlSel As Outlook.Selection '
    Dim objItem As Object
    Dim strname, strSaveToPath As String
    Dim x As Integer
    strSaveToPath = getENV("USERPROFILE") & "\Desktop\"
    strSaveToPath = getENV("HOMEPATH") & "\My Documents\CONSTANTNAME\xEmailArchive\"
        
    Set myItem = Application.ActiveInspector
    Set myOlExp = Application.ActiveExplorer
    Set myOlSel = myOlExp.Selection
    
    If Not TypeName(myOlExp) = "Nothing" Then
'        Set objItem = myOlExp.CurrentItem
'        strname = stripIllegalChars(objItem.Subject)
        'Prompt the user for confirmation
        Dim strPrompt As String
        strPrompt = IIf(myOlSel.Count = 1, myOlSel.Count & " Selected Item", myOlSel.Count & " Selected Items")
        strPrompt = strPrompt & " will be saved to " & vbCrLf & strSaveToPath & vbCrLf & _
        "Any files with the same name will be OVERWRITTEN."
        If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then
            'objItem.SaveAs Environ("HOMEPATH") & "\My Documents\" & strname & ".txt", olTXT

    For x = 1 To myOlSel.Count
    On Error GoTo FileError
'  strname = stripIllegalChars(myOlSel.Item(x).Subject)
'  strname = stripIllegalChars(myOlSel.Item(x).SenderEmailAddress & myOlSel.Item(x).Subject)
    strname = stripIllegalChars(myOlSel.Item(x).SenderName)   'SenderName  SenderEmailAddress
    strname = strname & "_" & stripIllegalChars(myOlSel.Item(x).Subject)
    strname = strname & "_" & Format(myOlSel.Item(x).CreationTime, "yyyymmdd_hhnnss")
              
            'MsgTxt = MsgTxt & vbCrLf & myOlSel.Item(x).SenderName & ";"
            'objItem.SaveAs Environ("USERPROFILE") & "\Desktop\" & strname & ".txt", olTXT
                    myOlSel.Item(x).Display
                    myOlSel.Item(x).SaveAs strSaveToPath & strname & ".htm", olHTML 'olMSGUnicode olTXT
            'The file type to save. Can be one of the following OlSaveAsType constants:
            ' olHTML, olMSG, olRTF, olTemplate, olDoc, olTXT, olVCal, olVCard, olICal, or olMSGUnicode.
                    
              myOlSel.Item(x).Close olPromptForSave  ' olSave olDiscard either has no effect if NOT changed
            '  myFolder.Items(1).Display

               'Set myinspector = Application.ActiveInspector
               'Set myItem = myinspector.CurrentItem
                                'myItem.Close olSave
    Next x          
    End If
    Else
        MsgBox "There is no current active Explorer."
    End If
    Exit Sub
FileError:
    MsgBox "Error: (Likely " & strSaveToPath & " does not exist!)" _
        & vbCrLf & "Please note and report the following information." _
        & vbCrLf & "Macro Name: SaveSelectedAsHTML" _
        & vbCrLf & "Error Number: " & Err.Number _
 & vbCrLf & CONSTANT_FULL_NAME_and_EMAIL & _ ' "Joe Xplsknik - joex@utestme.com" _
        & vbCrLf & "Error Description: " & Err.Description _
        , vbCritical, "Error!"
    'Resume 'SaveAttachmentsToFolder_exit
    
    
End Sub
' ───────
Sub SaveSelectedAsTXT()
    Dim myItem As Outlook.Inspector
    Dim myOlExp As Outlook.Explorer  '
    Dim myOlSel As Outlook.Selection '
    Dim objItem As Object
    Dim strname, strSaveToPath As String
    Dim x As Integer
    'strSaveToPath = getENV("USERPROFILE") & "\Desktop\"
    'strSaveToPath = getENV("HOMEPATH") & "\My Documents\CONSTANTNAME\xEmailArchive\"
    strSaveToPath = getENV("USERPROFILE") & "\My Documents\CONSTANTNAME\xEmailArchive\"
        
    On Error GoTo FileError

    Set myItem = Application.ActiveInspector
    Set myOlExp = Application.ActiveExplorer
    Set myOlSel = myOlExp.Selection
    
    If Not TypeName(myOlExp) = "Nothing" Then
'        Set objItem = myOlExp.CurrentItem
'        strname = stripIllegalChars(objItem.Subject)
        'Prompt the user for confirmation
        Dim strPrompt As String
        strPrompt = IIf(myOlSel.Count = 1, myOlSel.Count & " Selected Item", myOlSel.Count & " Selected Items")
        strPrompt = strPrompt & " will be saved to " & vbCrLf & strSaveToPath & vbCrLf & _
        "Any files with the same name will be OVERWRITTEN."
        If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then
            'objItem.SaveAs Environ("HOMEPATH") & "\My Documents\" & strname & ".txt", olTXT
              
    For x = 1 To myOlSel.Count
    strname = stripIllegalChars(myOlSel.Item(x).SenderName)   'SenderName  SenderEmailAddress
    strname = strname & "_" & stripIllegalChars(myOlSel.Item(x).Subject)
    strname = strname & "_" & Format(myOlSel.Item(x).CreationTime, "yyyymmdd_hhnnss") & Int(Rnd(1) * 1000)
       'strname = stripIllegalChars(myOlSel.Item(x).Subject)
                    'MsgTxt = MsgTxt & vbCrLf & myOlSel.Item(x).SenderName & ";"
                     'objItem.SaveAs Environ("USERPROFILE") & "\Desktop\" & strname & ".txt", olTXT
                    myOlSel.Item(x).Display
                    myOlSel.Item(x).SaveAs strSaveToPath & strname & ".txt", olTXT
                    'The file type to save. Can be one of the following OlSaveAsType constants:
                    '  olHTML, olMSG, olRTF, olTemplate, olDoc, olTXT, olVCal, olVCard, olICal, or olMSGUnicode.
                    
                    myOlSel.Item(x).Close olPromptForSave  ' olSave olDiscard either has no effect if NOT changed
                     '  myFolder.Items(1).Display

           'Set myinspector = Application.ActiveInspector
           'Set myItem = myinspector.CurrentItem
           'myItem.Close olSave
                    
    Next x
           
    End If
    Else
        MsgBox "There is no current active Explorer."
    End If
    Exit Sub

FileError:
    MsgBox "Error: (Likely " & strSaveToPath & " does not exist!)" _
        & vbCrLf & "Please note the following information." _
        & vbCrLf & "Macro Name: SaveSelectedAsTXT" _
        & vbCrLf & "Error Number: " & Err.Number _
        & vbCrLf & CONSTANT_FULL_NAME_and_EMAIL & _' redundant - see above
        & vbCrLf & "Error Description: " & Err.Description _
        , vbCritical, "Error!"
    'Resume 'SaveAttachmentsToFolder_exit
        
    
End Sub
' ───────

Private Function getENV(strReturn As String)
  'CALLED BY ChDir getENV("userprofile") & "\Desktop\"
Dim EnvString, Indx, Msg, PathLen    ' Declare variables.
Indx = 1    ' Initialize index to 1.
For Indx = 1 To Len(Environ(Indx)) + 2
    EnvString = Environ(Indx)    ' Get environment
    If UCase(Left(EnvString, Len(strReturn))) = UCase(strReturn) Then
      getENV = Mid(EnvString, Len(strReturn) + 2)
    End If
 Next Indx 'Loop Until EnvString = ""

End Function
' ───────
Private Function stripIllegalChars(strTest As String)
Dim strTemp, testThis As String
Dim kount As Integer

strTemp = ""
strTest = Trim(strTest)
For kount = 1 To Len(strTest)
testThis = Mid(strTest, kount, 1)
If InStr(".|\/?*:<>' ", testThis) > 0 Or Asc(testThis) < 32 Or Asc(testThis) = 34 Or Asc(testThis) > 129 Then
 'strTemp = strTemp & "_"
 Else: strTemp = strTemp & Mid(strTest, kount, 1)
End If
Next kount
stripIllegalChars = IIf(Len(strTemp) < 1, "Missing_Subject" & Int(Rnd(1) * 1000), strTemp)
End Function
' ───────

Sub SetFlagIcon()
    Dim mpfInbox As Outlook.Folder
    Dim obj As Outlook.MailItem
    Dim i As Integer
    
    Set mpfInbox = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("Test")
    ' Loop all items in the Inbox\Test Folder
    For i = 1 To mpfInbox.Items.Count
        If mpfInbox.Items(i).Class = olMail Then
            Set obj = mpfInbox.Items.Item(i)
            If obj.SenderEmailAddress = "someone@example.com" Then
                'Set the yellow flag icon
                obj.FlagIcon = olYellowFlagIcon
                obj.Save
            End If
         End If
    Next
End Sub
' ───────