I've compiled a script that adds a trailer to the end of a .csv file (to let the program reading it know that it's finished transmitting data.) Anyways, I'm trying to figure out how to only add this if the file that's referenced contains data.
dim filesys, filetxt
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Set filesys = CreateObject("Scripting.FileSystemObject")
Set filetxt = filesys.OpenTextFile("C:\Test\Test.csv", ForAppending, True)
filetxt.WriteLine(",,,,,,,,,,,," & vbCr)
filetxt.WriteLine(",,,,,,,,,,,," & vbCr)
filetxt.WriteLine(",,,,,,,,,,,," & vbCr)
filetxt.WriteLine(",,,,,,,,,,,," & vbCr)
filetxt.WriteLine(",,,,,,,,,,,," & vbCr)
filetxt.Close
Any help is appreciated!
Try to check the size of the file:
strFile = "C:\file.txt"
SET objFSO = CREATEOBJECT("Scripting.FileSystemObject")
SET objFile = objFSO.GetFile(strFile)
If objFile.Size > 0 Then
'do things here
Else
'do nothing
End If
Related
I have written a VB script to count the number of rows from several CSV files and save in a File in FileRecordCount.csv file with the filename and number of rows. The code does not show any errors at all.
But the script is not working at all. I don't know what is the problem. Any help Any help would be greatly appreciated!????
Const ForReading = 1
Const ForWriting = 2
Set objFSO = CreateObject("Scripting.FileSystemObject")
vbsFile = Wscript.ScriptName
vbsFilePath = Wscript.ScriptFullName
sFolder = left(vbsFilePath,len(vbsFilePath)-(len(vbsFile)+1))
ResultsFile = sFolder & "\FileRecordCount.csv"
For Each objFile In objFSO.GetFolder(sFolder).Files
If UCase(objFSO.GetExtensionName(objFile.Name)) = "CSV" Then
oFile = objFile.path
Set objFile = objFSO.OpenTextFile(oFile, ForReading)
RowCount = 0
Do Until objFile.AtEndOfStream
WScript.Echo objFile.ReadLine
RowCount = RowCount + 1
Loop
'need to make a new file to write the results to
FileName = objFSO.GetFileName(ResultsFile)
strText = FileName & "," & RowCount
Set objFile = objFSO.OpenTextFile(ResultsFile, ForWriting)
objFile.WriteLine strText
objFile.Close
End if
Next
MsgBox "FileRowCount Complete"
The script has multiple issues. First, as #Flakes stated, the same objFile variable is used for the files being processed and the results file. Second, the results filename is being written to the results file instead of each processed file name. Additionally, the variable "oFile" is a string, so would be better named "strFile" and the script path directory can be derived a bit more elegantly. Also, as per #Flakes, I moved the results file open before the loop and the results file close after the loop and I named the results file with a .txt extension so it doesn't get processed as one of the CSV files. Also added a Create = True flag to the results file open, so it doesn't have to pre-exist.
Here is the edited script:
Const ForReading = 1
Const ForWriting = 2
Const Create = True
Set objFSO = CreateObject("Scripting.FileSystemObject")
sFolder = objFSO.GetParentFolderName(WScript.ScriptFullName)
ResultsFile = sFolder & "\FileRecordCount.txt"
Set objResultsFile = objFSO.OpenTextFile(ResultsFile, ForWriting, Create)
For Each objFile In objFSO.GetFolder(sFolder).Files
If UCase(objFSO.GetExtensionName(objFile.Name)) = "CSV" Then
strFile = objFile.path
Set objReadFile = objFSO.OpenTextFile(strFile, ForReading)
RowCount = 0
FirstLine = True
Do Until objReadFile.AtEndOfStream
Line = objReadFile.ReadLine
RowCount = RowCount + 1
If FirstLine Then ColumnCount = UBound(Split(Line,",")) + 1
FirstLine = False
Loop
objReadFile.Close
strText = strFile & "," & RowCount & "," & ColumnCount
objResultsFile.WriteLine strText
End if
Next
objResultsFile.Close
WScript.Echo "File row/column count complete"
I'm having trouble getting a range that is embedded in an email to left align. I've tried several things but the embedded portion still centers in the email. Here is my code, which ironically, works just fine in other spreadsheets. I've tried adding HTML tags, changing the function(s), all to no avail. Any help would be appreciated. This is on W7x64 and Office 2010. In this report I am embedding a pivot table instead of a regular range.
Thanks.
Option Explicit
SalesSub Mail_RegionalRANGE()
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
'On Error Resume Next
Set OutApp = CreateObject("outlook.application")
Set OutMail = OutApp.CreateItem(olMailItem)
With OutMail
.SentOnBehalfOfName = "SalesAnalytics#company.us"
.Display
.Subject = "Sales Report"
.To = "mike.marshall#company.us"
'.CC =
'.BCC =
'.Attachments.Add "\\filesrv1\department shares\Sales Report\Sales Report.xlsx"
.HTMLBody = "<br>" _
& "Attached is the Sales Report. Please reach out to me with any questions." _
& "<br><br>" _
& "<p align=left>" & fncRangeToHtml("RegAEPctg", "B2:P67") & "<p>" _
& .HTMLBody
.Display
'.Send
End With
Set OutApp = Nothing
Set OutMail = Nothing
End Sub
Private Function fncRangeToHtml( _
strWorksheetName As String, _
strRangeAddress As String) As String
Dim objFilesytem As Object, objTextstream As Object, objShape As Shape
Dim strFilename As String, strTempText As String
Dim blnRangeContainsShapes As Boolean
Set objTextstream = Nothing
Set objFilesytem = Nothing
'Kill strFilename
strFilename = Environ$("temp") & "\" & _
Format(Now, "dd-mm-yy_h-mm-ss") & ".htm"
ThisWorkbook.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=strFilename, _
Sheet:=strWorksheetName, _
Source:=strRangeAddress, _
HtmlType:=xlHtmlStatic).Publish True
Set objFilesytem = CreateObject("Scripting.FileSystemObject")
Set objTextstream = objFilesytem.GetFile(strFilename).OpenAsTextStream(1, -2)
strTempText = objTextstream.ReadAll
objTextstream.Close
strTempText = Replace(strTempText, "align=center x:publishsource=", "align=left x:publishsource=")
For Each objShape In Worksheets(strWorksheetName).Shapes
If Not Intersect(objShape.TopLeftCell, Worksheets( _
strWorksheetName).Range(strRangeAddress)) Is Nothing Then
blnRangeContainsShapes = True
Exit For
End If
Next
If blnRangeContainsShapes Then _
strTempText = fncConvertPictureToMail(strTempText, Worksheets(strWorksheetName))
fncRangeToHtml = strTempText
Set objTextstream = Nothing
Set objFilesytem = Nothing
Kill strFilename
End Function
Public Function fncConvertPictureToMail(strTempText As String, objWorksheet As Worksheet) As String
Const HTM_START = "<link rel=File-List href="
Const HTM_END = "/filelist.xml"
Dim strTemp As String
Dim lngPathLeft As Long
lngPathLeft = InStr(1, strTempText, HTM_START)
strTemp = Mid$(strTempText, lngPathLeft, InStr(lngPathLeft, strTempText, ">") - lngPathLeft)
strTemp = Replace(strTemp, HTM_START & Chr$(34), "")
strTemp = Replace(strTemp, HTM_END & Chr$(34), "")
strTemp = strTemp & "/"
strTempText = Replace(strTempText, strTemp, Environ$("temp") & "\" & strTemp)
fncConvertPictureToMail = strTempText
End Function
I'm not a 100% sure but this seems to be cause by your rng to html function.
I had a similar problem with an older range to html I was using, so my solution is a kind of workaround, by rewriting the function you are using.
Can't comment for lack of rep, so please take it with a grain of salt.
I'd suggest using this range_to_html function and expanding it with a workbook open/activate call for your workbook/sheet:
Function RangetoHTML(rng As Range) ' converts a range into html for email-sendout'
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
Dim FSO As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
' Copy the range and create a workbook to receive the data.
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
' Publish the sheet to an .htm file.
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
filename:=TempFile, _
sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
' Read all data from the .htm file into the RangetoHTML subroutine.
Set FSO = CreateObject("Scripting.FileSystemObject")
Set ts = FSO.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
' Close TempWB.
TempWB.Close savechanges:=False
' Delete the htm file.
Kill TempFile
Set ts = Nothing
Set FSO = Nothing
Set TempWB = Nothing
End Function
I've used this for everything range related and no matter what it picked out it was always in line with the general email format.
Source: http://www.mrexcel.com/forum/excel-questions/485720-ron-de-bruin-rangetohtml.html
Since you are reading directly from the file the html might contain the allign command for the code. This one here does copying, and republishing which should circumvent the issue.
I'm also not sure how this code handles shapes, so it might not work for ranges with shapes.
Also if I misunderstood and the problem is that the text in the cells is left aligned lemme know, that would be easier to identify and fix.
I want to substitute the hard codes between the 2 underlined area in VB as indicated, so that it fetches the excel file automatically with code and transfers the spreadsheet into an Ms-Access table with same fields. IT should be able to do this function automatically with vb codes in MS-Access.
Dim fso As Object 'FileSystemObject
Dim f As Object 'File
Dim strTempPath As String
Dim objExcel As Object 'Excel.Application
Dim objWorkbook As Object 'Excel.Workbook
Const TemporaryFolder = 2
On Error Resume Next
StrSQL = "DELETE * FROM bed_code_tbl"
DoCmd.SetWarnings False
DoCmd.RunSQL StrSQL
Set fso = CreateObject("Scripting.FileSystemObject") 'New FileSystemObject
strTempPath = fso.GetSpecialFolder(TemporaryFolder) & "\" & fso.GetTempName & "\"
fso.CreateFolder strTempPath
'------------------------------------------------------
Set f = fso.GetFile("C:\Users\johnpfe\Documents\Bed_code_tbl.xlsx")
fso.CopyFile f.Path, strTempPath & f.Name
'--------------------------------------------------------
Set objExcel = CreateObject("Excel.Application") ' New Excel.Application
Set objWorkbook = objExcel.Workbooks.Open(strTempPath & f.Name)
objWorkbook.ActiveSheet.Range("A1:C100").Select
objWorkbook.Save
Set objWorkbook = Nothing
objExcel.Quit
Set objExcel = Nothing
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, "bed_code_tbl",
strTempPath & f.Name, True
fso.DeleteFile strTempPath & f.Name
fso.DeleteFolder Left(strTempPath, Len(strTempPath) - 1)
Set f = Nothing
Set fso = Nothing
End Sub
'----------------------------------------------------------------------
I'm assuming that you're trying to find the current user's documents folder.
You can use the eviron() function. More on that if you follow these links.
http://msdn.microsoft.com/en-us/library/office/gg264486(v=office.15).aspx
http://www.tek-tips.com/faqs.cfm?fid=4296
Dim fso As Object 'FileSystemObject
Dim f As Object 'File
Dim strTempPath As String
Dim objExcel As Object 'Excel.Application
Dim objWorkbook As Object 'Excel.Workbook
Const TemporaryFolder = 2
On Error Resume Next
strSQL = "DELETE * FROM bed_code_tbl"
DoCmd.SetWarnings False
DoCmd.RunSQL strSQL
Set fso = CreateObject("Scripting.FileSystemObject") 'New FileSystemObject
strTempPath = fso.GetSpecialFolder(TemporaryFolder) & "\" & fso.GetTempName & "\"
fso.CreateFolder strTempPath
'------------------------------------------------------
Set f = fso.GetFile(Environ("UserProfile") & "\Documents\Bed_code_tbl.xlsx")
fso.CopyFile f.Path, strTempPath & f.NAME
'----------------------------------------------------------------------
You can get folder location for Your access file. And place created file relative to that location.
Alternatively ask user for the location.
I have to insert commas at certain points in lines of text, using VBScript. I need it to check the first four charcters of each line with an if statement and if it matches it inserts the commas required for that line this is what I have so far:
Const ForReading = 1
Const ForWriting = 2
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile("H:\Letter Display\Letters\LTRPRT__00000008720000000001NI-K-RMND.txt", ForReading)
strNIK = "1000"
strLine = objFile.ReadLine
If Left(strLine,4) = strNIK then
arrCommas = Array(16,31,46,56,66,79,94,99)
Do Until objFile.AtEndOfStream
intLength = Len(strLine)
For Each strComma in arrCommas
strLine = Left(strLine, strComma - 1) + "," + Mid(strLine, strComma, intLength)
Next
strText = strText & strLine & vbCrLf
Loop
end if
objFile.Close
Set objFile = objFSO.OpenTextFile("H:\Letter Display\Letters\LTRPRT__00000008720000000001NI-K-RMND.txt", ForWriting)
objFile.Write strText
objFile.Close
If anyone could help with making this an IF statement it would be much appreciated.
You need to move the ReadLine and the conditional inside the Do..Loop:
strNIK = "1000"
arrCommas = Array(16,31,46,56,66,79,94,99)
Do Until objFile.AtEndOfStream
strLine = objFile.ReadLine
If Left(strLine, 4) = strNIK then
intLength = Len(strLine)
For Each strComma in arrCommas
strLine = Left(strLine, strComma - 1) + "," _
+ Mid(strLine, strComma, intLength)
Next
End If
strText = strText & strLine & vbCrLf
Loop
If you want the output to consist only of the modified lines, move the line strText = strText & strLine & vbCrLf inside the conditional:
If Left(strLine, 4) = strNIK then
'...
strText = strText & strLine & vbCrLf
End If
Do the comma indexes in your array already account for the positional shift that is caused by the character insertion?
Also, it might be a good idea to write the output line by line to a temporary file and then replace the input file with that temporary file after you finished processing all input:
Set inFile = objFSO.OpenTextFile(inputFilename, ForReading)
Set outFile = objFSO.OpenTextFile(outputFilename, ForWriting)
Do Until inFile.AtEndOfStream
strLine = inFile.ReadLine
'do stuff with strLine
outFile.WritLine
Loop
inFile.Close
outFile.Close
objFSO.DeleteFile inputFilename, True
objFSO.MoveFile outputFilename, inputFilename
That way you can avoid memory exhaustion when processing large files.
You can process all files with a specific extension in a given directory like this:
folderName = "C:\some\folder"
For Each objFile In objFSO.GetFolder(folderName).Files
If LCase(objFSO.GetExtensionName(objFile.Name)) = "ltr" Then
'processing takes place here
End If
Next
If you want to use the inputfile/outputfile approach I suggested above, you can either use the same temporary outputfile name for each input file, or you can derive the outputfile name from the inputfile name, e.g. like this:
inputFilename = objFile.Name
outputFilename = inputFilename & ".tmp"
I used the code below to import CSV files from a local folder then into a table in Access.
However, I noticed the Leading Zeros are missing/truncated.
Not sure why as I was under the impression that Access did not cut off the zeros.
I tried padding with zeros but not working. I am thinking the leading zeros are being truncated during import into access and since this is happening by code, not sure how to stop it.
Hopefully the great pros here can take a look:
Option Compare Database
Option Explicit
Sub ImportFileProcedure()
Dim strPathFile As String, strFile As String, strPath As String
Dim strTable As String
Dim xlApp As Object, xlWb As Object, xlWs As Object
Dim lngRow As Long, lngLastRow As Long
Dim rst As DAO.Recordset
strPath = "C:\FOLDER\"
strTable = "TEMP_TBL"
strFile = Dir(strPath & "*.csv")
Set rst = CurrentDb.OpenRecordset(strTable)
Do While Len(strFile) > 0
strPathFile = strPath & strFile
Set xlApp = CreateObject("Excel.Application")
Set xlWb = xlApp.Workbooks.Open(strPathFile)
Set xlWs = xlWb.Worksheets(1)
lngLastRow = xlWs.UsedRange.Rows.Count
For lngRow = 2 To lngLastRow
rst.AddNew
rst("SAMPLE") = xlWs.Range("A" & lngRow).Value
rst("SAMPLE") = xlWs.Range("B" & lngRow).Value
rst("SAMPLE") = xlWs.Range("C" & lngRow).Value
rst("SAMPLE") = xlWs.Range("D" & lngRow).Value
rst("SAMPLE") = xlWs.Range("E" & lngRow).Value
rst.Update
Next
xlApp.Quit
Set xlApp = Nothing
Set xlWb = Nothing
Set xlWs = Nothing
strFile = Dir()
Loop
rst.Close
Set rst = Nothing
End Sub
Thanks for looking
I decided to simply create an UPDATE query that adds/pads the leading zeros, the UPDATE is run after the data becomes loaded into the table. This was the best I could do rather than modifying the above code:
This is SQL for the UPDATE Query:
x = left(yourfield & string(8,"0"), 8)
x = right(string(8,"0")& yourfield, 8)
or...
padlen = 8
x = left(yourfield & string(padlen,"0"), padlen)
x = right(string(padlen,"0")& yourfield, padlen)
Thanks everyone!