I am cleaning up some of my late father's Visual Basic 6 code, which takes info from a weather station and plants it in files for a website.
I was wondering how I can deal with an EoF error for this code.
Open "LastRun.txt" For Input As #4
Line Input #4, adate
adate = Trim(adate)
flds = Split(adate, "/")
If Len(flds(0)) = 1 Then flds(0) = "0" & flds(0)
If Len(flds(1)) = 1 Then flds(1) = "0" & flds(1)
thismonth = Trim(flds(2)) & "-" & Trim(flds(0))
Close 4
If Not SkipUpdate Then
Open "cvtbmp.sh" For Output As #3
Print #3, "cd /history" & vbLf;
For i = 1 To lastfile
aline = files(i)
oline = "/usr/local/bin/convert -quality 40 " & aline & " " & Replace(aline, ".bmp", ".jpg")
Print #3, oline & vbLf;
Next
Open "LastRun.txt" For Output As #4
Print #4, Date
Close
Occasionally the LastRun.txt ends up empty (mainly after a long period of downtime or power outages).
The code will fix itself if I can skip to the If Not SkipUpdate Then Line when I have the EoF error at Line Input #4, adate
I feel as though the fix might be very simple, I just lack experience with VB6 and error handling.
You can check for EOF:
Open "LastRun.txt" For Input As #4
If Not EOF(4) Then
Line Input #4, adate
adate = Trim(adate)
flds = Split(adate, "/")
If Len(flds(0)) = 1 Then flds(0) = "0" & flds(0)
If Len(flds(1)) = 1 Then flds(1) = "0" & flds(1)
thismonth = Trim(flds(2)) & "-" & Trim(flds(0))
End If
Close 4
If Not SkipUpdate Then
Open "cvtbmp.sh" For Output As #3
Print #3, "cd /history" & vbLf;
For i = 1 To lastfile
aline = files(i)
oline = "/usr/local/bin/convert -quality 40 " & aline & " " & Replace(aline, ".bmp", ".jpg")
Print #3, oline & vbLf;
Next
Open "LastRun.txt" For Output As #4
Print #4, Date
Close
Input past end of file" sometimes happen when you use print instead of write...
Related
long time user of the forum but first time I'm actually asking something so please let me know if I'm doing something wrong.
So I'm writing a Powerpoint Macro that basically just go through all Powerpoint files in a given path and just go through and check for anything that might be of interest.
My code runs great so no real need for help with it but at one point I'm checking for embedded videos or sound by using the shape.mediatype property.
problem is, I found this https://learn.microsoft.com/en-us/office/vba/api/powerpoint.ppmediatype to know what I can expect to find with this property but I have no idea what ppMediaTypeMixed or ppMediaTypeOther actually are in th real world and unfortunately microsoft just telling me "It's mixed media!" doesn't really help either.
If anyone could let me know what these two actually represent I would really appreciate it.
if anyone is interested, code for the macro is below (still a WIP and I only started vba a few month ago by teaching myself so don't judge it too hard pls)
Sub PowerPoint_Check_v2()
Dim fldpath As String
Dim filepath As String
Dim Longsum As String
Dim Shortsum As String
Dim com As Comment
Dim pres As Presentation
Dim hyp As hyperlink
Dim sld As Slide
Dim dsg As Design
Dim cstmly As CustomLayout
Dim shape As shape
Dim totnote As Long
Dim tothyp As Long
Dim sldcom As Long
Dim totcom As Long
Dim curdsg As Long
Dim dsgcstmly As Long
Dim hypsld As Long
Dim totchart As Long
Dim sldchart As Long
Dim cursld As Long
Dim hidsld As Long
fldpath = UserForm1.TextBox1.Text & "\"
filepath = Dir(fldpath & "*.ppt*")
'loop through all ppt/pptx/pptm in that path
Do While filepath <> ""
totchart = 0
tothyp = 0
sldchart = 0
cursld = 1
hidlsd = 0
curdsg = 1
tothyp = 0
On Error Resume Next 'this is really only for testing cause I actually can't be f***** to delete the folders every time since it overwrites the files
MkDir (fldpath & "Detailled reports")
MkDir (fldpath & "Short Summary reports")
Shortsum = fldpath & "Short Summary reports\ShortSum_" & filepath & ".txt"
Longsum = fldpath & "Detailled reports\DetailRep_" & filepath & ".txt"
Open Shortsum For Output As #1
Open Longsum For Output As #2
Set pres = Application.Presentations.Open(fldpath & filepath)
With pres
Print #1, "filename: " & .Name
Print #1, "Total number of slides: " & .Slides.Count
Print #2, "filename: " & .Name
Print #2, "Total number of slides: " & .Slides.Count
'count master designs
Print #1, "Number of master designs: " & .Designs.Count
Print #2, "Number of master designs: " & .Designs.Count
'count custom layouts
For Each dsg In .Designs
For Each cstmly In .SlideMaster.CustomLayouts
If cstmly.Shapes.Count <> 0 Then
dsgcstmly = dsgcstmly + 1
End If
Next
Print #2, "Master design " & curdsg & " has " & dsgcstmly & " custom layouts"
curdsg = curdsg + 1
dsgcstmly = 0
Next
'go through all slides and ungroup everything to avoid missing anything
Do While cursld < .Slides.Count
For Each sld In .Slides
For Each shape In sld.Shapes
On Error Resume Next
shape.Ungroup
Next
Next
cursld = cursld + 1
Loop
'Start looking through each slide
For Each sld In .Slides
Print #2, "------------Slide " & sld.SlideNumber & "------------"
'check if hidden
If sld.SlideShowTransition.Hidden = msoTrue Then
hidsld = hidsld + 1
Print #2, vbTab & "-Is Hidden "
Else: Print #2, vbTab & "-Is vsible"
End If
'check for speaker note
If sld.NotesPage.Shapes(2).TextFrame.TextRange.Text <> "" Then
If sld.NotesPage.Shapes(2).TextFrame.TextRange.Characters.Count > 1 Then
totnote = totenote + 1
Print #2, vbTab; "-Has speaker notes"
End If
Else: Print #2, vbTab & "-No speaker notes"
End If
'check for comments
If sld.Comments.Count > 0 Then
totcom = totcom + 1
For Each com In sld.Comments
sldcom = sldcom + 1
Next
Print #2, vbTab & "-Has " & sldcom & " comments"
sldcom = 0
Else: Print #2, vbTab & "-Has no comments"
End If
'start checking shapes
For Each shape In sld.Shapes
'Check for pictures/dead images
If InStr(1, shape.Name, "Picture") <> 0 Then
sldpic = sldpic + 1
End If
'check for charts (which could have embedded Excels)
If shape.HasChart Then
sldchart = sldchart + 1
End If
'check for embedded media
If shape.Type = msoMedia Then
If shape.MediaType = ppMediaTypeMovie Then
Debug.Print ("movie")
sldmov = sldmov + 1
ElseIf shape.MediaType = ppMediaTypeSound Then
Debug.Print ("sound")
sldsound = sldsound + 1
ElseIf shape.MediaType = ppMediaTypeMixed Then
Debug.Print ("mixed") 'the f*** is this?
ElseIf shape.MediaType = ppMediaTypeOther Then
Debug.Print ("Other") 'the f*** is that?
End If
End If
Next
'check and print shape chck results
If sldchart > 0 Then
totchart = totchart + 1
Print #2, vbTab & "-There are " & sldchart & " charts with an embedded Excel."
Else: Print #2, vbTab & "-No chart present."
End If
If sldpic > 0 Then
totpic = totpic + 1
Print #2, vbTab & "-Has " & sldpic & " pictures that might contain text."
Else: Print #2, vbTab & "-No images present"
End If
'check for hyperlinks (skips links to other parts of the presentation)
If sld.Hyperlinks.Count > 0 Then
For Each hyp In sld.Hyperlinks
If hyp.Address <> "" Then
hypsld = hypsld + 1
End If
Next
End If
If hypsld > 0 Then
tothyp = tothyp + 1
Print #2, vbTab & "-Has " & hypsld & " hyperlinks."
Else: Print #2, vbTab & "-No Hyperlinks."
End If
sldpic = 0
sldchart = 0
hypsld = 0
Next
.Close
End With
pog: filepath = Dir 'clear filepath so that it can loop to the next one
Print #1, _
hidlsd & " hidden slides" & vbLf _
; totnote & " slides with speaker notes" & vbLf _
; totcom & " slides with comments" & vbLf _
; totpic & " slides with dead images" & vbLf _
; totchart & " slides with charts" & vbLf _
; tothyp & " slides with hyperlinks"
Close #1
Close #2
Loop
End Sub
ppMediaTypeMixed should probably only apply to ShapeRange objects, not individual Shapes. If you insert a video and a sound file, then select both, then
MsgBox ActiveWindow.Selection.ShapeRange.MediaType
will tell you it's a -2, or ppMediaTypeMixed. I doubt you'd ever get this result back from an individual shape, and even if you grouped the vid and sound shapes, the group wouldn't be a media object.
I am trying to copy an Excel range to a .txt file.
The export is successful, with one exception, It adds one "extra" empty line at the end.
I've read and tests many of the solution on SO (and other sites), but still without any success.
My Code (relevant part)
' === Export to the .txt file ===
Dim TxtFileName As String, lineText As String
TxtFileName = ThisWorkbook.Path & "\Inv_" & Format(Date, "yyyymmdd") & ".txt"
Open TxtFileName For Output As #1
With StockSht
For i = 1 To LastRow
For j = 1 To 3
If j = 3 Then
lineText = lineText & .Cells(i, j).Value2
Else ' j = 1 or 2
lineText = lineText & .Cells(i, j).Value2 & vbTab
End If
Next j
Print #1, lineText
lineText = ""
Next i
End With
Close #1
My StockSht (worksheet object) and LastRow are defined correctly, and getting their values.
Screen-shot of the end of the exported .txt file
You can use a semi-colon in the Print statement to control the insertion point (i.e. prevent the line-feed on the last line).
The relevant bit on the MSDN page:
Use a semicolon to position the insertion point immediately after the last character displayed.
I tested this code:
Sub PrintTest()
Dim lng As Long
Open "C:\foo3.txt" For Output As #1
For lng = 1 To 10
If lng < 10 Then
Print #1, "foo" & lng
Else
Print #1, "foo" & lng; '<-- semi-colon prevents the newline
End If
Next lng
Close #1
End Sub
So I would update your code like below (not tested):
' === Export to the .txt file ===
Dim TxtFileName As String, lineText As String
TxtFileName = ThisWorkbook.Path & "\Inv_" & Format(Date, "yyyymmdd") & ".txt"
Open TxtFileName For Output As #1
With StockSht
For i = 1 To LastRow
For j = 1 To 3
If j = 3 Then
lineText = lineText & .Cells(i, j).Value2
Else ' j = 1 or 2
lineText = lineText & .Cells(i, j).Value2 & vbTab
End If
Next j
'--- new bit: check for i against LastRow and add the semicolon on last row
If i <> LastRow Then
Print #1, lineText
Else
Print #1, lineText; '<-- semi colon keeps insertion point at end of line
End If
lineText = ""
Next i
End With
Close #1
Try using a ; on the last print line.
' === Export to the .txt file ===
Dim TxtFileName As String, lineText As String
TxtFileName = ThisWorkbook.Path & "\Inv_" & Format(Date, "yyyymmdd") & ".txt"
Open TxtFileName For Output As #1
With StockSht
For i = 1 To LastRow
For j = 1 To 3
If j = 3 Then
lineText = lineText & .Cells(i, j).Value2
Else ' j = 1 or 2
lineText = lineText & .Cells(i, j).Value2 & vbTab
End If
Next j
If i = LastRow Then
Print #1, lineText;
Else
Print #1, lineText
End if
lineText = ""
Next i
End With
Close #1
I have a simple questions, after reading from record set and writing ti file in end of loop I need to write in the first line (rowcount) code as below:
sFileName = "C:\filename.csv"
RowCount = 0
Open sFileNameFor Output As #1
Do While Not rst.EOF
'Print #1, rst!Name
Print #1, rst.Fields(0).Value & "|" & rst.Fields(1) ... rst.Fields(n).Value
RowCount = RowCount + 1
rst.MoveNext
Loop
'--header and rowcount
Print #1, "Header Line" & RowCount
I am not finding out how to add header in the first line of file "C:\filename.csv"
Thanks in advance
I found this code which does the job - add it just below the Loop command:
Dim sFileContents As String
Close #1
Open sFileNameFor For Binary As 1
sFileContents = Space$(LOF(1))
Get #1, 1, sFileContents
Put #1, 1, "Header Line " & RowCount & vbCrLf
Put #1, , sFileContents
Close #1
Source:
http://www.pcreview.co.uk/threads/how-write-into-text-file-at-first-and-last-line-with-excel-vba.4046562/
Afaik, there is no collection of every Field.Name in the recordset. Instead, you have to loop over the collection Fields and get each items .Name-property like so:
For i = 1 To rst.Fields.Count
Debug.Print rst.Fields(i - 1).Name
Next i
Generate a string out of that with, let's say, something like this:
Dim strHeader as String
strHeader = rst.Fields(0).Name
For i = 1 To rst.Fields.Count - 1
strHeader = strHeader & "|" & rst.Fields(i).Name
Next i
Counting i is obviously a bit weird, bc, you know, 0-based arrays in VBA.
Hope that helps.
I am new to vba and am trying to create a simple macro to export some data to a text file. I have that working, however, when a user applies any filters that hide rows, it simply exports all data from the first row to the last row, disregarding anything filtered out. I have searched all over, but (probably from my lack of experience with vba) I cannot find anything that will work with both the user's filter and their selection. The thing is, I don't even know if filtered rows are considered by excel to be "hidden". I've also tried many methods other than what was listed below, such as .AutoFilter and .SpecialCells(xlCellTypeVisible), however neither of them work with Selection.
Sub old_export_for()
Dim myFile As String, rng As Range, cellValue As Variant, i As Integer, j As Integer
myFile = "C:\OUT\old_out_" + CStr(Format(Now(), "mmddhhmm")) + ".txt"
Set rng = Selection
Open myFile For Output As #1
For i = 1 To rng.Rows.Count
If Not rng.Rows.Hidden Then
j = 1
cellValue = rng.Cells(i, j).Value
Print #1, "Filename : " + CStr(cellValue)
j = 2
cellValue = rng.Cells(i, j).Value
Print #1, "File Size : " + CStr(cellValue)
j = 3
cellValue = rng.Cells(i, j).Value
Print #1, "Hostname : " + CStr(cellValue)
j = 4
cellValue = rng.Cells(i, j).Value
Print #1, "Date : " + CStr(cellValue)
j = 5
cellValue = rng.Cells(i, j).Value
Print #1, "Session ID : " + CStr(cellValue),
Print #1, vbNewLine + vbNewLine
End If
Next i
Close #1
End Sub
Change
If Not rng.Rows.Hidden Then
to
If Not rng.Rows(i).EntireRow.Hidden Then
Just to show how I would put this with the SpecialCells:
Sub old_export_for()
Dim myFile As String, rng As Range, cellValue As Variant, xRow As Variant
myFile = "C:\OUT\old_out_" + CStr(Format(Now(), "mmddhhmm")) & ".txt"
Set rng = Selection.SpecialCells(xlCellTypeVisible)
Open myFile For Output As #1
For Each xRow In rng.Rows
Print #1, "Filename : " & CStr(xRow.Cells(1).Value)
Print #1, "File Size : " & CStr(xRow.Cells(2).Value)
Print #1, "Hostname : " & CStr(xRow.Cells(3).Value)
Print #1, "Date : " & CStr(xRow.Cells(4).Value)
Print #1, "Session ID : " & CStr(xRow.Cells(5).Value)
Print #1, vbNewLine & vbNewLine
Next i
Close #1
End Sub
still, for a sub this short, I'd use something non-readable like this:
Sub old_export_for()
Dim xRow As Variant, i As Long, str As String
Open "C:\OUT\old_out_" + CStr(Format(Now(), "mmddhhmm")) & ".txt" For Output As #1
For Each xRow In Selection.SpecialCells(xlCellTypeVisible).Rows: For i = 1 To 6
Print #1, Array("Filename : ", "File Size : ", "Hostname : ", "Date : ", "Session ID : ", vbNewLine)(i - 1) & Array(CStr(xRow.Cells(i).Value), vbNewLine)(1 + (i < 6))
Next: Next
Close #1
End Sub
But do not do this :P
If this is not helpful, I will delete the answer. Say we have AutoFiltered data in Sheet1. This tiny macro will take the header row and all the visible data rows and copy them to Sheet2
Sub AutoFilterCopyVisible()
Sheets("Sheet1").AutoFilter.Range.Copy
Sheets("Sheet2").Paste
End Sub
After running this, you can export Sheet2. If Sheet1 is like:
then Sheet2 will have:
Note:
There is no autofiltering in the output sheet.
This is the header of my main function to write excel cells to an XML file. I want this to call another function, which can do its own set of writing.
Public Sub WriteXML()
Dim Sheet As Worksheet
Dim Cell As Range
Dim xmlFile
xmlFile = ThisWorkbook.Path & "\" & 'Test1' & ".xml"
Set Sheet = ActiveWorkbook.Worksheets("Sht1")
Open xmlFile For Output As #1
Print #1, "<?xml version=" & Chr(34) & "1.0" & Chr(34) & _
" encoding=" & Chr(34) & "UTF-8" & Chr(34) & "?>"
Call WriteCustomer(xmlFile)
This is the start of the second function, though I'm getting an 'object not found' sort of error.
Sub WriteCustomer(x As Variant)
Print x, " <Customer>"
Print x, " <First>" & 'Bill' & "</First>"
Print x, " <Last>" & 'Johnson' & "</Last>"
Print x, " </Customer>"
Print x, ""
End Sub
How do I need to construct the call and/or variable to pass the open file as an object to the second function?
You can request, store and pass around a handle as follows:
Dim handle As Integer
handle = FreeFile()
Open xmlFile For Output As #handle
Print #handle, "<?xml version=" & Chr(34) & "1.0" & Chr(34) & _
...
Call WriteCustomer(handle)
And
Sub WriteCustomer(handle As Integer)
Print #handle, " <Customer>"
Since you have opened the file in the first function with the line
Open xmlFile For Output As #1
Any code that references #1 while it's open will write to the same file. Thus you can simply rewrite your second function as
Sub WriteCustomer()
Print #1, " <Customer>"
Print #1, " <First>" & 'Bill' & "</First>"
Print #1, " <Last>" & 'Johnson' & "</Last>"
Print #1, " </Customer>"
Print #1, ""
End Sub