How could I, using "ReadProcessMemory" API, loop through all running processes of the machine and scan for an Array of strings and return a true/false value if any one or more are contained in the memory of the process - using VB6?
Example:
Strings() = {"#STRING1#", "#ANOTHERSTRING#", "$TRING"}
Loop # Processes
If InStr(ProcessMemory(#), Strings) Then
MsgBox(Process(#) & " Contains one of the strings!")
End If
Loop
i dont know but i used wmi in my program
something how that
Public Sub KillProcess(ByVal processName As String)
On Error GoTo ErrHandler
Dim oWMI
Dim ret
Dim sService
Dim oWMIServices
Dim oWMIService
Dim oServices
Dim oService
Dim servicename
Set oWMI = GetObject("winmgmts:")
Set oServices = oWMI.InstancesOf("win32_process")
For Each oService In oServices
servicename = LCase$(Trim$(CStr(oService.Name) & ""))
If InStr(1, servicename, LCase(processName), vbTextCompare) > 0 Then
ret = oService.Terminate
End If
Next
If Not oServices Is Nothing Then Set oServices = Nothing
If Not oWMI Is Nothing Then Set oWMI = Nothing
ErrHandler:
Err.Clear
End Sub
Related
I have a Stored Procedure on the SQL Server and I pull the results via VBA (Library: MS ActiveX Data Objects Library, ADODB).
Everything works fine when I only expect the query to return the result for 1 SELECT statement.
Now the Query consists of 5 SELECT statements and I want get all records from each recordset to be put into an array so I can work with the data. I am not able to do so, please help me further.
SQL Query results look like this in SQL Server Management Studio:
I tried different approaches in VBA, but non is working and will lead to different errors.
Error Numbers are either "3251", "3704" or "91".
This is my function to put the results into a RecordSet:
Function getAnalysisInformationFromDB(ByRef rs As Recordset, ByVal sSQL As String) As Boolean
On Error GoTo errHandler
Set cnn = New ADODB.Connection
cnn.Open conString
Set rs = cnn.Execute(sSQL)
rs.MoveFirst
getAnalysisInformationFromDB = True
Exit Function
errHandler:
Dim sErrMsg As String
If Err Then
If Not cnn Is Nothing Then
If cnn.Errors.Count > 0 Then
Dim i As Integer
For i = 0 To cnn.Errors.Count - 1 Step 1
sErrMsg = sErrMsg & cnn.Errors.Item(i) & vbCrLf
Next
End If
End If
If sErrMsg = "" Then
If Err.Number = 3021 Then
sErrMsg = "AnalysisID not found in DB"
Else
sErrMsg = Err.Number & " " & Err.Description
End If
End If
End If
If sErrMsg <> "" Then
MsgBox sErrMsg, vbCritical
End If
If Not cnn Is Nothing Then
If cnn.State = adStateOpen Then cnn.Close
End If
Set cnn = Nothing
End Function
Different approaches no look like this:
Sub getData()
Dim sSQL As String
sSQL = "confidential" ' --> SQL Connection String etc...
Dim rsAnalysis
If Not getAnalysisInformationFromDB(rsAnalysis, sSQL) = True Then Exit Sub
Dim vHeader() As Variant
Dim vData() As Variant
Dim rsTemp
Do Until rsAnalysis Is Nothing
Set rsTemp = rsAnalysis.NextRecordset()
vData = rsTemp.GetRows
' Do something with the Array...
' ...
Loop
End Sub
Or (here it does not even jump to the error handler, eventhough an error occurs...):
Sub getData2()
Dim rsAnalysis
If Not getAnalysisInformationFromDB(rsAnalysis, sSQL) = True Then Exit Sub
Do Until rsAnalysis Is Nothing
rsAnalysis.MoveFirst
On Error GoTo check_RS
Dim iCount As Integer: iCount = -1
For Each s In rsAnalysis.Fields
iCount = iCount + 1
ReDim Preserve vHeader(iCount): vHeader(iCount) = s.name
Next
If Not rsAnalysis.BOF And Not rsAnalysis.EOF Then
vData = rsAnalysis.GetRows
End If
Stop
Erase vHeader
retry_RS:
Set rsAnalysis = rsAnalysis.NextRecordset()
Loop
check_RS:
If Err Then
Debug.Print Err.Number
If Err.Number = 91 Or Err.Number = 3704 Or Err.Number = 3251 Then
GoTo retry_RS
End If
End If
End Sub
edit: the error always happens when I try to hand over the recordset to the array variable (vData = rsAnalysis.GetRows)
I have watched many videos on calling another sub. But with my code every time it gets to the line where it should call the function. It just finished the IF statement without following this command. Please note that this code is from a commandbutton inside of a userforum
Sub Begin_Click()
Unload BeginTheCode
Dim ws As Worksheet
Dim strDataRange As Range
Dim keyRange As Range
Dim wbk As Workbook
Dim wbkName As String
Dim wsName As String
Dim mName As String
Dim yName As String
Dim cName As String
On Error GoTo Err
'This command puts the other code in this workbook on hold'
Application.DisplayAlerts = False
'This provides shortcuts for future use in the code'
Set wa = ThisWorkbook.Worksheets("RE-I-A Raw")
Set wb = ThisWorkbook.Worksheets("I-A Data Copy (1)")
Set wc = ThisWorkbook.Worksheets("Untied Raw")
Set wd = ThisWorkbook.Worksheets("Blanks")
Dim IMRCCSpec() As String
Dim IMRSup() As String
Dim x As Integer
Dim y As Integer
Dim i As Integer
If Comittee = "IMRCC" Then
Call IM
Else
If Comittee = "COO" Then
Call COO
Else
If Comittee = "CFO" Then
Call CFO
Else
If Comittee = "AURA" Then
Call AURA
Else
If Comittee = "Distribution" Then
Call Dist
Else
If Comittee = "Legal" Then
Call Legal
End If
End If
End If
End If
End If
End If
Exit Sub
Err:
MsgBox "Error on Line : Sub Begin_Click() " & Erl
End Sub
Sub IM()
On Error GoTo Err
Dim IMRCCSpec() As String
Dim IMRSup() As String
Dim x As Integer
Dim y As Integer
x = Application.WorksheetFunction.CountA(wt.Range("C:C")) - 2
y = Application.WorksheetFunction.CountA(wt.Range("E:E")) - 2
ReDim IMRCCSpec(x) As String
ReDim IMRCCSup(y) As String
Dim i As Integer
For i = 0 To x
IMRCCSpec(i) = wt.Range("A" & i + 2)
Next i
For i = 0 To y
IMRCCSup(i) = wt.Range("B" & i + 2)
Next i
'Call Something
Exit Sub
Err:
MsgBox "Error on Line : Sub IM()" & Erl
End Sub
No error messages occur. when I use the F8 command it goes through this line without any error and does not do anything
I have the follwing VBA script for Outlook that should move emails to the Archives folder (that are not categorized in one of the special categories). It both works and not. I mean it moves some emails but skips the others so I have to run it mulitple times until the Inbox is cleaned-up. I don't understand why it behaves this way. It doesn't throw any exceptions it just doesn't do its job for all items. Can you see anything suspicios here?
Option Explicit
Sub CleanUpInbox()
Dim ns As Outlook.NameSpace
Set ns = GetNamespace("MAPI")
Dim inbox As Outlook.Folder: Set inbox = ns.GetDefaultFolder(olFolderInbox)
Dim archive As Outlook.Folder: Set archive = ns.Folders("my#mailbox.abc").Folders("Archives").Folders("2018")
Dim maxDiffInDays As Integer: maxDiffInDays = 14
Dim today As Date: today = DateValue(now())
On Error GoTo bang
Dim mail As Variant ' Outlook.MailItem
For Each mail In inbox.Items
If mail Is Nothing Then
GoTo continue
End If
Dim receivedOn As Date: receivedOn = DateValue(mail.ReceivedTime)
Dim diff As Integer: diff = DateDiff("d", receivedOn, today)
Dim isOld As Boolean: isOld = True ' diff > maxDiffInDays
If isOld Then
'Debug.Print diff
'Debug.Print mail.Subject
'Debug.Print mail.Categories
Dim isPinned As Boolean: isPinned = InStr(mail.Categories, "PINNED")
Dim isTTYL As Boolean: isTTYL = InStr(mail.Categories, "TTYL")
If LinqAll(False, isPinned, isTTYL) Then
Debug.Print mail.Subject
mail.Move archive
End If
End If
GoTo continue
bang:
Debug.Print "bang!"
Debug.Print Err.Description
continue:
Next
End Sub
Function LinqAll(ByVal Expected As Boolean, ParamArray Values() As Variant) As Boolean
Dim x As Variant
For Each x In Values
If x <> Expected Then
LinqAll = False
Exit Function
End If
Next
LinqAll = True
End Function
Function LinqAny(ByVal Expected As Boolean, ParamArray Values() As Variant) As Boolean
Dim x As Variant
For Each x In Values
If x = Expected Then
LinqAny = True
Exit Function
End If
Next
LinqAny = False
End Function
Not sure whether I miss something here, but your code seems to handle any mail as old, for you set isOld to true within the loop. Is there a special reason for declaring isPinedand isTTYLeach loop? Have you tried:
Sub CleanUpInbox()
Dim ns As Outlook.Namespace
Dim inbox As Outlook.Folder: Set inbox = ns.GetDefaultFolder(olFolderInbox)
Dim archive As Outlook.Folder: Set archive = ns.Folders("my#mailbox.abc").Folders("Archives").Folders("2018")
Dim maxDiffInDays As Integer: maxDiffInDays = 14
Dim today As Date: today = DateValue(Now())
Dim mail As Variant ' Outlook.MailItem
Dim receivedOn As Date
Dim diff As Integer
Dim isOld As Boolean
Dim isPinned As Boolean
Dim isTTYL As Boolean
Set ns = GetNamespace("MAPI")
On Error GoTo bang
For Each mail In inbox.Items
If mail Is Nothing Then
GoTo continue
End If
isOld = False
receivedOn = DateValue(mail.ReceivedTime)
diff = DateDiff("d", receivedOn, today)
If diff > maxDiffInDays Then
isOld = True
End If
isPinned = InStr(mail.Categories, "PINNED")
isTTYL = InStr(mail.Categories, "TTYL")
If LinqAll(False, isPinned, isTTYL) Then
Debug.Print mail.Subject
mail.Move archive
End If
GoTo continue
bang:
Debug.Print "bang!"
Debug.Print Err.Description
continue:
Next
End Sub
I've solved it. You must not use Items in a For Each loop and at the samve time .Move its items. It's like modifying the loop collection in C#. The only difference is that C# is throwing a nice exception while VBA just reduces the number of items and then just stops :-o
Instead, I used Do While and two counters. One that counts the processed items and the other that is the current index for Items. Now it processes everything.
Sub CleanUpInbox2()
' ... other variables
Dim processCount As Integer
Dim itemIndex As Integer: itemIndex = 1
Dim itemCount As Integer: itemCount = inbox.Items.Count
Do While processCount < itemCount
processCount = processCount + 1
Set mail = inbox.Items(itemIndex)
' ... body
If LinqAll(False, isPinned, isTTYL) Then
Debug.Print mail.Subject
mail.Move archive
moveCount = moveCount + 1
Else
itemIndex = itemIndex + 1
End If
bang:
Debug.Print "bang!"
Debug.Print Err.Description
continue:
Loop
Debug.Print "Emails processed: " & processCount
Debug.Print "Emails moved: " & moveCount
End Sub
I tried to copy Items first but I didn't succeed with that (apparently there is no new Outlook.Items) so I use indexes.
I've recently found out the way below to select the desired TAB (when within a sales order, for instance).
For T = 0 To 15
If Len(T) = 1 Then T = "0" & T
If SapSession.findById("wnd[0]/usr/tabsTAXI_TABSTRIP_HEAD/tabpT\" & T).Text = "Sales" Then
SapSession.findById("wnd[0]/usr/tabsTAXI_TABSTRIP_HEAD/tabpT\" & T).Select
Exit For
End If
Next T
I am looking now for a similar way to loop through the fields in the current active window in order to select (setfocus) on a specific field.
Is it possible?
I found this piece of code at SAP community site and it works fine.
Sub ScanFields(Area As Object, Application As SAPFEWSELib.GuiApplication)
Dim Children As Object
Dim i As Integer
Dim Obj As Object
Dim ObjChildren As Object
Dim NextArea As Object
Set Children = Area.Children()
For i = 0 To Children.Count() - 1
Set Obj = Children(CInt(i))
'If Obj.Type = "GuiTextField" Then 'If Obj.Name = "MyField" Then 'Obj.SetFocus
Debug.Print Obj.Name & " " & Obj.Type & " " & Obj.Text
If Obj.ContainerType() = True Then
Set ObjChildren = Obj.Children()
If ObjChildren.Count() > 0 Then
Set NextArea = Application.FindById(Obj.ID)
ScanFields NextArea, Application
Set NextArea = Nothing
End If
End If
Next i
Set Children = Nothing
End Sub
Sub Test()
Dim SapGuiAuto As Object
Dim Application As SAPFEWSELib.GuiApplication
Dim Connection As SAPFEWSELib.GuiConnection
Dim Session As SAPFEWSELib.GuiSession
Dim UserArea As SAPFEWSELib.GuiUserArea
Set SapGuiAuto = GetObject("SAPGUI")
If Not IsObject(SapGuiAuto) Then
Exit Sub
End If
Set Application = SapGuiAuto.GetScriptingEngine()
If Not IsObject(Application) Then
Exit Sub
End If
Set Connection = Application.Connections(0)
If Not IsObject(Connection) Then
Exit Sub
End If
Set Session = Connection.Sessions(0)
If Not IsObject(Session) Then
Exit Sub
End If
'-Get the user area and scan it recursively-----------------------
Set UserArea = Session.FindById("wnd[0]/usr")
ScanFields UserArea, Application
Set UserArea = Nothing
End Sub
I am trying to delete some specific lines of a text using VB.Net. I saw a solution here however it is in VB6. The problem is, I am not really familiar with VB6. Can somebody help me?
This is the code from the link:
Public Function DeleteLine(ByVal fName As String, ByVal LineNumber As Long) _As Boolean
'Purpose: Deletes a Line from a text file
'Parameters: fName = FullPath to File
' LineNumber = LineToDelete
'Returns: True if Successful, false otherwise
'Requires: Reference to Microsoft Scripting Runtime
'Example: DeleteLine("C:\Myfile.txt", 3)
' Deletes third line of Myfile.txt
'______________________________________________________________
Dim oFSO As New FileSystemObject
Dim oFSTR As Scripting.TextStream
Dim ret As Long
Dim lCtr As Long
Dim sTemp As String, sLine As String
Dim bLineFound As Boolean
On Error GoTo ErrorHandler
If oFSO.FileExists(fName) Then
oFSTR = oFSO.OpenTextFile(fName)
lCtr = 1
Do While Not oFSTR.AtEndOfStream
sLine = oFSTR.ReadLine
If lCtr <> LineNumber Then
sTemp = sTemp & sLine & vbCrLf
Else
bLineFound = True
End If
lCtr = lCtr + 1
Loop
oFSTR.Close()
oFSTR = oFSO.CreateTextFile(fName, True)
oFSTR.Write(sTemp)
DeleteLine = bLineFound
End If
ErrorHandler:
On Error Resume Next
oFSTR.Close()
oFSTR = Nothing
oFSO = Nothing
End Function
Dim delLine As Integer = 10
Dim lines As List(Of String) = System.IO.File.ReadAllLines("infile.txt").ToList
lines.RemoveAt(delLine - 1) ' index starts at 0
System.IO.File.WriteAllLines("outfile.txt", lines)
'This can also be the file that you read in
Dim str As String = "sdfkvjdfkjv" & vbCrLf & "dfsgkjhdfj" & vbCrLf & "dfkjbhhjsdbvcsdhjbvdhs" & vbCrLf & "dfksbvashjcvhjbc"
Dim str2() As String = str.Split(vbCrLf)
For Each s In str2
If s.Contains("YourString") Then
'add your line to txtbox
Else
'don't add your line to txtbox
End If
Next
Or You Can Use
TextFile = TextFile.Replace("You want to Delete","")