Reply
 
LinkBack Thread Tools Search this Thread Display Modes
  #1   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
 
Posts: 92
Default Merge 2 pieces of code

Hi everyone. I have 2 separate pieces of code: 1 allows the user to browse
to and select a directory. The second opens all files within a flder
directory. In that piece, the folder path is predefined as a variable. I
would love to make that piece dynamic to allow for the user to browse to the
folder, read that folder as a variable, and apply it to the second piece of
code. The code is below. Thanks for your help!!

Get Directory Code:
Option Explicit
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type

'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String)
_
As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Sub Test()
Dim Msg As String
Dim x As Variant
Msg = "Please select a location for the backup."
MsgBox GetDirectory(Msg)
End Sub

Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer

' Root folder = Desktop
bInfo.pidlRoot = 0&

' Title in the dialog
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
Else
bInfo.lpszTitle = Msg
End If

' Type of directory to return
bInfo.ulFlags = &H1

' Display the dialog
x = SHBrowseForFolder(bInfo)

' Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
End If
End Function


Open Files Code:
Sub Open_all_files() 'Opens all files in folder AND Subfolders

Dim FSO As Scripting.FileSystemObject
Dim TopFolder As String
Set FSO = New Scripting.FileSystemObject
TopFolder = "C:\testfolder" '<<<<<<<<< THIS IS WHAT I WOULD LIKE
TO BE VARIABLE
InnerProc FSO.GetFolder(TopFolder), FSO

End Sub

Sub InnerProc(F As Scripting.Folder, FSO As Scripting.FileSystemObject)

Dim SubFolder As Scripting.Folder
Dim OneFile As Scripting.File
Dim WB As Workbook

For Each SubFolder In F.SubFolders
If LCase(SubFolder.Name) Like "*rollup*" Then
' do nothing
Else
InnerProc SubFolder, FSO
End If
Next SubFolder
For Each OneFile In F.Files
Debug.Print OneFile.path
If Right(OneFile.Name, 4) = ".xls" Then
Set WB = Workbooks.Open(Filename:=OneFile.path)
'Do stuff here
End If
Next OneFile

End Sub


  #2   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
 
Posts: 27,285
Default Merge 2 pieces of code

As long as GetDirecotry is visible to this routine

Sub Open_all_files() 'Opens all files in folder AND Subfolders

Dim FSO As Scripting.FileSystemObject
Dim TopFolder As String
Set FSO = New Scripting.FileSystemObject
msg "Select directory"
TopFolder = GetDirectory(msg)
if TopFolder = "" then
msgbox "No selection, exiting"
exit sub
end if
InnerProc FSO.GetFolder(TopFolder), FSO

End Sub


--
Regards,
Tom Ogilvy


"Steph" wrote in message
...
Hi everyone. I have 2 separate pieces of code: 1 allows the user to

browse
to and select a directory. The second opens all files within a flder
directory. In that piece, the folder path is predefined as a variable. I
would love to make that piece dynamic to allow for the user to browse to

the
folder, read that folder as a variable, and apply it to the second piece

of
code. The code is below. Thanks for your help!!

Get Directory Code:
Option Explicit
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type

'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As

String)
_
As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Sub Test()
Dim Msg As String
Dim x As Variant
Msg = "Please select a location for the backup."
MsgBox GetDirectory(Msg)
End Sub

Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer

' Root folder = Desktop
bInfo.pidlRoot = 0&

' Title in the dialog
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
Else
bInfo.lpszTitle = Msg
End If

' Type of directory to return
bInfo.ulFlags = &H1

' Display the dialog
x = SHBrowseForFolder(bInfo)

' Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
End If
End Function


Open Files Code:
Sub Open_all_files() 'Opens all files in folder AND Subfolders

Dim FSO As Scripting.FileSystemObject
Dim TopFolder As String
Set FSO = New Scripting.FileSystemObject
TopFolder = "C:\testfolder" '<<<<<<<<< THIS IS WHAT I WOULD

LIKE
TO BE VARIABLE
InnerProc FSO.GetFolder(TopFolder), FSO

End Sub

Sub InnerProc(F As Scripting.Folder, FSO As Scripting.FileSystemObject)

Dim SubFolder As Scripting.Folder
Dim OneFile As Scripting.File
Dim WB As Workbook

For Each SubFolder In F.SubFolders
If LCase(SubFolder.Name) Like "*rollup*" Then
' do nothing
Else
InnerProc SubFolder, FSO
End If
Next SubFolder
For Each OneFile In F.Files
Debug.Print OneFile.path
If Right(OneFile.Name, 4) = ".xls" Then
Set WB = Workbooks.Open(Filename:=OneFile.path)
'Do stuff here
End If
Next OneFile

End Sub




Reply
Thread Tools Search this Thread
Search this Thread:

Advanced Search
Display Modes

Posting Rules

Smilies are On
[IMG] code is On
HTML code is Off
Trackbacks are On
Pingbacks are On
Refbacks are On


Similar Threads
Thread Thread Starter Forum Replies Last Post
Merge base on same code number Pran Excel Worksheet Functions 5 July 17th 09 08:26 AM
First zero doesn't show up in zip code mail merge. DLencz Excel Worksheet Functions 1 November 12th 07 08:30 PM
zip code with mail merge Booklisa Excel Discussion (Misc queries) 4 August 30th 07 05:24 PM
Code launches Mail Merge but disables the Mail Merge austris Excel Discussion (Misc queries) 0 October 14th 06 01:11 AM
Merge two pieces of code into one Steph[_3_] Excel Programming 3 January 22nd 04 12:52 PM


All times are GMT +1. The time now is 03:32 AM.

Powered by vBulletin® Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
Copyright ©2004-2024 ExcelBanter.
The comments are property of their posters.
 

About Us

"It's about Microsoft Excel"