RECORD vba to install to SendTo (Or shell extension)

 

"RECORD"  VBA for COPY or MOVE to RECORD\yyyy-mm-ddthhmm-descript folder

• Basic: (Files)
• Right click file(s)
• dialog
• Use oldest date, newest date or time right now (Command line switches too - bypass dialog - inform of malformed switches)
• Move or Copy (command line switches for direct shortcuts can be create to MOVE or COPY bypass dialog- inform of malformed switches)
• /LeaveCopy switch to NOT strip Copy (#) of copies - will strip by default! (Or ask?)
• Advanced: (Later - folders and subfolders)
• Works with RECORD as SUBFOLDER of current file folder content.
• Advanced version to allow for packing of entire regimented subfolders for PDF orDWG/RVT/SKP/etc. content into packages or backups

In Progress: 2020-01-02:

Attribute VB_Name = "vbs_RECORD_FOLDER" Option Explicit ''Require definiton of all variables Option Compare Text ''Set default compre method to text ''Note shortcut to add args must be formatted: ''C:\Windows\System32\wscript.exe "C:\Users\ron.allen\Desktop\Record Folder.vbs" /suffix SnapShot ''otherwise arcuments will not show up ''https://stackoverflow.com/questions/22029519/how-to-call-vbscript-from-cmd-exe-and-pass-parameters Public Wscript As New objWSCRIPT_Emulator Dim GobjFSO ''As GLOBAL FileSystemObject Dim GstrSuffix ''"/textsuffix" ''as GLOBAL String name suffixm next word is suffix Dim GstrPrefix ''"/textprefix" ''as GLOBAL String name suffixm next word is suffix Dim GDatePrefix ''"/dateprefix" ''Global Apply date prefix Parametr Dim GDateSuffix ''"/datesuffix" ''Global Apply date suffix Parametr Dim GTime ''"/time" ''add TIME to the date "t2359UTC" Dim strMsg ''String message for junk and reporting Dim GDate ''-1 = oldest from file, 0=cur date/time, 1=Newest from file Dim UTC ''UTC Time offset from current tim e- show all time in UTC to ignore timezone ''============================================================================= 'Main ''============================================================================= Sub Main() '''Global Argument presets GDatePrefix = False ''GDAte prefix - add date as prefix GDateSuffix = False ''Add date as ssuffix GTime = False ''add gtime, FALSE = no GDate = -99 ''unset value for date preference UTC = Get_UTC() ''Offset in year.time CDBL format - add to time to get UTC ''LOCAL Arguments Dim objargs ''for wscript arguments Dim Arg ''current argument Dim i, x ''i counter and X for split Dim DoFileCheck ''after switches found skip file check Dim FP 'File Path Dim FN_count, FP_Count 'File Name count and File Path Count

Dim FN_Dict As Dictionary ''Folder collection //Future use Dim FP_Dict ''As Dictionary ''Filename collection Set FN_Dict = CreateObject("Scripting.Dictionary") ''filename = file Set FP_Dict = CreateObject("Scripting.Dictionary") ''file path = folder FN_Dict.CompareMode = TextCompare FP_Dict.CompareMode = TextCompare ''LocalArguments presets FN_count = 0 FP_Count = 0 Set GobjFSO = CreateObject("Scripting.FileSystemObject") Set objargs = Wscript.Arguments ''MsgBox "Args count: " & objargs.Count ''debug ARGS count For i = 0 To objargs.Count - 1 DoFileCheck = False ''set filecheck to false so it will run Arg = "": Arg = objargs.item(i) ''Current argument 'MsgBox Arg ''DEBUG Select Case LCase(Arg) ''//SPECIFIED DATE TIME TO USE Case "/newest" ''Use most recent file date If GDate = -99 Then GDate = 1 Else GDateMsgAdd Arg ''add error message for gdate End If Case "/oldest" ''Use oldest file date time If GDate = -99 Then GDate = -1 Else GDateMsgAdd Arg ''add error message for gdate End If Case "/current" ''Use oldest file date time If GDate = -99 Then GDate = 0 Else GDateMsgAdd Arg ''add error message for gdate End If Case "/time" ''Add TIME to the date "t2359UTC" GTime = True Case "/datesuffix" ''Add date as suffix T/F GDateSuffix = True Case "/dateprefix" ''Add date as prefix T/F GDatePrefix = True Case Else DoFileCheck = True ''If not a switch run a file/folder check it End Select '''Looking for compound arguments switches like /filesuffix=somevalue, use 2nd part to set 3rd value ''NOTE: If called with no value- Input box prompts for value If DoFileCheck And InStr(1, Arg, "=") > 0 Then DoFileCheck = Not CompoundArg(Arg, "/filesuffix=", GstrSuffix) If DoFileCheck And InStr(1, Arg, "=") > 0 Then DoFileCheck = Not CompoundArg(Arg, "/fileprefix=", GstrPrefix) 'If DoFileCheck And InStr(1, Arg, "=") > 0 Then DoFileCheck = Not CompoundArg(Arg, "/datesuffix=", GDatePrefix) 'If DoFileCheck And InStr(1, Arg, "=") > 0 Then DoFileCheck = Not CompoundArg(Arg, "/dateprefix=", GDateSuffix) If DoFileCheck Then 'If GobjFSO.FolderExists(objargs.item(i)) Then ' FP_Dict.Add objargs.item(i), objargs.item(i) ' FP_Count = FP_Count + 1 ' ''handle folders later - will move entire folder to date RECORD\yyyymmdd folder name 'End If If GobjFSO.FileExists(objargs.item(i)) Then FN_Dict.Add objargs.item(i), objargs.item(i) FN_count = FN_count + 1 Else strMsg = strMsg & "NotFound: " & objargs.item(i) & vbCr End If End If ''lcase /name Next RecordFilesCopy FN_Dict ''FP Dict of files to move ''RecordFolderCopy FP_Dict ''Future ''Check newest file & Ask for date if date specified End Sub ''compoundArguments Function CompoundArg(ByVal Arg As String, ByVal strKey As String, ByRef ParamAssignValue) As Boolean strKey = LCase(strKey) If ParamAssignValue > "" Then strMsg = strMsg & "Already defined: " & strKey & vbCr ElseIf LCase(left(Arg, Len(strKey))) = strKey Then ParamAssignValue = StrClean(Right(Arg, Len(Arg) - Len(strKey)), "", "") If ParamAssignValue = "" Then ParamAssignValue = StrClean(InputBox("Enter a value for " & strKey, "Text input specified", ""), "", "") End If CompoundArg = True End If End Function ''============================================================================= Sub RecordFilesCopy(ByRef FN_Dict) 'As Dictionary) Dim objdic ''For For Each Dim objFile As File ''LIVE Object file for retrieving data Dim dDate 'As Date '' Dim StrNewname ''string holder for new filename Dim strdate ''formatted string version of date Dim FP, FN, ext 'filepath+name to start, filenmae, extension ''NOTE IF IN RECORD FOLDER act as restore with question - are you sure you want to do this? ''Regex types ''removes 'copy'''(1=fp)(2=fn)(3='copy'''''''''''''''')(4=fn) Const REG_COPY = "(.*\\){0,1}(.+?)(\W{0,}\-\W{0,}Copy\W{0,}\()(\d{1,}){0,1}" ''removes copy'''''''''''''(1=fp)(2=fn)'''''''''''''''''''''''(2=fn) Const REG_FP_FN_SWDT_COPY = "(.*\\){0,1}(.+?)(?:\W{0,}(\d{4}\-\d{2}\-\d{2}|\d{4}\-\d{2}\-\d{2}[tT\-_]\d{4}[AaPp]{0,1}?)){0,1}\W{0,}\-\W{0,}Copy(?:\W{0,1}\((\d{1,})\)){0,1}" ''Initial Check for prefs to make sure something gets changed.... For Each objdic In FN_Dict Set objFile = Nothing Set objFile = GobjFSO.GetFile(objdic) ''DATE Spcified in UTC time <<<<<<<<<<<<<<<<<<<<<<---------Date in UTC time using offset dDate = objFile.DateLastModified + UTC strdate = strDateFormat(dDate, UTC) On Error GoTo 0 StrNewname = "" ''initialize new name If GstrPrefix > "" Then ''STRING PREFIX if applies If StrNewname > "" Then StrNewname = StrNewname & "-" ''add Dash if additional naming in play StrNewname = StrNewname & GstrPrefix ''Prefix End If If GDatePrefix Then ''Date as prefix AFTER prefix if exists i.e. RFI, ASI,2020-01-01... etc. If StrNewname > "" Then StrNewname = StrNewname & "-" ''add Dash if additional naming in play StrNewname = StrNewname & strdate End If If StrNewname > "" Then StrNewname = StrNewname & "-" ''add Dash if additional naming in play FP = objFile.Path getVBSinfo FP, FN, ext ''Split path to parts FN = StrClean(objFile.Path, REG_FP_FN_SWDT_COPY, "$2") ''cleanup filename ''remove copy(*) StrNewname = StrNewname & FN If GstrSuffix > "" Then ''STRING PREFIX if applies If StrNewname > "" Then StrNewname = StrNewname & "-" ''add Dash if additional naming in play StrNewname = StrNewname & GstrSuffix ''Suffix End If If GDateSuffix Then ''Date as prefix AFTER prefix if exists i.e. RFI, ASI,2020-01-01... etc. If StrNewname > "" Then StrNewname = StrNewname & "-" ''add Dash if additional naming in play StrNewname = StrNewname & strdate End If StrNewname = StrClean( _ StrNewname, "[^a-zA-Z0-9\.()]", "-") ''Clean out all but A-Z, numbers, parenthesis and "." StrNewname = StrClean( _ StrNewname, "\.", "_") ''Replace "." with "_" StrNewname = StrNewname & ext MsgBox StrNewname ''GobjFSO.CopyFile (objdic)'''<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<ACTION LINE COMMENTED OUT Next ''objdic End Sub Function strDateFormat(dDate, UTC) Dim yyyy, dd, mm, hh, nn, ap ''date-time derivatives yyyy = Year(dDate) mm = Right("0" & Month(dDate), 2) dd = Right("0" & Day(dDate), 2) hh = Right("0" & Hour(dDate), 2) nn = Right("0" & Minute(dDate), 2) If hh > 12 Then ap = "P" Else ap = "A" strDateFormat = yyyy & "-" & mm & "-" & dd & "-" & hh & nn & ap & UTC If UTC <> 0 Then strDateFormat = strDateFormat & "UTC" End Function Sub test_getVBSinfo() Dim FP, FN, ext 'fp = wscript.ScriptFullName FP = "c:\temp\foo" getVBSinfo FP, FN, ext End Sub Function StrClean(strSource, strPattern, strReplace) 'As String If strPattern = "" Then strPattern = "[^a-zA-Z0-9()_]" If strReplace = "" Then strReplace = "-" Dim objRegex As New RegExp '' - Regular Expression Dim result 'As String - for replce result Dim allMatches 'As Object - for all matches object Set objRegex = CreateObject("vbscript.REGEXP") objRegex.Pattern = strPattern objRegex.Global = True objRegex.IgnoreCase = True Set allMatches = objRegex.Execute(strSource) StrClean = objRegex.Replace(strSource, strReplace) End Function ''Use ByRef to get these variables filled on way back from the call of this sub Sub getVBSinfo(ByRef vbsFP, ByRef vbsFN, ByRef ext) ''FP comes in as FP+FN returns vbsFP for filepath and vbsFN File Name Dim GobjFSO 'As FileSystemObject Dim objFile 'As File Dim strFolder 'As String Dim x '(For split) Set GobjFSO = CreateObject("Scripting.FileSystemObject") 'MsgBox "vbsFP: " & vbsFP Set objFile = GobjFSO.GetFile(vbsFP) strFolder = GobjFSO.GetParentFolderName(objFile) On Error Resume Next vbsFN = objFile.Name vbsFP = objFile.ParentFolder ''extensions are eerything after the last "." in the file name, ''if there is not "." in the file name then there is no exxtension x = Split(vbsFN, ".") If UBound(x) > 0 Then ext = "." & x(UBound(x)) ''get extension 'As l'Ast after "." Else ext = "" End If vbsFN = left(vbsFN, Len(vbsFN) - Len(ext)) ''creating text file by wscript name to save dropped arguments ''Set objFileStream = GobjFSO.CreateTextFile(strFolder & "\" & strname & ".txt", True) ''Outdide loop for wscript arguments End Sub ''' Sub GDateMsgAdd(strTag) If GDate = -1 Then strMsg = strMsg & "Error: " & strTag & " - /Oldest file date alredy specified" ElseIf GDate = 1 Then strMsg = strMsg & "Error: " & strTag & " - /Newest file date alredy specified" ElseIf GDate = 0 Then strMsg = strMsg & "Error: " & strTag & " - /Current Execute date alredy specified" End If End Sub Function Get_UTC(Optional DateTime = 0) ''as double '' Returns value to add to current time to get to UTC ''Based on above functions : ) ''return offset from current time to UTC ''https://stackoverflow.com/questions/15887700/utc-time-assignment-in-vbscript/22842128 Dim SWDT ''As SWbemDateTime Dim dt ''As Date Set SWDT = CreateObject("WbemScripting.SWbemDateTime") dt = Date + Time() SWDT.SetVarDate (dt) Get_UTC = CDbl(SWDT.GetVarDate(False)) - CDbl(SWDT.GetVarDate(True)) Get_UTC = CDbl(Round(Get_UTC * 24 * 60 * 60, 0) / 24 / 60 / 60) Get_UTC = DateTime + Get_UTC End Function