Copy selected files from column to prompted directory. Then make read only -r

[Mitch_McComb]

Hi everyone,

I'm a newbie when it comes to vba and macros.
I'm hoping there is a simple solution to what we're trying to accomplish.
It sounds simple enough =-)

I have a spreadsheet that contains a running list of files.
Column F contains the name of the file.
Column M contains the file path of it's location.
Column N contains a text string that relates to different casses.

Each case we have in place does seperate things. Case E will copy selected excel files to a specified directory, then open the file. Case TW will copy the selected word files to a temp directory and open the files. These work great but only work for the specified file types.

The goal is to have any files selected in column F (.doc, .xls, .pdf, .tif, .etc...) to be copied from the file path in column M to a specified file path given by the user. Then have all files marked as "not read only".

Here is a copy of our current code.
I'm not familiar with the macro sources, but I know some are supplied from misc. websites and have password protection.

I thought I could use filecopy to assign the what and where, but are not having any luck. Am I chasing dreams here or is this possible. I'm already 16 hours into trying to solve it. Always feel like I'm close.

Below is the current code without any of my updates.

Thank you very much for the help!

'Option Explicit
Sub loopit()
'8/30/04
'2/23/05
'8/25/06      added user name to C:/temp files so others running on terminal services don't have permission
'             problem trying to overwright the same filename
'11/15/07     fixed problem if there is a blank in the username, strip out the blank
'7/26/08      added EW and EX options to edit master files
'user selects cells in column F that he wants to run (executable programs)
'or copy to a user-selected directory and open (excel files)
'or find and run (web based program);
'macro then loops thru each selected program
'excel files are copied to user selected directory and left open for use;
'if the filename already exists, the user is prompted for another save name
'TX option copies excel file to c:/temp and opens the copy
'TW option copies word file to c:/temp and opens the copy
'column M of the TE Tools file lists the pathname where the master spreadsheet
'or executable file is located;  column N tells where it is an excel file,
'proprietary (executable) file, downloadable installation file, or web-based program
Dim RunCopy(), ProgName(), Path, Dirname, Ans, Msg, MasterPathName, Master_Filename, Filecopy, Fileopen, kstring As String
Dim NumCells, i, k, num, RetVal, colnum As Integer
NumCells = Selection.Cells.Count
Dirname = "firsttime"
ReDim RunCopy(NumCells), ProgName(NumCells)
num = 1
    For Each cell In Selection
        colnum = cell.Column
        If colnum <> 6 Then     'change this value to column number to be selected
            MsgBox "You selected cells not in Column F"
            GoTo 1000
        End If
        ProgName(num) = cell.Offset(0, 7).Value     'program name with path
        RunCopy(num) = cell.Offset(0, 8).Value      'has value of P,E,H,W,B,TW,TX
        num = num + 1
    Next cell
 
    For k = 1 To NumCells
        Select Case RunCopy(k)
            Case "E"                                    'excel files that get copied, then opened
                On Error GoTo nofile
                If Dirname = "firsttime" Then           'only calls 1st time thru
                    Call Ask_for_Dirname(Dirname)
                    If Dirname = "" Then GoTo 1000      'stops if no name is supplied
                End If
                Workbooks.Open Filename:=ProgName(k)    'open the master file
                ChDir Dirname
                On Error GoTo closefile                 '[if this is activated, macro will overwrite existing files]
                Master_Filename = ActiveWorkbook.Name   'file name, no path
                MasterPathName = Dirname & "\" & Master_Filename
                If Dir(MasterPathName) = "" Then     'check if file exists in target directory
                    ActiveWorkbook.SaveAs Filename:=MasterPathName, FileFormat:= _
                    xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
                    , CreateBackup:=True
                Else
                Application.DisplayAlerts = False      'suppresses warning messages from saveas
                'filename already exists, save under different name
                    Msg = "File name already exists.  Select same name to overwrite or enter new filename"
                    newname = Application.GetSaveAsFilename(Master_Filename, "Excel Files (*.xls), *.xls", 1, Msg)
                    ActiveWorkbook.SaveAs Filename:=newname, FileFormat:= _
                    xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
                    , CreateBackup:=True
                Application.DisplayAlerts = True       'allows warning messages
                End If
                GoTo end_of_loop
closefile:
                Application.DisplayAlerts = False      'suppresses warning messages
                MsgBox "Copy of master file not made"
                ActiveWorkbook.Close
                Application.DisplayAlerts = True       'allows warning messages
                GoTo end_of_loop
nofile:
                config = vbYesNo
                Msg = "The master file you want to copy could not be found"
                Msg = Msg & Chr(13) & "OK to go to next selection?"
                Ans = MsgBox(Msg, config)
                If Ans = vbYes Then GoTo end_of_loop
                If Ans = vbNo Then GoTo 1000
end_of_loop:
 
            Case "P"                                   'executable file
                If Dir(ProgName(k)) <> "" Then         'check if executable file exists
                    RetVal = Shell(ProgName(k), vbNormalFocus)
                Else
                    MsgBox "Program " & ProgName(k) & " could not be found"
                End If
 
            Case "W"                                   'web program or PDF
                ActiveWorkbook.FollowHyperlink Address:=ProgName(k), NewWindow:=True
 
 
            Case "H"                                   'palm program
                MsgBox "This is a PDA program, can't run from network"
 
 
            Case "B"                                   'basic program
                MsgBox "This is a Microsoft Basic program, this macro not set up to run it"
 
 
            Case "D"                                   'copy a downloaded file to local drive and extract files
                If Dir(ProgName(k)) <> "" Then                                                     'check if file exists in target directory
                    Set obj_1 = CreateObject("Scripting.FileSystemObject")
                    'if target file already exists it will be overwritten
                    obj_1.CopyFile ProgName(k), "c:\temp\", True
                    Set obj_1 = Nothing
                    MsgBox "This program cannot run from the network.  The master program file has been copied to your C:\Temp directory.  You must extract the contents to a directory on your C: drive and then run the program from that directory."
                Else
                    MsgBox "File you are trying to copy does not exist"
                End If
 
            Case "TW"                                   'copy the target word file to
                                                        'c:\temp\ directory and open with Word
                                                        'can handle multiple files, files are not deleted when done
                If Dir(ProgName(k)) <> "" Then                                                       'check if master file exists
                    Set obj_1 = CreateObject("Scripting.FileSystemObject")
                    kstring = CStr(k)                                                                       'convert k to a string
                    userstring = Application.UserName                                             'adds users name to the filename to get around permissions issue
                    userstring = Application.Substitute(userstring, " ", "")                   'strips blanks from username
                    Filecopy = "c:\temp\temp" & userstring & kstring & ".doc"
                    obj_1.CopyFile ProgName(k), Filecopy, True                               'copy progname to filecopy, if target file already exists it will be overwritten
                    Set obj_1 = Nothing
                    Fileopen = "winword " & Filecopy                                               'create "winword c:\temp\____" command
                    RetVal = Shell(Fileopen, 1)                                                        'open Filecopy file in c:\temp with Word
                Else
                    MsgBox "Program " & ProgName(k) & " could not be found"
                End If
 
            Case "TX"                                    'copy the target excel file to
                                                         'c:\temp\ directory and open with excel
                                                         'can handle multiple files, files are not deleted when done
                If Dir(ProgName(k)) <> "" Then                                                        'check if master file exists
                    Set obj_1 = CreateObject("Scripting.FileSystemObject")
                    kstring = CStr(k)                                                                        'convert k to a string
                    userstring = Application.UserName                                              'adds users name to the filename to get around permissions issue
                    userstring = Application.Substitute(userstring, " ", "")                    'strips blanks from username
                    Filecopy = "c:\temp\temp" & userstring & kstring & ".xls"
                    obj_1.CopyFile ProgName(k), Filecopy, True                                'copy progname to filecopy, if target file already exists it will be overwritten
                    Set obj_1 = Nothing
                    Fileopen = "excel " & Filecopy                                                    'create "excel c:\temp\____" command
                    RetVal = Shell(Fileopen, 1)                                                         'open Filecopy file in c:\temp with excel
                Else
                    MsgBox "Program " & ProgName(k) & " could not be found"
                End If
 
            Case "EX"                                     'edit the master excel file
                If Dir(ProgName(k)) <> "" Then
                    Set excelapp = CreateObject("excel.application")
                    excelapp.Workbooks.Open (ProgName(k))
                    excelapp.Visible = True
 
                'If Dir(ProgName(k)) <> "" Then                                                        'check if master file exists
                '    Fileopen = "excel " & ProgName(k)                                             'create "excel progname(k)" command
                '         config = vbYesNo
                '         Msg = "You are about to edit a master file, not a copy"
                '         Msg = Msg & Chr(13) & "OK to continue?"
                '         Ans = MsgBox(Msg, config)
                '         If Ans = vbYes Then GoTo end_of_loop1
                '         If Ans = vbNo Then GoTo 1000
'end_of_loop1:
                '    RetVal = Shell(Fileopen, 1)                                                         'open file
                Else
                    MsgBox "Program " & ProgName(k) & " could not be found"
                End If
 
 
            Case "EW"                                    'edit the master word file
                If Dir(ProgName(k)) <> "" Then
                    Set wordapp = CreateObject("word.application")
                    wordapp.documents.Open (ProgName(k))
                    wordapp.Visible = True
 
 
                'If Dir(ProgName(k)) <> "" Then                                                        'check if master file exists
                '    Fileopen = "winword " & ProgName(k)                                         'create "winword progname(k)" command
                '         config = vbYesNo
                '         Msg = "You are about to edit a master file, not a copy"
                '         Msg = Msg & Chr(13) & "OK to continue?"
                '         Ans = MsgBox(Msg, config)
                '         If Ans = vbYes Then GoTo end_of_loop2
                '         If Ans = vbNo Then GoTo 1000
'end_of_loop2:
                '    RetVal = Shell(Fileopen, 1)                                                         'open file
                Else
                    MsgBox "Program " & ProgName(k) & " could not be found"
                End If
 
 
            Case "XGD"                                   'copy the target files to the specified directory, then turn off read-only attribute
 
                If Dirname = "firsttime" Then           'only calls 1st time thru
                    Call Ask_for_Dirname(Dirname)
                    If Dirname = "" Then GoTo 1000      'stops if no name is supplied
                End If
 
                If Dir(ProgName(k)) <> "" Then                                                       'check if master file exists
                    'Set obj_1 = CreateObject("Scripting.FileSystemObject")
                    'obj_1.CopyFile ProgName(k), Dirname, True                'copy progname to Dirname, if target file already exists it will NOT be overwritten
                    'Set obj_1 = Nothing
                    batchfile = "[URL="file://\\TEIFS1\owner\gdtest\changepermiss.bat"]\\TEIFS1\owner\gdtest\changepermiss.bat[/URL]"
                    batchfile1 = "[URL="file://\\TEIFS1\owner\gdtest\changepermiss.bat"]\\TEIFS1\owner\gdtest\changepermiss.bat[/URL] " & ProgName(k) & " " & Dirname
                    If Dir(batchfile) <> "" Then         'check if executable file exists
                        RetVal = Shell(batchfile1, vbNormalFocus)
                    Else
                        MsgBox "Program " & batchfile & " could not be found"
                    End If
                Else
                    MsgBox "Program " & ProgName(k) & " could not be found"
                End If
 
 
 
 
 
 
 
 
 
 
            'this was a test case to try to copy files without overwriting existing files;
            'wanted to be able to also change the file from read-only to non-read-only
 
            Case "XGD1"
                                                       'copy the target word file to
                                                       'c:\temp\ directory and open with Word
                                                       'can handle multiple files, files are not deleted when done
                If Dir(ProgName(k)) <> "" Then         'check if master file exists
                    On Error GoTo file_exists          '[if this is activated, macro will not overwrite existing files]
                    Set obj_1 = CreateObject("Scripting.FileSystemObject")
                    kstring = CStr(k)                  'convert k to a string
                    Filecopy = "c:\temp\temp" & kstring & ".doc"
                    obj_1.CopyFile ProgName(k), Filecopy, False    'copy progname to filecopy, if target file already exists it will be overwritten
                    Set obj_1 = Nothing
                    Fileopen = "winword " & Filecopy   'create "winword c:\temp\____" command
                    RetVal = Shell(Fileopen, 1)        'open Filecopy file in c:\temp with Word
                  GoTo end_of_loop3
 
file_exists:
                    MsgBox "Program " & ProgName(k) & " already exists on the target drive and was not overwritten"
end_of_loop3:
                Else
                    MsgBox "Program " & ProgName(k) & " could not be found"
                End If
 
 
 
         End Select
 
    Next k
1000:
End Sub
 
Sub closeit()
    ActiveWorkbook.Close (False)
End Sub
 
Sub foobar()
'this was a test to create a batch file and run it
'works fine if you execute the batch file it creates but doesn't seem to work in the macro
'unless you step thru it
'
var_file_name = "foobar.bat"
var_file_path = "c:\temp\"
'\\TEIFS1\Engineer\Mechanical Programs\ARMSTRON\ARMTRAP2\hdcyn.exe
Const ForReading = 1, ForWriting = 2
Const TristateUseDefault = -2
Set obj_level_1 = CreateObject("Scripting.FileSystemObject")
'create file, overwriting if one already exists
Set obj_level_2 = obj_level_1.CreateTextFile(var_file_path & var_file_name, True)
Set obj_level_2 = obj_level_1.GetFile(var_file_path & var_file_name)
'write the .bat code
Set obj_level_3 = obj_level_2.OpenAsTextStream(ForWriting, TristateUseDefault)
obj_level_3.Writeline "@echo off"
obj_level_3.Writeline "cls"
obj_level_3.Writeline "n:"
obj_level_3.Writeline "cd \Mechanical Programs\ARMSTRON\ARMTRAP2"
obj_level_3.Writeline "cd"
obj_level_3.Writeline "pause"
obj_level_3.Writeline "call hdcyn.exe"
'echo Hello World"
obj_level_3.Writeline "pause"
obj_level_3.Close
'run the .bat file
var_null = Shell(var_file_path & var_file_name, vbNormalFocus)
'delete the .bat file
Kill (var_file_path & var_file_name)
Set obj_level_1 = Nothing
Set obj_level_2 = Nothing
Set obj_level_3 = Nothing
End Sub
'garbage stuff that didn't work
                    'Lenfile = Len(Dir(ProgName(k)))
                    'Lentotal = Len(ProgName(k))
                    'Directory_name = Left(ProgName(k), Lentotal - Lenfile - 1)
                    'ChDir Directory_name
                    'ChDir "N:\Mechanical Programs\ARMSTRON\PRV"
                    'xx = CurDir("N:\Mechanical Programs\ARMSTRON\PRV")
                    'Filename = Dir(ProgName(k))
                'RetVal = Shell("explorer " & ProgName(k), vbNormalFocus) this didn't work as well
                '(explorer was opened but it just blinked)