i am working on this project, which I login in to router . ping to some IP, if i increase the packet size to 4, the O/p will be display result of Percent & roundtrip quicker as compared to packet count-100 which takes time. so need code so that Vb check the file real-time like "screening window" and if wherever it find the Percent & roundtrip on cmd windows it will send logout/exit/some my stuff to cmd and display in the MsgBox .
i need help on Vb checking the txt file real-time , if not found, close the file and again open for rechecking and so on or may be like "screening window" ..
pl help .
My original Code is below.
====================
Private Sub Runcode()
i = Shell("\windows\system32\cmd.exe", vbNormalFocus)
Dim MY_SERVER_IP As String
Dim LocalHost As String
Dim SourceIP As String
Dim DestinationIP As String
Dim Number As String
Dim Size As String
MY_SERVER_IP = "97.1.2.2"
Application.Wait (Now + TimeValue("0:00:02"))
SendKeys "telnet " & MY_SERVER_IP & " 6000 -f D:\Report\PING.txt{ENTER}"
Application.Wait (Now + TimeValue("0:00:02"))
SendKeys " Command to Login the Router"
Application.Wait (Now + TimeValue("0:00:02"))
SendKeys " PING IP: SRN=0, SN=14, SIPADDR=some_Source_IP , DESTIP=Some_Destination_IP, CONTPING=NO, TIMES=4, PKTSIZE=1400; "
Application.Wait (Now + TimeValue("0:00:50"))
' for short packet Number also i have to wait around 50 sec
' here currently Times=4 means it will recieve 4 reply packets which will show the result in 4 sec
' but same if i change it to 50 it wll take around 30-50 sec
Dim sFileName As String
Dim iFileNum As Integer
Dim sBuf As String
Dim Fields As String
Dim buffer As String
buffer = "round-trip"
sFileName = "D:\Report\PING.txt"
''//Does the file exist?
If Len(Dir$(sFileName)) = 0 Then
MsgBox ("File not Created")
End If
iFileNum = FreeFile()
Open sFileName For Input As iFileNum
Do While Not EOF(iFileNum)
Line Input #iFileNum, Fields
If Fields <> buffer Then
Call hint
Else
MsgBox ("didnt Work")
End If
Loop
Close iFileNum
End Sub
Close sFileName
Sub hint()
Dim myFile As String, text As String, textline As String, pkt As String, rndtrip As String
Dim objShell
Set objShell = CreateObject("WScript.Shell")
objShell.AppActivate "Telnet " & MY_SERVER_IP
objShell.SendKeys "Logout{enter}"
objShell.Application.Wait (Now + TimeValue("0:00:02"))
objShell.SendKeys "Exit{enter}"
myFile = "D:\Report\PING.txt"
Open myFile For Input As #1
Do Until EOF(1)
Line Input #1, textline
text = text & textline
Loop
Close #1
pkt = Trim(Mid(text, InStr(text, "Percent") + 0, (InStrRev(text, "packet") + 0) - (InStr(text, "Percent") + 1)))
rndtrip = Trim(Mid(text, InStr(text, "round-trip") + 0, (InStrRev(text, "ms") + 0) - (InStr(text, "round-trip") + 1)))
Call MsgBox("Percent : " & pkt & " Round-Trip : " & rndtrip & ".", vbOKOnly)
End Sub
Try Adding this line. Your loop will only fire if the file exist.
If System.IO.File.Exists(myFile )
Do Until EOF(1)
Line Input #1, textline
text = text & textline
Loop
Close #1
else
' if the file is not there rerun the method.
Runcode()
end if
Related
I am trying to work on a code that will give me the user activity on the userform that I have created. I want to keep this logs file in shared drive if possible.
below is my code, not getting any records in logs folder
Sub LogInformation(LogMessage As String)
Const LogFileName As String = "D:\FOLDERNAME\TEXTFILE.LOG"
Dim FileNum As Integer
FileNum = FreeFile ' next file number
Open LogFileName For Append As #FileNum ' creates the file if it doesn't exist
Print #FileNum, LogMessage ' write information at the end of the text file
Close #FileNum ' close the file
End Sub
Public Sub DisplayLastLogInformation()
Const LogFileName As String = "D:\FOLDERNAME\TEXTFILE.LOG"
Dim FileNum As Integer, tLine As String
FileNum = FreeFile ' next file number
Open LogFileName For Input Access Read Shared As #f ' open the file for reading
Do While Not EOF(FileNum)
Line Input #FileNum, tLine ' read a line from the text file
Loop ' until the last line is read
Close #FileNum ' close the file
MsgBox tLine, vbInformation, "Last log information:"
End Sub
Sub DeleteLogFile(FullFileName As String)
On Error Resume Next ' ignore possible errors
Kill FullFileName ' delete the file if it exists and it is possible
On Error GoTo 0 ' break on errors
End Sub
Private Sub Workbook_Open()
LogInformation ThisWorkbook.Name & " opened by " & _
Application.UserName & " " & Format(Now, "yyyy-mm-dd hh:mm")
End Sub
Filename = Dir(Filepath & "\" & "*.csv")
While Filename <> ""
SourceFile = Filepath & "\" & Filename
TargetFile = SavePath & "\" & Replace(Filename, ".csv", ".txt")
OpenAsUnicode = False
Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject")
'Detect Unicode Files
Dim Stream: Set Stream = objFSO.OpenTextFile(SourceFile, 1, False)
intChar1 = Asc(Stream.Read(1))
intChar2 = Asc(Stream.Read(1))
Stream.Close
If intChar1 = 255 And intChar2 = 254 Then
OpenAsUnicode = True
End If
'Get script content
Set Stream = objFSO.OpenTextFile(SourceFile, 1, 0, OpenAsUnicode)
arrData = Stream.ReadAll()
Stream.Close
'Create output file
Dim objOut: Set objOut = objFSO.CreateTextFile(TargetFile)
objOut.Write Replace(Replace(arrData,",", "#|#"), Chr(34), "") '-- This line is working fine but it is replacing all the commas inside the text qualifier as well..
objOut.Close
Filename = Dir
Wend
In the above code the line objOut.Write Replace(Replace(arrData,",", "#|#"), Chr(34), "") is replacing all the commas with #|# including the commas inside string.so I want to replace only commas which are not in double quotes.
File containing the string
"A","B,C",D
Result I need is
A#|#B,C#|#D
Thanks for your help in advance.
How about something along the line of:
objOut.Write Mid(Replace(Replace(arrData,""",""", "#|#"), Chr(34), ""), 2)
Basically, this exchanges now "," for #|#. But that's not enough as the file begins with a ". So, this one is being eliminated using the Mid() function. If the file also ends with a " then you would have to adjust that as well.
Based on the speed concerns noted in the comments here is the complete code which I used to test this solution:
Option Explicit
Option Compare Text
Public Sub ConvertFile()
Dim lngRowNumber As Long
Dim strLineFromFile As String
Dim strSourceFile As String
Dim strDestinationFile As String
strSourceFile = "C:\tmp\Extract.txt"
strDestinationFile = "C:\tmp\Extract_b.txt"
Open strSourceFile For Input As #1
Open strDestinationFile For Output As #2
lngRowNumber = 0
Do Until EOF(1)
Line Input #1, strLineFromFile
strLineFromFile = Mid(Replace(strLineFromFile, """,""", "#|#"), 2)
Write #2, strLineFromFile
strLineFromFile = vbNullString
Loop
Close #1
Close #2
End Sub
The tested file was 350 MB with a bit over 4 million rows. The code completed in less than a minute.
I have the following VBA code:
Sub read_in_data_from_txt_file()
Dim dataArray() As String
Dim i As Integer
Const strFileName As String = "Z:\sample_text.txt"
Open strFileName For Input As #1
' -------- read from txt file to dataArrayay -------- '
i = 0
Do Until EOF(1)
ReDim Preserve dataArray(i)
Line Input #1, dataArray(i)
i = i + 1
Loop
Close #1
Debug.Print UBound(dataArray())
End Sub
I'm trying to read in text line by line (assume 'sample.txt' is a regular ascii file) from a file and assign this data to consecutive elements in an array.
When I run this, I get all my data in the first value of the array.
For example, if 'sample.txt' is:
foo
bar
...
dog
cat
I want each one of these words in a consecutive array element.
What you have is fine; if everything ends up in dataArray(0) then the lines in the file are not using a CrLf delimiter so line input is grabbing everything.
Instead;
open strFileName for Input as #1
dataArray = split(input$(LOF(1), #1), vbLf)
close #1
Assuming the delimiter is VbLf (what it would be coming from a *nix system)
Here is a clean code on how to use for each loop in VBA
Function TxtParse(ByVal FileName As String) As String
Dim fs, ts As Object
Dim strdic() As String
Dim oitem As Variant
Set fs = CreateObject("Scripting.FileSystemObject")
Set ts = fs.OpenTextFile(FileName, 1, False, -2)
strdic = Split(ts.ReadAll, vbLf)
For Each oitem In strdic
If InStr(oitem, "YourString") <> 0 Then
Else
If InStr(1, oitem, vbTab) <> 0 Then
Debug.Print "Line number is : "; "'" & Replace(oitem, vbTab, "','") & "'"
Else
Debug.Print "Line number is : "; "'" & Replace(oitem, ",", "','") & "'"
End If
End If
Next
End Function
Can someone assist with how I can use this function below that converts my data in an excel file to an XML file in a sub? When I go to create a macro it by default has it for sub but I need to have it as a function. I need to be able to use this as maybe a custom button on the toolbar possibly or how can I use it for any spreadsheet I need to convert it from Excel to an XML file?
Public Function ExportToXML(FullPath As String, RowName _
As String) As Boolean
On Error GoTo ErrorHandler
Dim colIndex As Integer
Dim rwIndex As Integer
Dim asCols() As String
Dim oWorkSheet As Worksheet
Dim sName As String
Dim lCols As Long, lRows As Long
Dim iFileNum As Integer
Set oWorkSheet = ThisWorkbook.Worksheets(1)
sName = oWorkSheet.Name
lCols = oWorkSheet.Columns.Count
lRows = oWorkSheet.Rows.Count
ReDim asCols(lCols) As String
iFileNum = FreeFile
Open FullPath For Output As #iFileNum
For i = 0 To lCols - 1
'Assumes no blank column names
If Trim(Cells(1, i + 1).Value) = "" Then Exit For
asCols(i) = Cells(1, i + 1).Value
Next i
If i = 0 Then GoTo ErrorHandler
lCols = i
Print #iFileNum, "<?xml version=""1.0""?>"
Print #iFileNum, "<" & sName & ">"
For i = 2 To lRows
If Trim(Cells(i, 1).Value) = "" Then Exit For
Print #iFileNum, "<" & RowName & ">"
For j = 1 To lCols
If Trim(Cells(i, j).Value) <> "" Then
Print #iFileNum, " <" & asCols(j - 1) & "><![CDATA[";
Print #iFileNum, Trim(Cells(i, j).Value);
Print #iFileNum, "]]></" & asCols(j - 1) & ">"
DoEvents 'OPTIONAL
End If
Next j
Print #iFileNum, " </" & RowName & ">"
Next i
Print #iFileNum, "</" & sName & ">"
ExportToXML = True
ErrorHandler:
If iFileNum > 0 Then Close #iFileNum
Exit Function
End Function
To convert to a Sub that could be run from a button you would change it to:
Public Sub ExportToXML()
This will automatically change the last line to End Sub.
FullPath and RowName will no longer be passed as function-arguments, so would, presumably, need to be read from cells on a worksheet, or perhaps from two InputBoxes.
The Sub would no longer return a Boolean value, so whatever happens with this value would have to be converted to code within the same Sub (or possibly passed to another Sub).
I am writing a function in excel vba
Function WriteByteArray(vData As Variant, sFileName As String, Optional bAppendToFile As Boolean = False) As Boolean
Dim iFileNum As Integer, lWritePos As Long
Debug.Print " --> Entering WriteByteArray function with " & sFileName & " file to write."
On Error GoTo ErrFailed
If bAppendToFile = False Then
If Len(Dir$(sFileName)) > 0 And Len(sFileName) > 0 Then
'Delete the existing file
VBA.Kill sFileName
End If
End If
iFileNum = FreeFile
Debug.Print "iFileNum = " & iFileNum
'Open sFileName For Binary Access Write As #iFileNum
Open sFileName For Binary Lock Read Write As #iFileNum
If bAppendToFile = False Then
'Write to first byte
lWritePos = 1
Else
'Write to last byte + 1
lWritePos = LOF(iFileNum) + 1
End If
Dim buffer() As Byte
buffer = vData
Put #iFileNum, lWritePos, buffer
WriteByteArray = True
Exit Function
ErrFailed:
Debug.Print "################################"
Debug.Print "Error handling of WriteByteArray"
Debug.Print "################################"
FileWriteBinary = False
Close iFileNum
Debug.Print Err.Description & "(" & Err.Number & ")"
End Function
I am getting a permission denied error in VBA.Kill and Open Can any one help me???
You are forgetting to close the file when the function returns, you currently only do so when there is an error.
The file handle persists between runs of you code so when you re-run it you attempt to operate on a file that is already open and explicitly locked, causing an error.