Want to protect your cyber security and still get fast solutions? Ask a secure question today.Go Premium

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 260
  • Last Modified:

script issue

Sems to be a problem with this.  I have FirstName(Cell A1) and LastName (Cell B1) and then list the names underneath but am getting a double dash for the first folder and it is only listing the next name then ignoring the rest?
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objShell = CreateObject("WScript.Shell")
strMyDocs = objShell.ExpandEnvironmentStrings("%USERPROFILE%") & "\My Documents"
strShortcutPath = "C:\1234.vbs"
 
'Create TFP folder
If objFSO.FolderExists(strMyDocs & "\TFP") = False Then objFSO.CreateFolder strMyDocs & "\TFP"
 
'Create Names.xls
If objFSO.FileExists(strMyDocs & "\TFP\names.xls") = False Then
	Set objExcel = CreateObject("Excel.Application")
	objExcel.Visible = True
	intSheetsInNewWB = objExcel.SheetsInNewWorkbook
	objExcel.SheetsInNewWorkbook = 1
	Set objWB = objExcel.Workbooks.Add
	objExcel.SheetsInNewWorkbook = intSheetsInNewWB
	Set objSheet = objWB.Sheets(1)
	objSheet.Rows("1:1").Font.Bold = True
	objSheet.Cells(1, "A") = "FirstName"
	objSheet.Cells(1, "B") = "LastName"
	objWB.SaveAs strMyDocs & "\TFP\names.xls"
End If
 
'Create Instructions.txt
If objFSO.FileExists(strMyDocs & "\TFP\Instructions.txt") = False Then
	Set objFile = objFSO.CreateTextFile(strMyDocs & "\TFP\Instructions.txt", True)
	objFile.Write "Please add your names to the Excel file called ""names"" and then click save and close the file.  Then click on the Create Folders Icon."
	objFile.Close
	Set objFile = Nothing
	objShell.Run "notepad """ & strMyDocs & "\TFP\Instructions.txt" & """", 1, False
End If
 
'Create Create Folders.lnk
If objFSO.FileExists(strMyDocs & "\TFP\Create Folders.lnk") = False Then
	' There may be a truncation issue with the shorcut path: See http://support.microsoft.com/kb/263324
	Set objShortcut = objShell.CreateShortcut(strMyDocs & "\TFP\Create Folders.lnk")
	objShortcut.TargetPath = strShortcutPath
	objShortcut.Save
	Set objShortcut = Nothing
End If
objShell.Run "explorer.exe /n, """ & strMyDocs & "\TFP""", 1, False
MsgBox "Done"

Open in new window

0
Dier02
Asked:
Dier02
  • 2
  • 2
2 Solutions
 
William ElliottSr Tech GuruCommented:
maybe i am misunderstanding,. what is the script not doing?
when first run it opens excel and instructions and creates a folder.
on the second run it just opens explorer again and says done.
everything in the script seems to be working.
0
 
RobSampsonCommented:
Hi, I believe you have posted the wrong script.

I think you need to post the code from the VBS file at
strShortcutPath = "C:\1234.vbs"

That would be the script that actually creates the folders.....

Regards,

Rob.
0
 
Dier02Author Commented:
Sorry, you are correct Rob, as posted below.
Dim myName 'As String
Dim main_fldr 'As String
Dim subfldr1 'As String
Dim subfldr2 'As String
Dim lastrow 'As Integer
Dim cell 'As Object
Const xlUp = -4162 '(&HFFFFEFBE)
 
 
Set objWshShell = WScript.CreateObject("WScript.Shell")
Set objFSO = CreateObject("Scripting.FileSystemObject")
 
strUserProfile = objWshShell.Environment("PROCESS")("UserProfile")
strNewDirectory = strUserProfile + "\My Documents\Students" 
 
If objfso.FolderExists(strnewdirectory) = False Then
	Set objFolder = objFSO.CreateFolder(strNewDirectory)
End If
 
subfldr1 = inputbox("Do you want to add a subfolder to the childs folder? ", "Folder name", "add subfolder name here")        'folder1
subfldr2 = inputbox("What is the second foldername? If you add nothing a folder will not be created", "Folder name", "")               'folder2
mynames = strUserProfile & "\My Documents\names.xls"        'location of the excel spreadsheet
worksheetname = "Sheet1"        'name of the worksheet within excel 
 
Set objExcel = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open(mynames)
objExcel.Visible = False
set ws = objExcel.activeworkbook.Worksheets(worksheetname)
objExcel.Displayalerts = false
 
 
'find the lastrow on the sheet
lastrow = ws.Range("A65536").End(xlUp).Row
 
'make the folders
For Each cell In ws.Range("A5:A" & lastrow)
    myName = cell.Value & "_" & cell.Offset(0, 1).Value
    'Call MkDir(strNewDirectory & "\") remove this.. its created already
    Call MkDir(strNewDirectory & "\" & myName & "\")
    Call MkDir(strNewDirectory & "\" & myName & "\" & subfldr1 & "\")
    Call MkDir(strNewDirectory & "\" & myName & "\" & subfldr2 & "\")
Next
 
objExcel.Displayalerts = true
objexcel.Quit
wscript.quit
 
 
Function MkDir(strPath)
        Dim strParentPath, objFSO
  Set objFSO = CreateObject("Scripting.FileSystemObject")
        On Error Resume Next
        strParentPath = objFSO.GetParentFolderName(strPath)
  If Not objFSO.FolderExists(strParentPath) Then MkDir strParentPath
        If Not objFSO.FolderExists(strPath) Then objFSO.CreateFolder strPath
        On Error Goto 0 
  MakeDir = objFSO.FolderExists(strPath)
End Function 

Open in new window

0
 
Dier02Author Commented:
Thanks guys.
0
 
RobSampsonCommented:
Hi, your code works fine for me, although I did start my names in the XLS on row 5, because of this line:
For Each cell In ws.Range("A5:A" & lastrow)

If you want it to pick names starting from row 2, change that line to this:
For Each cell In ws.Range("A2:A" & lastrow)

Also, I have added a condition to not make any folders if the name on a row is blank.

Regards,

Rob.
Dim myName 'As String
Dim main_fldr 'As String
Dim subfldr1 'As String
Dim subfldr2 'As String
Dim lastrow 'As Integer
Dim cell 'As Object
Const xlUp = -4162 '(&HFFFFEFBE)
 
 
Set objWshShell = WScript.CreateObject("WScript.Shell")
Set objFSO = CreateObject("Scripting.FileSystemObject")
 
strUserProfile = objWshShell.Environment("PROCESS")("UserProfile")
strNewDirectory = strUserProfile + "\My Documents\Students" 
 
If objfso.FolderExists(strnewdirectory) = False Then
	Set objFolder = objFSO.CreateFolder(strNewDirectory)
End If
 
subfldr1 = inputbox("Do you want to add a subfolder to the childs folder? ", "Folder name", "add subfolder name here")        'folder1
subfldr2 = inputbox("What is the second foldername? If you add nothing a folder will not be created", "Folder name", "")               'folder2
mynames = strUserProfile & "\My Documents\names.xls"        'location of the excel spreadsheet
worksheetname = "Sheet1"        'name of the worksheet within excel 
 
Set objExcel = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open(mynames)
objExcel.Visible = False
set ws = objExcel.activeworkbook.Worksheets(worksheetname)
objExcel.Displayalerts = false
 
 
'find the lastrow on the sheet
lastrow = ws.Range("A65536").End(xlUp).Row
 
'make the folders
For Each cell In ws.Range("A5:A" & lastrow)
    If Trim(cell.Value) <> "" Then
	    myName = cell.Value & "_" & cell.Offset(0, 1).Value
	    'Call MkDir(strNewDirectory & "\") remove this.. its created already
	    Call MkDir(strNewDirectory & "\" & myName & "\")
	    Call MkDir(strNewDirectory & "\" & myName & "\" & subfldr1 & "\")
	    Call MkDir(strNewDirectory & "\" & myName & "\" & subfldr2 & "\")
	End If
Next
 
objExcel.Displayalerts = true
objexcel.Quit
wscript.quit
 
 
Function MkDir(strPath)
        Dim strParentPath, objFSO
  Set objFSO = CreateObject("Scripting.FileSystemObject")
        On Error Resume Next
        strParentPath = objFSO.GetParentFolderName(strPath)
  If Not objFSO.FolderExists(strParentPath) Then MkDir strParentPath
        If Not objFSO.FolderExists(strPath) Then objFSO.CreateFolder strPath
        On Error Goto 0 
  MakeDir = objFSO.FolderExists(strPath)
End Function

Open in new window

0

Featured Post

Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

  • 2
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now