Solved

script issue

Posted on 2008-11-02
5
251 Views
Last Modified: 2010-04-24
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
Comment
Question by:Dier02
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 2
  • 2
5 Comments
 
LVL 19

Assisted Solution

by:weellio
weellio earned 50 total points
ID: 22863406
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
 
LVL 65

Accepted Solution

by:
RobSampson earned 450 total points
ID: 22864622
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
 

Author Comment

by:Dier02
ID: 22864893
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
 

Author Closing Comment

by:Dier02
ID: 31512539
Thanks guys.
0
 
LVL 65

Expert Comment

by:RobSampson
ID: 22871658
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

Secure Your Active Directory - April 20, 2017

Active Directory plays a critical role in your company’s IT infrastructure and keeping it secure in today’s hacker-infested world is a must.
Microsoft published 300+ pages of guidance, but who has the time, money, and resources to implement? Register now to find an easier way.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Recently I finished a vbscript that I thought I'd share.  It uses a text file with a list of server names to loop through and get various status reports, then writes them all into an Excel file.  Originally it was put together for our Altiris server…
Welcome back!  My apologies for taking so long to write part two of this series; it's been a long time coming!  As I promised in Part 1, this article will focus on how to locate those elusive AD properties that you are searching for.  Why is this us…
Nobody understands Phishing better than an anti-spam company. That’s why we are providing Phishing Awareness Training to our customers. According to a report by Verizon, only 3% of targeted users report malicious emails to management. With compan…
Finding and deleting duplicate (picture) files can be a time consuming task. My wife and I, our three kids and their families all share one dilemma: Managing our pictures. Between desktops, laptops, phones, tablets, and cameras; over the last decade…

726 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question