Scenario - OutFolder contains XML files which are named by their created datetime (like 20140524110115, 20140524110120, 20140524110122 and so on). I want to rename these files based on their ID and Action tag values (and check for duplications too).
Problem - When I run the following code, the loop is running twice as many times as number of files in the folder. Currently, the folder contains 67 files and the loop is running 134 times. Hence the files are renamed as
ID11_New_2.xml
ID11_Used_2.xml
ID12_New_2.xml
ID12_Sold_2.xml
... and so on
I was expecting
ID11_New_1.xml
ID11_Used_1.xml
ID12_New_1.xml
ID12_Sold_1.xml
... and so on
Why the loop is running twice?
Sub Test(OutFolder)
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set xmlDoc = CreateObject("Microsoft.XMLDOM")
xmlDoc.SetProperty "SelectionLanguage", "XPath"
xmlDoc.Async = False
Set objFiles = objFSO.GetFolder(OutFolder).Files
i = 1
For Each FileXML In objFiles
Debug.Print i
xmlDoc.Load (FileXML.Path)
Set varID = xmlDoc.GetElementsByTagName("Id")
Set varAction = xmlDoc.GetElementsByTagName("Action")
If varID.Length > 0 And varAction.Length > 0 Then 'if file is of correct format
FileCtr = 1
varFileName = varID(0).Text & "_" & varAction(0).Text & "_" & FileCtr & ".xml"
'check for duplicates
While objFSO.FileExists(objFSO.BuildPath(OutFolder, varFileName))
varFileName = varID(0).Text & "_" & varAction(0).Text & "_" & FileCtr & ".xml"
FileCtr = FileCtr + 1
Wend
'FileXML.Name = varFileName
With objFSO
.MoveFile .BuildPath(FileXML.ParentFolder, FileXML.Name), .BuildPath(FileXML.ParentFolder, varFileName)
End With
End If
i = i + 1
Next
End Sub
While objFSO.FileExists(objFSO.BuildPath(OutFolder, varFileName))
FileCtr = FileCtr + 1
varFileName = varID(0).Text & "_" & varAction(0).Text & "_" & FileCtr & ".xml"
Wend
And not really sure if the folder where you test for duplicates is the correct one (i don't know what the folders contain), but maybe in ther first line you need to change OutFolder with FileXML.ParentFolder
Related
I am trying to replace part of the code in my Python script using VBA.
I need to replace two lines of code with nothing. The VBA is not able to "find" these two lines in the code, which I think is because of the spaces, tabs in the Python script.
strContents = Replace(strContents, "if time == 12:" & vbNewLine & vbTab & "Freq = 1", "")
' *** THIS IS THE MOST CRUCIAL LINE - WHICH IS FAILING RIGHT NOW***
I am not adding the rest of the code of finding and replacing as it works, and the issue is finding this particular expression.
The Python script I am trying to delete (or replace with nothing):
if time == 12:
Freq = 1
else:
Freq = 12
In another attempt, I tried counting the number of spaces, and asking the VBA to find the text in the Python script with the number of spaces I could count in the script.
Thanks #Aldert for responding, here is the entire code :
Sub FindReplaceTrials()
Dim objFSO
Const ForReading = 1
Const ForWriting = 2
Dim objTS 'define a TextStream object
Dim strContents As String
Dim path As String
Dim fileSpec As String
Dim filename As String
path = Application.ActiveWorkbook.path
For m = 4 To 11 ' we need to make this dynamic too
filename = Worksheets("ScriptName").Cells(m, 1).Value
fileSpec = path & "\" & filename & ".py"
'MsgBox (vbCrLf & vbTab & "else:")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTS = objFSO.OpenTextFile(fileSpec, ForReading)
If Worksheets(4).Range("B" & 7).Value = 1 Then
If filename = "econ" Then
strContents = objTS.ReadAll
strContents = Replace(strContents, "if time == 12:" & vbCrLf & Space(20) & "freq = 1" & vbCrLf & Space(16) & "else:" & vbCrLf & Space(20) & "freq = 12", "freq = 12")
Set objTS = objFSO.OpenTextFile(fileSpec, ForWriting)
objTS.Write strContents
objTS.Close
End If
End If
objTS.Close
Next
End Sub
The vbCrLf & Space() objects worked to find the right sentences in the script.
I'm struggling to figure out what I need to do in order to run this code. I've based almost the entire thing off of this question:
MS Access VBA download attachment Mkdir path not exist
In which we have similar objectives, except mine is to send all fields from a table to two new folders based off of two fields "engine" and "testtype" rather than "year" and "month" as in the question posted above^.
I'm very new to VBA programming (basically started two weeks ago), and am open to any suggestions. Basically, I set the Dim for Record 1 as a string so that the field value could be read and not have an error pop up. But, I'm still using the code from the question above at the end of the script, and I'm not sure if I should keep it in, given my objective. The question above has multiple attachments in one field, whereas I just have multiple fields with strings in their records.
I'm getting the error message at the "While Not Record1.EOF" line.
Please advise if possible!
Sub Eng_Test()
Dim database As DAO.database
Dim table As DAO.Recordset
Dim PONum As String
Dim folder As String
Dim Record1 As String
Set database = CurrentDb
Dim PKey As String
Dim P2Key As String
Set table = database.OpenRecordset("tblFieldLogNOAUTO#")
folder = "C:\users"
If Len(Dir(folder, vbDirectory)) = 0 Then
MkDir folder
End If
folder = folder & "\ndemos"
If Len(Dir(folder, vbDirectory)) = 0 Then
MkDir folder
End If
folder = folder & "\ONEDRIVE"
If Len(Dir(folder, vbDirectory)) = 0 Then
MkDir folder
End If
folder = folder & "\Documents"
If Len(Dir(folder, vbDirectory)) = 0 Then
MkDir folder
End If
With table
Do Until .EOF
Record1 = table.Fields("TimeDateTeam").Value
'Record2 = table.Fields("frmDate").Value
'Record3 = table.Fields("Location").Value
'Record4 = table.Fields("Engine").Value
'Record5 = table.Fields("TestType").Value
'Record6 = table.Fields("Data Locator").Value
'Record7 = table.Fields("Calibration File").Value
'Record8 = table.Fields("Engine Serial").Value
'Record9 = table.Fields("VIN Number").Value
'Record10 = table.Fields("Moe Number").Value
'Record11 = table.Fields("Name/Team").Value
'Records = Record1 & Record2 & Record3 & Record4 & Record5 & Record6 & Record7 & Record8 & Record9 & Record10 & Record11
PKey = table.Fields("Engine").Value
If Len(Dir(folder & "\" & PKey, vbDirectory)) = 0 Then
MkDir folder & "\" & PKey
End If
P2Key = table.Fields("TestType").Value
If Len(Dir(folder & "\" & PKey & "\" & P2Key, vbDirectory)) = 0 Then
MkDir folder & "\" & PKey & "\" & P2Key
End If
Eng_TestFolder = folder & "\" & PKey & "\" & P2Key
While Not Record1.EOF
Record1.Fields("FileData").SaveToFile (Eng_TestFolder)
Record1.MoveNext
Wend
.MoveNext
Loop
End With
End Sub
I have the following Code that generates separate PDF Files for each rows of my excel sheet.
My goal is to generate a Single PDF file having a number of pages instead of seperate PDF Files.
Can any kind soul help me with this?
Option Explicit
Sub Create_PDF_Files()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim dsh As Worksheet
Dim tsh As Worksheet
Dim setting_Sh As Worksheet
Set dsh = ThisWorkbook.Sheets("Data")
Set tsh = ThisWorkbook.Sheets("Letter Template")
Set setting_Sh = ThisWorkbook.Sheets("Settings")
Application.DisplayStatusBar = True
Application.StatusBar = ""
Dim i As Integer
Dim File_Name As String
For i = 2 To dsh.Range("A" & Application.Rows.Count).End(xlUp).Row
Application.StatusBar = i - 1 & "/" & dsh.Range("A" & Application.Rows.Count).End(xlUp).Row - 1
tsh.Range("C2").Value = dsh.Range("A" & i).Value
tsh.Range("C3").Value = dsh.Range("D" & i).Value
tsh.Range("C5").Value = dsh.Range("E" & i).Value
tsh.Range("C6").Value = dsh.Range("F" & i).Value
tsh.Range("C7").Value = dsh.Range("G" & i).Value
tsh.Range("C8").Value = dsh.Range("H" & i).Value
tsh.Range("C9").Value = dsh.Range("I" & i).Value
tsh.Range("C10").Value = dsh.Range("J" & i).Value
tsh.Range("D12").Value = dsh.Range("K" & i).Value
File_Name = dsh.Range("B" & i).Value & "_" & dsh.Range("C" & i).Value & "_" & dsh.Range("K" & i).Value & ".pdf"
tsh.ExportAsFixedFormat xlTypePDF, ThisWorkbook.Sheets("Settings").Range("F4").Value & "\" & File_Name
Next i
Application.StatusBar = ""
MsgBox "PDF files generated successfully."
End Sub
The line starting tsh.ExportAsFixedFormat... is inside the For... next loop. This is why it is generating a new PDF for each file.
There are three approaches you could try:
Move that line below the next statement, and adjust your code so that your accumulating variable is fed into an overall variable, which you then export.
Run it like you are now, but add a step at the end to combine all the generated files into one PDF.
Find a different export function that generates a PDF page rather than file, and can aggregate at the end.
I need to copy my server log file to another folder up on completion of one log file and then rename the copied file adding date and time to the file name.
Source : C:\Server\Logs
Destination : Can be selected by user using .BrowseForFolder
Log file name : Server_log_23.txt ("23" is the log number which will change from 1 to 30)
One log file will be completed in 2 minutes and log writing will be moved to next file by adding one (that means if Server_log_23.txt is completed then server will starts writing logs in Server_logs_24.txt till Server_log_30.txt, if log_30 is completed then it will starts writing in log_1)
I got a code like this, but it is not giving a continuous loop
Const DestinationFile = "C:\Users\Testbench\Desktop\file copy\Destination\"
Const src = "C:\Users\Testbench\Desktop\file copy\Source\"
strInput = UserInput( "Please enter file number:" )
strInput1 = "log_(" &strInput1 &")"
Dim sDateTimeStamp
Dim folder
Sub CopyFile()`enter code here`
Set fso = CreateObject("Scripting.FileSystemObject")
srcfile = strInput
Set folder = fso.GetFolder(src)
For Each file In folder.files
If instr(file.name, strInput) > 0 Then
srcfile=file.name
WScript.Echo srcfile
End If
Next
SourceFile= "C:\Users\Testbench\Desktop\file copy\Source\" & srcfile
WScript.Echo SourceFile
sDateTimeStamp = cStr(Year(now())) & _
Pad(cStr(Month(now())),2) & _
Pad(cStr(Day(now())),2) & _
Pad(cStr(Hour(now())),2) & _
Pad(cStr(Minute(now())),2) & _
Pad(cStr(Second(now())),2)
WScript.Echo "Copying " & SourceFile & " to " & DestinationFile
fso.CopyFile SourceFile, DestinationFile & srcfile & "_" & sDateTimeStamp & ".txt", True
Set fso = Nothing
End Sub
Function Pad(CStr2Pad, ReqStrLen)
Dim Num2Pad
Pad = CStr2Pad
If len(CStr2Pad) < ReqStrLen Then
Num2Pad = String((ReqStrlen - Len(CStr2Pad)), "0")
Pad = Num2Pad & CStr2Pad
End If
End Function
Function UserInput( myPrompt )
If UCase( Right( WScript.FullName, 12 ) ) = "\CSCRIPT.EXE" Then
WScript.StdOut.Write myPrompt & " "
UserInput = WScript.StdIn.ReadLine
Else
UserInput = InputBox( myPrompt )
End If
End Function
Do while strInput1<30
wscript.sleep 180
CopyFile()
strInput1 = strInput1 + 1
Exit Do
strInput1 =1
CopyFile()
strInput1 = strInput1 + 1
Loop
I want to create a bit of code that saves a file out to a folder (PDF / DWG ) and moves all my files with a lower revision #5 than the current file being saved into a superseded folder.
I cannot see how to set a condition for the revision number: I can't use a wildcard as that would cause issues as other files in the folder would be picked up and moved incorrectly.
I have the save function sorted, I just dont know were to start with filing part.
Examples of the filenames:
Pdf/TE1801_200-01_{name}_#5.PDF
Dwg/TE1801_200-01_{name}_#5.DWG
You could use the GetBaseName Method to get just the filename without the extension
Then use the INSTRREV Function to find the position of the last "#" (just in case someone used a "#" in the {name} part).
Next use the LEFT Function to get the the "TE1801_200-01_{name}_#" part and now you can add a wildcard to it like "TE1801_200-01_{name}_#*.*". (It doesn't matter whether or not you have the "#" at the end at this stage.)
Prepend the full path and get all the matching files.
Move those files.
Now save the current file with its revison number.
' ------------------------------------------------------------------------------
' MOVE OLD REVISION TO SUPERSEDED FOLDERS - PDF
' ------------------------------------------------------------------------------
URLPASS = Filepath & "PDF\"
Dim MyObj As Object, MySource As Object, file As Variant
Set MyObject = CreateObject("Scripting.FileSystemObject")
Set MySource = MyObject.GetFolder(URLPASS)
For Each file_ In MySource.Files
LArray = Split(file_, "#")
checkfile = LArray(0)
REV = Split(LArray(1), ".")
If LArray(0) = checkfile And REV(0) < VERSION Then
' FILE FORMATING
' ----------------------------------------
RECON = Split(file_, "PDF\")
file_ = RECON(1)
RECON = Split(file_, ".")
DRAWNOCONFIG = RECON(0)
' MOVE TO NEW LOCATION
' ----------------------------------------
If Dir(Filepath & "PDF" & "\SUPERSEDED", vbDirectory) = "" Then '
MkDir Filepath & "PDF" & "\SUPERSEDED"
End If
Name Filepath & "PDF\" & DRAWNOCONFIG & ".pdf" As Filepath & "PDF\" & "SUPERSEDED\" & DRAWNOCONFIG & ".pdf"
Else
'DO NOTHING
GoTo Endline
End If
Endline:
Next file_
' ------------------------------------------------------------------------------
' MOVE OLD REVISION TO SUPERSEDED FOLDERS - DWG
' ------------------------------------------------------------------------------
URLPASS = Filepath & "DWG\"
Set MyObject = CreateObject("Scripting.FileSystemObject")
Set MySource = MyObject.GetFolder(URLPASS)
For Each file_ In MySource.Files
LArray = Split(file_, "#")
checkfile = LArray(0)
REV = Split(LArray(1), ".")
If LArray(0) = checkfile And REV(0) < VERSION Then
' FILE FORMATING
' ----------------------------------------
RECON = Split(file_, "DWG\")
file_ = RECON(1)
RECON = Split(file_, ".")
DRAWNOCONFIG = RECON(0)
' MOVE TO NEW LOCATION
' ----------------------------------------
If Dir(Filepath & "DWG" & "\SUPERSEDED", vbDirectory) = "" Then '
MkDir Filepath & "DWG" & "\SUPERSEDED"
End If
Name Filepath & "DWG\" & DRAWNOCONFIG & ".dwg" As Filepath & "DWG\" & "SUPERSEDED\" & DRAWNOCONFIG & ".dwg"
Else
'DO NOTHING
GoTo Endline2
End If
Endline2:
Next file_