I Have Displayed text file in richtextbox.
and onclick on command button value of textbox1 is being replaced in text file.
but How to keep both data . previous one and another which is entered new in textbox
I HAVE USE THIS CODE BUT IT REPLACES ALL THE TEXT :
Open "D:\chat.txt" For Output As #1
a = Text1.Text
Print #1, a
Close #1
Change For Output to For Append, and it will add the new text to the end of the file instead of overwriting it.
Additional note
Since I'm not able to add a comment to Boann's answer (the one marked as accepted).
The Append access mode used with the Print statement automatically appends a new line at the end of the file. This is fine in almost all cases, but for anyone reading this that wants to avoid this behavior, just add a semicolon at the end of the Print statement (this is the only instance I've seen the semicolon used in VB6).
a = Text1.Text
intHandle = FreeFile
Open "D:\chat.txt" For Append As intHandle
Print #intHandle, a; ' Notice the semicolon; prevents a new line after this output.
Close #intHandle
I'm sure the code you posted originally was just for the sake of getting an answer and is not what your code actually looks like. Otherwise:
To you or any future readers, here's a simple AppendToFile() function which will make repeated calls easier, ensures the file gets closed even if a run-time error is encountered, and shows useful debug information upon failure (i.e. with an invalid filename):
How your original code would be written when putting my below function in your code:
AppendToFile "D:\chat.txt", Text1.Text
And here's the function:
Private Function AppendToFile( _
ByRef FilePath As String, _
ByRef Text As String, _
Optional ByVal AppendNewLine As Boolean = True _
) As Boolean
On Error GoTo ErrorHandler
Dim intHandle As Integer
' Get an available file handle to use.
intHandle = FreeFile
Open FilePath For Append As intHandle
' Only use semicolon at end if we do NOT want to append a new line.
If AppendNewLine Then
Print intHandle, Text
Else
Print intHandle, Text;
End If
Close intHandle
intHandle = 0
AppendToFile = True
Exit Function
ErrorHandler:
' Ensure that file is indeed closed.
If intHandle <> 0 Then
Close intHandle
End If
' Show error in debug window (CTRL+G)
Debug.Print _
"Error (#" & CStr(Err.Number) & ") in " & _
"TextToFile( _" & vbCrLf & _
"`" & FilePath & "`, _" & vbCrLf & _
"`" & Text & "`, _" & vbCrLf & _
IIf(AppendNewLine, "`True`", "`False`") & vbCrLf & _
"): " & Err.Description & IIf("." = Right$(Err.Description, 1), "", ".") & vbCrLf
Exit Function
End Function
Related
Ok, so we need to create a GPO that allows our users to only use specific programs.
GPO Location:
User Configuration
Policies
Administrative Templates [...]
System
Run only specified Windows applications
Then setting the GPO to enabled and clicking on List of allowed applications --> Show...
I have created an excel spreadsheet containing the names of all the programs and their associated executable files with other pertinent information so that we can easily organize, add, delete, etc. the executable files that we need to allow our users access to.
This spreadsheet then dumps all the executable files into a text file.
Here is an example of what the text file looks like:
Acrobat.exe
chrome.exe
calc.exe
.
.
.
There are a lot of entries and these are likely subject to change. What I am trying to do is create a script that will take that text file and populate the GPO automatically. I don't care if we have to open the window and then run it, it does not need to run from the task scheduler (although that would be amazing if someone has that code ready). We just need it to populate this ridiculous amount of executable filenames into the fields.
Here is code I found (VBScript) that when run, should populate the fields automatically, however I cannot get it to run in the Group Policy Management Editor (it runs in the windows explorer window instead and ends up searching for some of the files)
' Open the text file, located in the same path as the script
Set objFSO = CreateObject("Scripting.FileSystemObject")
strPath = Mid(Wscript.ScriptFullName, 1, InStrRev(Wscript.ScriptFullName, wscript.ScriptName) -1)
Set objFile = objFSO.OpenTextFile(strPath & "appList.txt")
' Activate the "Show Contents" window with the "List of allowed applications".
' Note the window must be opened already and we should have selected where in
' the list we want to enter the data before running the script
set WshShell = WScript.CreateObject("WScript.Shell")
WScript.Sleep 1000
WshShell.AppActivate "Show Contents"
' Read the file line by line
Do While objFile.AtEndOfStream <> True
' Each line contains one EXE name
exeName = objFile.ReadLine
' Escape forbidden chars { } [ ] ( ) + ^ % ~
exeName = Replace(exeName, "[", "{[}")
exeName = Replace(exeName, "]", "{]}")
exeName = Replace(exeName, "(", "{(}")
exeName = Replace(exeName, ")", "{)}")
exeName = Replace(exeName, "+", "{+}")
exeName = Replace(exeName, "^", "{^}")
exeName = Replace(exeName, "%", "{%}")
exeName = Replace(exeName, "~", "{~}")
' Send the EXE name to the window
WScript.Sleep 100
WshShell.SendKeys exeName
' Move to the next one
WshShell.SendKeys "{TAB}"
Loop
objFile.Close
from: http://blogs.msdn.com/b/alejacma/archive/2011/03/24/how-to-update-quot-run-only-specified-windows-applications-quot-gpo-programmatically-vbscript.aspx
"C:\Windows\System32\GroupPolicy\User\Registry.pol"
Is where my policies are stored. It's a semi text file. Try writing to that file.
Ok, so I tried it many different ways. If anyone is looking for an answer to do this, this is the way I've figured it out and the way I've decided to proceed. I will post all relevant code below.
In Excel, the format of my table is as follows:
(With obviously WAY more entries)
Here is the VBA code I used to turn the data from this file into the proper format for the registry key:
VBA - In Excel
Public Sub ExportToTextFile(FName As String, _
Sep As String, SelectionOnly As Boolean, _
AppendData As Boolean)
Dim WholeLine As String
Dim FNum As Integer
Dim RowNdx As Long
Dim ColNdx As Integer
Dim StartRow As Long
Dim EndRow As Long
Dim StartCol As Integer
Dim EndCol As Integer
Dim CellValue As String
Application.ScreenUpdating = False
On Error GoTo EndMacro:
FNum = FreeFile
StartRow = 2
If SelectionOnly = True Then
With Selection
StartCol = .Cells(2).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(2).Column
End With
Else
With ActiveSheet.UsedRange
StartCol = .Cells(2).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(2).Column
End With
End If
If AppendData = True Then
Open FName For Append Access Write As #FNum
Else
Open FName For Output Access Write As #FNum
End If
For RowNdx = StartRow To EndRow
WholeLine = ""
For ColNdx = StartCol To EndCol
If Cells(RowNdx, ColNdx).Value = "" Then
CellValue = ""
Else
CellValue = Cells(RowNdx, ColNdx).Value
End If
WholeLine = WholeLine & Chr(34) & CellValue & ".exe" & Chr(34) & "=" & Chr(34) & CellValue & ".exe" & Chr(34) & Sep
Next ColNdx
WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep))
Print #FNum, WholeLine; ""
Next RowNdx
EndMacro:
On Error GoTo 0
Application.ScreenUpdating = True
Close #FNum
End Sub
Sub PipeExport()
Dim FileName As Variant
Dim Sep As String
FileName = Application.GetSaveAsFilename(InitialFileName:="appList", filefilter:="Text (*.txt),*.txt")
If FileName = False Then
''''''''''''''''''''''''''
' user cancelled, get out
''''''''''''''''''''''''''
Exit Sub
End If
Sep = "|"
If Sep = vbNullString Then
''''''''''''''''''''''''''
' user cancelled, get out
''''''''''''''''''''''''''
Exit Sub
End If
Debug.Print "FileName: " & FileName, "Extension: " & Sep
ExportToTextFile FName:=CStr(FileName), Sep:=CStr(Sep), _
SelectionOnly:=False, AppendData:=False
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
PipeExport
End Sub
The file that is created is appList.txt and its format is the same format as the registry key:
"Acrobat.exe"="Acrobat.exe"
"AcroRd32.exe"="AcroRd32.exe"
Now in your GPO, add a unique program name to the allowed applications list (say test1234.exe) and in your registry editor, go to Edit > Find test1234.exe.
Export that registry key under File > Export. Remove the test1234.exe line and paste in your text file. Then reimport that file and you're done!
I've got a spreadsheet that uses some basic code to get the user to select a file (txt file). It works flawlessly on Windows but fails on OSX obviously due to the difference in FileDialog calls. I've done some research though and can't seem to find much information about opening a File Dialog on both OSX and Windows for Excel/VB.
The current code is,
FileToOpen = Application.GetOpenFilename _
(Title:="Please choose a file to import", _
FileFilter:="Excel Files *.xls (*.xls),")
''
If FileToOpen = False Then
MsgBox "No file specified.", vbExclamation, "Duh!!!"
Exit Sub
Else
Workbooks.Open Filename:=FileToOpen
End If
Answer can be found here - http://msdn.microsoft.com/en-us/library/office/hh710200%28v=office.14%29.aspx
Code is as follows,
OSX
Sub Select_File_Or_Files_Mac()
Dim MyPath As String
Dim MyScript As String
Dim MyFiles As String
Dim MySplit As Variant
Dim N As Long
Dim Fname As String
Dim mybook As Workbook
On Error Resume Next
MyPath = MacScript("return (path to documents folder) as String")
'Or use MyPath = "Macintosh HD:Users:Ron:Desktop:TestFolder:"
' In the following statement, change true to false in the line "multiple
' selections allowed true" if you do not want to be able to select more
' than one file. Additionally, if you want to filter for multiple files, change
' {""com.microsoft.Excel.xls""} to
' {""com.microsoft.excel.xls"",""public.comma-separated-values-text""}
' if you want to filter on xls and csv files, for example.
MyScript = _
"set applescript's text item delimiters to "","" " & vbNewLine & _
"set theFiles to (choose file of type " & _
" {""com.microsoft.Excel.xls""} " & _
"with prompt ""Please select a file or files"" default location alias """ & _
MyPath & """ multiple selections allowed true) as string" & vbNewLine & _
"set applescript's text item delimiters to """" " & vbNewLine & _
"return theFiles"
MyFiles = MacScript(MyScript)
On Error GoTo 0
If MyFiles <> "" Then
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
MySplit = Split(MyFiles, ",")
For N = LBound(MySplit) To UBound(MySplit)
' Get the file name only and test to see if it is open.
Fname = Right(MySplit(N), Len(MySplit(N)) - InStrRev(MySplit(N), Application.PathSeparator, , 1))
If bIsBookOpen(Fname) = False Then
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MySplit(N))
On Error GoTo 0
If Not mybook Is Nothing Then
MsgBox "You open this file : " & MySplit(N) & vbNewLine & _
"And after you press OK it will be closed" & vbNewLine & _
"without saving, replace this line with your own code."
mybook.Close SaveChanges:=False
End If
Else
MsgBox "We skipped this file : " & MySplit(N) & " because it Is already open."
End If
Next N
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If
End Sub
Function bIsBookOpen(ByRef szBookName As String) As Boolean
' Contributed by Rob Bovey
On Error Resume Next
bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function
Windows
Sub Select_File_Or_Files_Windows()
Dim SaveDriveDir As String
Dim MyPath As String
Dim Fname As Variant
Dim N As Long
Dim FnameInLoop As String
Dim mybook As Workbook
' Save the current directory.
SaveDriveDir = CurDir
' Set the path to the folder that you want to open.
MyPath = Application.DefaultFilePath
' You can also use a fixed path.
'MyPath = "C:\Users\Ron de Bruin\Test"
' Change drive/directory to MyPath.
ChDrive MyPath
ChDir MyPath
' Open GetOpenFilename with the file filters.
Fname = Application.GetOpenFilename( _
FileFilter:="Excel 97-2003 Files (*.xls), *.xls", _
Title:="Select a file or files", _
MultiSelect:=True)
' Perform some action with the files you selected.
If IsArray(Fname) Then
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
For N = LBound(Fname) To UBound(Fname)
' Get only the file name and test to see if it is open.
FnameInLoop = Right(Fname(N), Len(Fname(N)) - InStrRev(Fname(N), Application.PathSeparator, , 1))
If bIsBookOpen(FnameInLoop) = False Then
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(Fname(N))
On Error GoTo 0
If Not mybook Is Nothing Then
MsgBox "You opened this file : " & Fname(N) & vbNewLine & _
"And after you press OK, it will be closed" & vbNewLine & _
"without saving. You can replace this line with your own code."
mybook.Close SaveChanges:=False
End If
Else
MsgBox "We skipped this file : " & Fname(N) & " because it is already open."
End If
Next N
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If
' Change drive/directory back to SaveDriveDir.
ChDrive SaveDriveDir
ChDir SaveDriveDir
End Sub
Function bIsBookOpen(ByRef szBookName As String) As Boolean
' Contributed by Rob Bovey
On Error Resume Next
bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function
Picker Function
Sub WINorMAC()
' Test for the operating system.
If Not Application.OperatingSystem Like "*Mac*" Then
' Is Windows.
Call Select_File_Or_Files_Windows
Else
' Is a Mac and will test if running Excel 2011 or higher.
If Val(Application.Version) > 14 Then
Call Select_File_Or_Files_Mac
End If
End If
End Sub
Sub WINorMAC_2()
' Test the conditional compiler constants.
#If Win32 Or Win64 Then
' Is Windows.
Call Select_File_Or_Files_Windows
#Else
' Is a Mac and will test if running Excel 2011 or higher.
If Val(Application.Version) > 14 Then
Call Select_File_Or_Files_Mac
End If
#End If
End Sub
I am trying to create a .vbs that will check is a dvd drive exists (if objdrive.drivetype= 4) while ignoring other drives such as hard drives (else if cdrive = 1 then -no statement- ect.).
However this line is causing me grief: "For Each objDrive in colDrives". When it exists it causes a syntax error, yet when it is removed it causes an error saying "object required: objdrive". The script uses a hta/vbs hybrid that offers the user to cancel the search for media, and this is achieved by using a function so putting this in a sub and calling this would be useless. Here is my code, please help.
Set shell=CreateObject("wscript.shell")
Set objShell = Wscript.CreateObject("WScript.Shell")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set colDrives = objFSO.Drives
For Each objDrive in colDrives
if objdrive.drivetype= 4 then
select case 1
case 1
if objdrive.isready then
'continue statement here
else
select case 2
case 2
with HTABox("#F2F2F2", 115, 300, 700, 400)
.document.title = "Waiting..."
.msg.innerHTML = "Waiting for playable media...<b>"
end with
function HTABox(sBgColor, h, w, l, t)
Dim IE, HTA
randomize : nRnd = Int(1000000 * rnd)
sCmd = "mshta.exe ""javascript:{new " _
& "ActiveXObject(""InternetExplorer.Application"")" _
& ".PutProperty('" & nRnd & "',window);" _
& "window.resizeTo(" & w & "," & h & ");" _
& "window.moveTo(" & l & "," & t & ")}"""
with CreateObject("WScript.Shell")
.Run sCmd, 1, False
do until .AppActivate("javascript:{new ") : WSH.sleep 10 : loop
end with ' WSHShell
For Each IE In CreateObject("Shell.Application").windows
If IsObject(IE.GetProperty(nRnd)) Then
set HTABox = IE.GetProperty(nRnd)
IE.Quit
HTABox.document.title = "Waiting"
HTABox.document.write _
"<HTA:Application contextMenu=no border=thin " _
& "minimizebutton=no maximizebutton=no sysmenu=no />" _
& "<body scroll=no style='background-color:" _
& sBgColor & ";font:normal 10pt Arial;" _
& "border-Style:normal;border-Width:0px'" _
& "onbeforeunload='vbscript:if (done.value or cancel.value) then " _
& "window.event.cancelBubble=false:" _
& "window.event.returnValue=false:" _
& "cancel.value=false: done.value=false:end if'>" _
& "<input type=hidden id=done value=false>" _
& "<input type=hidden id=cancel value=false>" _
& "<center><span id=msg> </span><br>" _
& " <center><input type=button id=btn1 value=Cancel
' "_
& "onclick=self.close><center></body>"
exit function
End If
Next
MsgBox "HTA window not found."
wsh.quit
End Function
end select
end select
else if objdrive.drivetype = 1 then
else if objdrive.drivetype = 2 then
else if objdrive.drivetype = 3 then
else if objdrive.drivetype = 5 then
end if
The syntax error is most likely caused by the missing Next keyword that would close the loop. I think the conditional if objdrive.isready then is missing a closing End If too (between the two End Select). Add the missing keywords and the error should go away.
However, you're doing this whole thing upside down. Why are you creating an HTA on the fly from a VBScript? Just write the HTA and embed whatever VBScript code you need in it. See this tutorial for an introduction. Also, I would strongly recommend avoiding nested function definitions. They will cause you maintenance headaches at some point and they're not even generally allowed in VBScript. And what are your Select statements supposed to do? A construct
Select Case 1
Case 1
'instruction
End Select
is utterly pointless, because there is no selection in the first place. It's the exact same as running the instruction directly. Another thing to avoid are empty actions in conditionals. They just make your code harder to read and to maintain without generating you any benefit.
Its possible your issue may be due to the Upper Case D in "objDrive" in your For statement and then you later reference the name with a lower case "d" objdrive.isready within the loop. You may want to declare 'Option Explicit' at the top to find all undeclared variables.
Can you test the below code and see if it performs properly.
Set objFSO = CreateObject("Scripting.FileSystemObject")
For Each objDrive in objFSO.Drives
If objDrive.DriveType = 4 Then
If objDrive.IsReady Then
MsgBox "The appropriate media is inserted and ready for access"
Else
MsgBox "The Drive Is Not Ready"
End If
End If
Next
Also, I'm not sure the code snippet you provided is your full code but there appear to be several missing End statements. If so, these may also cause you problems.
how o write vb code which can except parameter at runtime
ex. My exe is "readfile.exe" and if i want to give file name rom command line the command to be executed will be
readfile.exe filename
it should take the file name parameter and perform the action
Look at the Command function, that should give you all the parameters that were passed in.
I can't find the VB6 docs for it online, but MSDN have the docs for the VBA version, and that's usually the same so I'd suggest looking here for more info. And it even has a full sample here.
You can do something like this:
Sub Main()
Dim a_strArgs() As String
Dim blnDebug As Boolean
Dim strFilename As String
Dim i As Integer
a_strArgs = Split(Command$, " ")
For i = LBound(a_strArgs) To UBound(a_strArgs)
Select Case LCase(a_strArgs(i))
Case "-d", "/d"
' debug mode
blnDebug = True
Case "-f", "/f"
' filename specified
If i = UBound(a_strArgs) Then
MsgBox "Filename not specified."
Else
i = i + 1
End If
If Left(a_strArgs(i), 1) = "-" Or Left(a_strArgs(i), 1) = "/" Then
MsgBox "Invalid filename."
Else
strFilename = a_strArgs(i)
End If
Case Else
MsgBox "Invalid argument: " & a_strArgs(i)
End Select
Next i
MsgBox "Debug mode: " & blnDebug
MsgBox "Filename: " & strFilename
End Sub
I start out with text103.text having a text value of what I want to check C:\test.txt for. So if whatever's in text103.text matches up with whatever's in C:\test.txt label3.caption should read "success" yet every time I run it, I get "failure" why??
So here's the code in my button:
Private Sub Command1_Click()
nFileNum = FreeFile
Open "C:\test.txt" For Input As nFileNum
lLineCount = 1
Do While Not EOF(nFileNum)
Line Input #nFileNum, sNextLine
sNextLine = sNextLine & vbCrLf
sText = sText & sNextLine
Loop
Text102.Text = sText
Close nFileNum
If Text102.Text = Text103.Text Then
Label3.Caption = "success"
Else
Label3.Caption = "failure"
End If
End Sub
Even when my text103.text starts out as "hello" and I edit the C:\test.txt to just say "hello" it always gives me label3.caption "failure"!!! Why???
Possibly because you are always adding a newline to the data read from the file.
Does Text103.Text contain a new line too?
Update:
vbCrLf aka \r\n are part of the set of whitespace characters so you may not be able to see them directly.
Before If Text102.Text = Text103.Text Then try
msgbox "Len 102 " & Len(Text102.Text) & " Len 103 " & Len(Text103.Text)
this will show that the strings are different lengths, therefore they cannot be equal.
Alternatively, in immediate mode try ? "[" & text102.Text & "]" and ? "[" & text103.Text & "]" Assuming the word in question is "Hello", I'll bet the first will print
[Hello
]
and the second
[Hello]
It's because you are adding newline characters text103.text does not have this.
Could it be to do with your trailing carriage return? It looks like your file read will always have a vbCrLf on the end of it whereas possibly your text103 doesn't. Can you go into debug mode and confirm exactly what each string contains?
I'd make a guess that it's to do with the newlines (vbCrLf) that you add, or some similar character.
Otherwise it might be case dependant, you could try adding Option Compare Text at the top of the file.
Try this:
Private Sub Command1_Click()
nFileNum = FreeFile
Open "C:\test.txt" For Input As nFileNum
lLineCount = 1
Do While Not EOF(nFileNum)
Line Input #nFileNum, sNextLine
sNextLine = sNextLine & vbCrLf
sText = sText & sNextLine
Loop
Text102.Text = sText
Close nFileNum
If Replace$(Text102.Text, VBCrLf, "") = Replace$(Text103.Text, VbCrLf, "") Then
Label3.Caption = "success"
Else
Label3.Caption = "failure"
End If
End Sub