I am Using the below code in my VAPI-XP script to upload my latest file in Test lab. But the attachments are not getting uploaded.
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder("D:\Services\2017\Test\New folder")
Set recentFile = Nothing
For Each file in folder.Files
If UCase(fso.GetExtensionName(file.name)) = "XLS" Then
If (recentFile is Nothing) Then
Set recentFile = file
ElseIf (file.DateLastModified > recentFile.DateLastModified) Then
Set recentFile = file
End If
End If
Next
TDHelper.UploadAttachment "D:\Services\2017\Test\New folder" & "\" & recentFile.name, CurrentRun
Related
I have created an excel macro, which loops through the different subfolders of a fixed parent folder. The parent folder directory does not change. I have found a code on the net, which first lets me choose the folder to scan, which is nice, but is awkward for my purpose, since I run the code several times and each time I have to choose the folder again.
Instead I would like to give the macro the fixed full path and do without the prompt to choose the folder. I have written the following code, but do not know how to adjust it to make it work the way I described. Could you give me some advise?
This is the code:
Dim MyPath As String, MyFolderName As String, MyFileName As String, strStartCell2 As String, strFolderToScan As String
Dim i As Integer
Dim F As Boolean
Dim objShell As Object, objFolder As Object, AllFolders As Object, AllFiles As Object, strFileFormat As Object, fso As Object
Dim MySheet As Worksheet
'Define variables and constants
Set strFileFormat = ThisWorkbook.Worksheets("Makro").Range("A6")
strStartCell2 = strStartCell
strFolderToScan = ThisWorkbook.Worksheets("Makro").Range("C4").Value & "\"
'Select folder
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "Please select the folder you would like to scan", 0, 0)
If Not objFolder Is Nothing Then
MyPath = objFolder.self.Path & "\"
ThisWorkbook.Worksheets("Sheet1").Range("B3").Value = MyPath
Else
Exit Sub
End If
Set objFolder = Nothing
Set objShell = Nothing
'List all folders
Set AllFolders = CreateObject("Scripting.Dictionary")
Set AllFiles = CreateObject("Scripting.Dictionary")
AllFolders.Add (MyPath), ""
i = 0
Do While i < AllFolders.Count
Key = AllFolders.keys
MyFolderName = Dir(Key(i), vbDirectory)
Do While MyFolderName <> ""
If MyFolderName <> "." And MyFolderName <> ".." Then
If (GetAttr(Key(i) & MyFolderName) And vbDirectory) = vbDirectory Then
AllFolders.Add (Key(i) & MyFolderName & "\"), ""
End If
End If
MyFolderName = Dir
Loop
i = i + 1
Loop
'List all files
For Each Key In AllFolders.keys
MyFileName = Dir(Key & "*." & strFileFormat)
Do While MyFileName <> ""
AllFiles.Add (Key & MyFileName), ""
MyFileName = Dir
Loop
Next
'List all files in Files sheet
Sheets("Makro").Range(strStartCell2).Resize(AllFiles.Count, 1) = WorksheetFunction.Transpose(AllFiles.keys)
Set AllFolders = Nothing
Set AllFiles = Nothing
Probably this is simple, but i just can't figure out how to do it.
Thanks a lot in advance!
Oliver
This is the relevant part for selecting the folder
'Select folder
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "Please select the folder you would like to scan", 0, 0)
If Not objFolder Is Nothing Then
MyPath = objFolder.self.Path & "\"
ThisWorkbook.Worksheets("Sheet1").Range("B3").Value = MyPath
Else
Exit Sub
End If
Set objFolder = Nothing
Set objShell = Nothing
Especially the objShell.BrowseForFolder is the part that asks you to browse for the folder. So you need to replace that to use strFolderToScan directly. We do that by using objShell.GetFolder(strFolderToScan) to get the folder from your path strFolderToScan.
But I recommend to check if the folder actually exists, so you do not run into errors:
'Select folder
Set objShell = CreateObject("Shell.Application")
If objShell.FolderExists(strFolderToScan) Then
MyPath = strFolderToScan
ThisWorkbook.Worksheets("Sheet1").Range("B3").Value = MyPath
Else
MsgBox "The folder '" & strFolderToScan & "' does not exist."
Exit Sub
End If
Set objShell = Nothing
I make a code then ask the user where he wants to put a text file created from an excel sheet.
if the selected folder is named formatted file, then a file should create. if the folder formatted file doesn't exist, the code should create a file named formatted Files and then create the text file in it.
the text file contains 4 columns of data from excel.
For now, the folder is created in the right place. the code is update with the correct solution.
if there's a way to simplify my code let me know!!
Here's my actual code:
Sub register_formated_data()
'
' register_formated_data Macro
'
Dim order As Object
Dim Folder As Object
Dim Folder_path As String
Dim lastrow As Long
Dim fSo As Object
Dim myFile As Object
FolderName = "Formated Files"
Filename = "formated" & Right(Sheets(8).Cells(12, 6).Value, InStr(File_path, "\"))
Dim FL As String ' FL is for file location
Sheets(8).Cells(12, 12).Value = ""
With Application.FileDialog(msoFileDialogFolderPicker) '
.Title = "Select where you want the folder to be" 'Open the file explorer
.InitialFileName = ThisWorkbook.path & "\" 'for you to select
.InitialView = msoFileDialogViewDetails 'the file you want
.AllowMultiSelect = True 'to add the txt file
.Show '
On Error GoTo PROC_EXIT
If Not .SelectedItems(1) = vbNullString Then FL = .SelectedItems(1)
End With
Sheets(8).Cells(12, 12).Value = FL
Folder_path = FL + "\" + FolderName
Set fSo = CreateObject("Scripting.FileSystemObject")
If Not fSo.FolderExists(Folder_path) Then
fSo.CreateFolder (Folder_path)
If fSo.FolderExists(Folder_path) Then
Set fSo = CreateObject("Scripting.FileSystemObject")
Set myFile = fSo.CreateTextFile(Folder_path + "\" + Filename, True)
myFile.WriteLine "Error"
myFile.Close
Set fSo = Nothing
End If
Else
If fSo.FolderExists(Folder_path) Then
Set fSo = CreateObject("Scripting.FileSystemObject")
Set myFile = fSo.CreateTextFile(Folder_path + "\" + Filename, True)
myFile.WriteLine "Error"
myFile.Close
Set fSo = Nothing
End If
End If
PROC_EXIT:
End Sub
As FL is picked using a FileDialog, it seems you are trying to create folder FL when it already exists.
Using
fSo.CreateFolder(FL).Name = FolderName
is equivalent to
folder = fSo.CreateFolder(FL)
folder.Name = FolderName
So you need to substitute it by fSo.CreateFolder(FolderName).
The corrected code block is then:
Set fSo = CreateObject("Scripting.FileSystemObject")
If Not fSo.FolderExists(Folder_path) Then
fSo.CreateFolder(Folder_path)
If fSo.FolderExists(Folder_path) Then
Set fSo = CreateObject("Scripting.FileSystemObject")
Set myFile = fSo.CreateTextFile(Folder_path + "\" + Filename, True)
myFile.WriteLine "Error"
myFile.Close
Set fSo = Nothing
End If
End If
This question already has answers here:
Recursively access subfolder files inside a folder
(2 answers)
Closed 6 years ago.
So I want to make a .vbs that edits all .txt in a folder. This the code I used, and the folder is C:\test folder.
Const ForReading = 1
Const ForWriting = 2
newline = ""
line = 1
Set objFSO = CreateObject("Scripting.FileSystemObject")
objStartFolder = "C:\test folder\"
Dim lineCount : lineCount = 0
Dim firstContent : firstContent = ""
Set objFolder = objFSO.GetFolder(objStartFolder)
Set colFiles = objFolder.Files
For Each objFile in colFiles
If LCase(objFSO.GetExtensionName(objFile)) = "txt" Then
lineCount = 0
firstContent = ""
FileName = objStartFolder & objFile.Name
Set objStream = objFSO.OpenTextFile(FileName, ForReading)
Do Until objStream.AtEndOfStream
lineCount = lineCount + 1
firstContent = firstContent & objStream.ReadLine & vbCrLf
If lineCount = line Then
firstContent = firstContent & newline & vbCrLf
End If
Loop
Set objStream = objFSO.OpenTextFile(FileName, ForWriting)
objStream.WriteLine firstContent
objStream.Close
End If
Next
It works. and changes all the text files to what I want them to say, but when I made a folder in C:\test folder called SF (C:\test folder\SF), all of the text files in SF don't change. How do I get it to work with subfolders?
Recursion is a function calling itself. It is used to walk trees.
ProcessFolder DirName
Sub ProcessFolder(FolderPath)
' On Error Resume Next
Set fldr = fso.GetFolder(FolderPath)
Set Fls = fldr.files
For Each thing in Fls
msgbox Thing.Name & " " & Thing.path
Next
Set fldrs = fldr.subfolders
For Each thing in fldrs
ProcessFolder thing.path
Next
End Sub
This solution: Export Pictures Excel VBA
Works just fine, but it's using a chart method that's being resized to the images inside the table to "screenshot" them(in my case even including the table borders), not actually exporting the images themselves.
When I get the images by converting the excel table to a html file, they even come in better resolution in the folder.
Is there a way to get the images themselves, with their original resolution instead using VBA(obviously I don't just need the pictures, otherwise I'd be content with the html conversion method)?
What I mean can be seen here: http://i.imgur.com/OUX9Iji.png The picture on the left is what I get using the html conversion method, the picture on the right is what I get using the chart method. As you can see the chart method just screenshots the picture within the excel table, and I need it to get the original picture like on the left.
As the newer filetypes .xlsm and .xlsx is actually a zip file, it's possible to have the workbook save a copy of itself and change the extension from .xlsm to .zip. From there, it can look inside the zip's xl/media folder and copy out the actual image files which will include metadata, etc.
For my purposes, since it changes the image filename (not filetype) inside the zip, I'm working on how to be more specific about renaming the image files based on workbook content (i.e., their placement in the workbook) as I copy them out for the user.
But yes, screenshots are not nearly as good as the real files and this method does it. This sub took me quite some time to write but I'm sure will be used by many!
Private Sub ExtractAllPhotosFromFile()
Dim oApp As Object, FileNameFolder As Variant, DestPath As String
Dim num As Long, sZipFile As String, sFolderName As String ', iPos As Long, iLen As Long
Dim vFileNameZip As Variant, strTmpFileNameZip As String, strTmpFileNameFld As String, vFileNameFld As Variant
Dim FSO As Object, strTmpName As String, strDestFolderPath As String
On Error GoTo EarlyExit
strTmpName = "TempCopy"
' / Check requirements before beginning / /
'File must be .xlsm
If Right(ActiveWorkbook.FullName, 5) <> ".xlsm" Then
MsgBox ("This function cannot be completed because the filetype of this workbook has been changed from its original filetype of .xlsm" _
& Chr(10) & Chr(10) & "Save as a Microsoft Excel Macro-Enabled Workbook (*.xlsm) and try again.")
Exit Sub
End If
'User to choose destination folder
strDestFolderPath = BrowseFolder("Choose a folder to Extract the Photos into", ActiveWorkbook.Path, msoFileDialogViewDetails)
If strDestFolderPath = "" Then Exit Sub
If Right(strDestFolderPath, 1) <> "\" Then strDestFolderPath = strDestFolderPath & "\"
'Prepare vars and Tmp destination
strTmpFileNameZip = Environ("Temp") & "\" & strTmpName & ".zip"
strTmpFileNameFld = Environ("Temp") & "\" & strTmpName
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(strTmpFileNameFld) Then
FSO.deletefolder strTmpFileNameFld
End If
If FSO.FileExists(strTmpFileNameZip) Then
Kill strTmpFileNameZip
End If
Set FSO = Nothing
'Save current workbook to Temp dir as a zip file
Application.StatusBar = "Saving copy of file to temp location as a zip"
ActiveWorkbook.SaveCopyAs Filename:=strTmpFileNameZip
'Create a folder for the contents of the zip file
strTmpFileNameFld = strTmpFileNameFld & "\"
MkDir strTmpFileNameFld
'Pass String folder path variables to Variant type variables
vFileNameFld = strTmpFileNameFld
vFileNameZip = strTmpFileNameZip
'Count files/folders inside the zip
Set oApp = CreateObject("Shell.Application")
num = oApp.Namespace(vFileNameZip).Items.Count
If num = 0 Then 'Empty Zip
GoTo EarlyExit 'Skip if somehow is empty as will cause errors
Else
'zip has files, copy out of zip into tmp folder
Application.StatusBar = "Copying items from temp zip file to folder"
oApp.Namespace(vFileNameFld).CopyHere oApp.Namespace(vFileNameZip).Items
End If
'Copy the image files from the tmp folder to the Dest folder
Application.StatusBar = "Moving Photos to selected folder"
strTmpFileNameFld = strTmpFileNameFld & "xl\media\"
CopyFiles strTmpFileNameFld, strDestFolderPath, "*.jpeg"
CopyFiles strTmpFileNameFld, strDestFolderPath, "*.jpg"
CopyFiles strTmpFileNameFld, strDestFolderPath, "*.png"
CopyFiles strTmpFileNameFld, strDestFolderPath, "*.bmp"
'Function complete, cleanup
'Prepare vars and Tmp destination
Application.StatusBar = "Cleaning up"
strTmpFileNameZip = Environ("Temp") & "\" & strTmpName & ".zip"
strTmpFileNameFld = Environ("Temp") & "\" & strTmpName
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(strTmpFileNameFld) Then
FSO.deletefolder strTmpFileNameFld
End If
If FSO.FileExists(strTmpFileNameZip) Then
Kill strTmpFileNameZip
End If
Application.StatusBar = False
MsgBox ("Photos extracted into the folder: " & strDestFolderPath)
Set oApp = Nothing
Set FSO = Nothing
Exit Sub
EarlyExit:
Application.StatusBar = False
Set oApp = Nothing
Set FSO = Nothing
MsgBox ("This function could not be completed.")
End Sub
I moved the copy to it's own sub to save space on how I filtered filetypes, not the best way but works
Private Sub CopyFiles(strFromPath As String, strToPath As String, FileExt As String)
'As function to get multiple filetypes
Dim FSO As Object
If Right(strFromPath, 1) <> "\" Then strFromPath = strFromPath & "\"
On Error Resume Next
Set FSO = CreateObject("scripting.filesystemobject")
FSO.MoveFile Source:=strFromPath & FileExt, Destination:=strToPath
Set FSO = Nothing
On Error GoTo 0
End Sub
I found this stable function online to select a destination folder, was actually difficult to find a good solid one.
Private Function BrowseFolder(Title As String, Optional InitialFolder As String = vbNullString, _
Optional InitialView As Office.MsoFileDialogView = msoFileDialogViewList) As String
'Used for the Extract Photos function
Dim V As Variant
Dim InitFolder As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = Title
.InitialView = InitialView
If Len(InitialFolder) > 0 Then
If Dir(InitialFolder, vbDirectory) <> vbNullString Then
InitFolder = InitialFolder
If Right(InitFolder, 1) <> "\" Then
InitFolder = InitFolder & "\"
End If
.InitialFileName = InitFolder
End If
End If
.Show
On Error Resume Next
Err.Clear
V = .SelectedItems(1)
If Err.Number <> 0 Then
V = vbNullString
End If
End With
BrowseFolder = CStr(V)
End Function
i want to convert excel files into tab limited txt files(without carriage returns). Currently i'm using the script(found in this forum) which converts mass excel files into .txt files.
the script is
' #file: xl2tab.vbs
' #author: stephen brown - sb09d#fsu.edu
' #date: 2009-Dec-10
'
' #description: mass convert excel files to tab-delimited files
'
' #usage: place in top-level directory where excel files are contained and double-click.
' script will recursively access all subdirectories and convert each excel file to
' tab delimited file. All output will be in "output" folder, which retains structure
' of original directories
Dim saveDirBase
set fso = CreateObject("Scripting.FileSystemObject")
set shell = CreateObject("WScript.Shell")
set objExcel = CreateObject("Excel.Application")
set top = fso.GetFolder(shell.CurrentDirectory)
saveDirBase = top & "\" & "output"
Sub TraverseFolders(path)
set folder = fso.GetFolder(path)
XL2Tab(folder)
For each item in folder.SubFolders
If item.Path <> saveDirBase Then
Call TraverseFolders(item.Path)
End If
Next
set folder = Nothing
End Sub
Sub XL2Tab(folder)
Dim saveDir
set files = folder.Files
If folder.Name <> top.Name Then
saveDir = saveDirBase & "\" & folder.Name
Else
saveDir = saveDirBase
End If
If fso.FolderExists(saveDir) = False Then
fso.CreateFolder(saveDir)
End If
For each file In files
If file.Name <> Wscript.ScriptName Then
objExcel.Application.DisplayAlerts = False
Set objWorkbook = objExcel.Workbooks.open(folder.Path & "\" & file.Name)
objWorkbook.SaveAs saveDir & "\" & file.Name & ".txt", -4158
objWorkbook.close
objExcel.Application.DisplayAlerts = True
End If
Next
End Sub
If fso.FolderExists(saveDirBase) = False Then
fso.CreateFolder(saveDirBase)
End If
Call TraverseFolders(top)
Before converting i want to remove carriage return in every excel file.
Please guide me anyone...!
Hi If you are trying to remove carriage returns after converting the file add the below procedure to code
sub RemoveCarriage(FileN)
Const ForReading = 1
Const ForWriting = 2
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile(FileN, ForReading)
strText = objFile.ReadAll
objFile.Close
strNewText = Replace(strText, chr(013) & chr(010), "")
' chr(010) = line feed chr(013) = carriage return
Set objFile = objFSO.OpenTextFile(FileN, ForWriting)
objFile.WriteLine strNewText
objFile.Close
End sub
Call the module inside forloop of your procedure just after closing the workbook
objWorkbook.close
RemoveCarriage(file.Name & ".txt")