Microsoft Office Forums

Go Back   Microsoft Office Forums > >

 
 
Thread Tools Display Modes
Prev Previous Post   Next Post Next
  #2  
Old 08-16-2011, 02:34 AM
Catalin.B Catalin.B is offline Macro to loop in subfolders, change links, export xml data Windows Vista Macro to loop in subfolders, change links, export xml data Office 2007
Expert
Macro to loop in subfolders, change links, export xml data
 
Join Date: May 2011
Location: Iaşi, Romānia
Posts: 386
Catalin.B is on a distinguished road
Default

Well, i ended with this codes :

Option Explicit

'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

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


Sub GetAllFiles()
Dim Msg As String
Dim Directory As String
Msg = "Select the folder for the recursive directory listing."
Directory = GetDirectory(Msg)
If Directory = "" Then Exit Sub
If Right(Directory, 1) <> "\" Then Directory = Directory & "\"
Cells.ClearContents
Call RecursiveDir(Directory)
End Sub

Public Sub RecursiveDir(ByVal CurrDir As String)
Dim Dirs() As String
Dim NumDirs As Long
Dim FileName As String
Dim PathAndName As String
Dim i As Long

' Make sure path ends in backslash
If Right(CurrDir, 1) <> "\" Then CurrDir = CurrDir & "\"

' Put column headings on active sheet
Cells(1, 1) = "Path"
Cells(1, 2) = "Filename"
Cells(1, 3) = "Size"
Cells(1, 4) = "Date/Time"
Range("A1:D1").Font.Bold = True

' Get files
FileName = Dir(CurrDir & "*.*", vbDirectory)
Do While Len(FileName) <> 0
If Left(FileName, 1) <> "." Then 'Current dir
PathAndName = CurrDir & FileName
If (GetAttr(PathAndName) And vbDirectory) = vbDirectory Then
'store found directories
ReDim Preserve Dirs(0 To NumDirs) As String
Dirs(NumDirs) = PathAndName
NumDirs = NumDirs + 1
Else
'Write the path and file to the sheet
Cells(WorksheetFunction.CountA(Range("A:A")) + 1, 1) = CurrDir
Cells(WorksheetFunction.CountA(Range("B:B")) + 1, 2) = FileName
Cells(WorksheetFunction.CountA(Range("C:C")) + 1, 3) = FileLen(PathAndName)
Cells(WorksheetFunction.CountA(Range("D:D")) + 1, 4) = FileDateTime(PathAndName)
End If
End If
FileName = Dir()
Loop
' Process the found directories, recursively
For i = 0 To NumDirs - 1
RecursiveDir Dirs(i)
Next i
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
Function GetFormulaI(Cell As Range) As String
'Application.Volatile = True
If VarType(Cell) = 8 And Not Cell.HasFormula Then
GetFormulaI = "'" & Cell.Formula
Else
GetFormulaI = Cell.Formula
End If
If Cell.HasArray Then _
GetFormulaI = "{" & Cell.Formula & "}"
End Function

And this:

Sub Macro2()
Dim i As Integer


For i = 2 To 275 Step 2
ActiveWorkbook.ChangeLink Name:= _
Sheets("Foaie1").Cells(2, 9).Value _
, NewName:= _
Sheets("Foaie2").Cells(i + 2, 3).Value _
, Type:=xlExcelLinks


ActiveWorkbook.ChangeLink Name:= _
Sheets("Foaie1").Cells(3, 9).Value _
, NewName:= _
Sheets("Foaie2").Cells(i + 3, 3).Value _
, Type:=xlExcelLinks


Application.DisplayAlerts = False
ActiveWorkbook.Save
Application.DisplayAlerts = True
ActiveWorkbook.XmlMaps("pdf_121_Asociere").Export URL:= _
"C:\Users\Catalin\Desktop\Cereri finantare\ " & Sheets("Foaie1").Range("b3").Value & "" _
, Overwrite:=True

Next i
End Sub

The problem is that the workbook with the path in red is password protected, and prompts for password at every change of links...
Unfortunately, i couldn't find a way to paste the password in the prompt for password for changing links.. There is no need to open the workbook, the paste password works only for workbook open, update links.

Is there a way to capture the prompt for password window and to insert password?
Reply With Quote
 



Similar Threads
Thread Thread Starter Forum Replies Last Post
Made a mistake with a macro change lance_kidd Word 0 02-09-2011 06:36 PM
Accessing Outlook Contacts in Subfolders jill5545 Outlook 1 11-17-2010 04:01 PM
Create a Custome Form and export data to Access ashleybyrdnc Office 0 03-05-2010 09:41 AM
Macro to export document sections to individual txt files? MJMR999 Excel Programming 0 02-18-2010 12:49 PM
Subfolders in Inbox and Sent Items stevie Outlook 0 09-08-2009 02:02 AM

Other Forums: Access Forums

All times are GMT -7. The time now is 11:26 AM.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2025, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2025 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft