codice:
Option Explicit
Option Base 0
Option Compare Text
Public Declare Function Beep Lib "kernel32" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long
Public Declare Function CloseHandle Lib "Kernel32.dll" (ByVal Handle As Long) As Long
Public Declare Function CreateToolhelp32Snapshot Lib "kernel32" (ByVal dwFlags As Long, ByVal th32ProcessID As Long) As Long
Public Declare Function DestroyWindow Lib "user32" (ByVal HWND As Long) As Long
Public Declare Function EnumProcesses Lib "PSAPI.DLL" (ByRef lpidProcess As Long, ByVal cb As Long, ByRef cbNeeded As Long) As Long
Public Declare Function EnumProcessModules Lib "PSAPI.DLL" (ByVal hProcess As Long, ByRef lphModule As Long, ByVal cb As Long, ByRef cbNeeded As Long) As Long
Public Declare Function EnumWindows Lib "user32" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Boolean
Public Declare Function GetModuleFileNameExA Lib "PSAPI.DLL" (ByVal hProcess As Long, ByVal hModule As Long, ByVal ModuleName As String, ByVal nSize As Long) As Long
Public Declare Function GetProcessMemoryInfo Lib "PSAPI.DLL" (ByVal hProcess As Long, ppsmemCounters As PROCESS_MEMORY_COUNTERS, ByVal cb As Long) As Long
Public Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Public Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal HWND As Long, ByVal lpString As String, ByVal cch As Long) As Long
Public Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal HWND As Long) As Long
Public Declare Function OpenProcess Lib "Kernel32.dll" (ByVal dwDesiredAccessas As Long, ByVal bInheritHandle As Long, ByVal dwProcId As Long) As Long
Public Declare Function Process32First Lib "kernel32" (ByVal hSnapshot As Long, lppe As PROCESSENTRY32) As Long
Public Declare Function Process32Next Lib "kernel32" (ByVal hSnapshot As Long, lppe As PROCESSENTRY32) As Long
Public Declare Function Putfocus Lib "user32" Alias "SetFocus" (ByVal HWND As Long) As Long
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal HWND As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Public Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Public Type PROCESSENTRY32
dwSize As Long
cntUsage As Long
th32ProcessID As Long
th32DefaultHeapID As Long
th32ModuleID As Long
cntThreads As Long
th32ParentProcessID As Long
pcPriClassBase As Long
dwFlags As Long
szExeFile As String * 260
End Type
Public Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
Public Type PROCESS_MEMORY_COUNTERS
cb As Long
PageFaultCount As Long
PeakWorkingSetSize As Long
WorkingSetSize As Long
QuotaPeakPagedPoolUsage As Long
QuotaPagedPoolUsage As Long
QuotaPeakNonPagedPoolUsage As Long
QuotaNonPagedPoolUsage As Long
PagefileUsage As Long
PeakPagefileUsage As Long
End Type
Public WebBrowser1 As Object, lblUltimo As Object, lblCodCorrente As Object
Public MSGB99 As String, TITPROG99 As String, numHWD As Long, hProc As Long, proc As PROCESS_MEMORY_COUNTERS
Public Const PROCESS_TERMINATE = &H1
Public Const VER_PLATFORM_WIN32_WINDOWS = 1
Public Const PROCESS_QUERY_INFORMATION = 1024
Public Const PROCESS_VM_READ = 16
Public Const TH32CS_SNAPPROCESS = &H2
Sub Main()
TITPROG99 = " Vassallo " & App.Major & "." & App.Minor & " "
If App.PrevInstance Then
MSGB99 = MsgBox("Il programma è già attivo.", vbInformation, TITPROG99)
End
End If
frmPrincipale.Show
End Sub
Public Sub ChiudiFinestrelle()
'con questa procedura chiudo le varie finestrelle che si aprono durante l'esplorazione, come per esempio
'gli avvisi protezioni, gli errori di script, eccetera (non si può usare TerminateExe perchè non è un exe)
numHWD = 0
EnumWindows AddressOf EnumWindowsProc, ByVal 0&
If numHWD > 0 Then Call DestroyWindow(numHWD)
End Sub
Public Function TerminateEXE(ByVal sEXE As String) As Boolean
Dim lPID As Long, lProcess As Long
Do
lPID = GetEXEProcessID(sEXE)
If lPID <> 0 Then
lProcess = OpenProcess(PROCESS_TERMINATE, 0, lPID)
Call TerminateProcess(lProcess, 0&)
Call CloseHandle(lProcess)
End If
Loop Until lPID = 0
TerminateEXE = True
End Function
Public Function CheckVersion() As Long
Dim tOS As OSVERSIONINFO
tOS.dwOSVersionInfoSize = Len(tOS)
Call GetVersionEx(tOS)
CheckVersion = tOS.dwPlatformId
End Function
Public Function GetEXEProcessID(ByVal sEXE As String) As Long
Dim aPID() As Long, lProcesses As Long, lProcess As Long, lModule As Long, sName As String
Dim iIndex As Integer, bCopied As Long, lSnapShot As Long, tPE As PROCESSENTRY32, bDone As Boolean
If CheckVersion() = VER_PLATFORM_WIN32_WINDOWS Then
lSnapShot = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0)
If lSnapShot < 0 Then Exit Function
tPE.dwSize = Len(tPE)
bCopied = Process32First(lSnapShot, tPE)
Do While bCopied
sName = Left$(tPE.szExeFile, InStr(tPE.szExeFile, Chr(0)) - 1)
sName = Mid(sName, InStrRev(sName, "\") + 1)
If InStr(sName, Chr(0)) Then
sName = Left(sName, InStr(sName, Chr(0)) - 1)
End If
bCopied = Process32Next(lSnapShot, tPE)
If StrComp(sEXE, sName, vbTextCompare) = 0 Then
GetEXEProcessID = tPE.th32ProcessID
Exit Do
End If
Loop
Else
ReDim aPID(255)
Call EnumProcesses(aPID(0), 1024, lProcesses)
lProcesses = lProcesses / 4
ReDim Preserve aPID(lProcesses)
For iIndex = 0 To lProcesses - 1
lProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, 0, aPID(iIndex))
If lProcess Then
If EnumProcessModules(lProcess, lModule, 4, 0&) Then
sName = Space(260)
Call GetModuleFileNameExA(lProcess, lModule, sName, Len(sName))
If InStr(sName, "\") > 0 Then
sName = Mid(sName, InStrRev(sName, "\") + 1)
End If
If InStr(sName, Chr(0)) Then
sName = Left(sName, InStr(sName, Chr(0)) - 1)
End If
If StrComp(sEXE, sName, vbTextCompare) = 0 Then
GetEXEProcessID = aPID(iIndex)
bDone = True
End If
End If
CloseHandle lProcess
If bDone Then Exit For
End If
Next
End If
End Function
Public Function EnumWindowsProc(ByVal HWND As Long, ByVal lParam As Long) As Boolean
Dim sSaVe As String, RET As Long
RET = GetWindowTextLength(HWND)
sSaVe = Space(RET)
GetWindowText HWND, sSaVe, RET + 1
If Trim(sSaVe) <> "" Then
If InStr(1, LCase(sSaVe), "avviso di protezione", vbTextCompare) > 0 Then numHWD = HWND
If InStr(1, LCase(sSaVe), "errore nello script", vbTextCompare) > 0 Then numHWD = HWND
If InStr(1, LCase(sSaVe), "download del file", vbTextCompare) > 0 Then numHWD = HWND
If InStr(1, LCase(sSaVe), "windows internet explorer", vbTextCompare) > 0 Then numHWD = HWND
If InStr(1, LCase(sSaVe), "connetti a", vbTextCompare) > 0 Then numHWD = HWND
If InStr(1, LCase(sSaVe), "windows media player", vbTextCompare) > 0 Then numHWD = HWND
If InStr(1, LCase(sSaVe), "errore pagina web", vbTextCompare) > 0 Then numHWD = HWND
If InStr(1, LCase(sSaVe), "ambiente di sviluppo", vbTextCompare) > 0 Then numHWD = HWND
If InStr(1, LCase(sSaVe), "messaggio dalla pagina", vbTextCompare) > 0 Then numHWD = HWND
End If
EnumWindowsProc = True 'continua enumerazione
End Function
Public Function AggiustaDimensioni(DimBytes As Long) As String
'da bytes in KB => bytes / 1024 ===== da bytes in MB => bytes / 1024 / 1024
AggiustaDimensioni = FormatNumber(DimBytes / 1024 / 1024, 2, vbTrue, vbFalse, vbTrue) & " MB"
End Function
Public Function ControllaUsoRam(Nome_Exe As String)
Dim RETV As Long, RISULTATO As String, ULTI As Boolean
hProc = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, 0, GetEXEProcessID(Nome_Exe))
RISULTATO = GetProcessMemoryInfo(hProc, proc, Len(proc))
RISULTATO = "Uso Ram: " & AggiustaDimensioni(proc.WorkingSetSize) & " (" & Format(Now, "Hh:Nn") & ")"
CloseHandle hProc
If proc.WorkingSetSize > 60000000 Then
'rimuovo, annullo e ri-creo l'oggetto WebBrowser
RETV = WebBrowser1.Height
ULTI = lblUltimo.Visible
frmRa_Princ.Controls.Remove ("WebBrowser1") 'rimuovo l'oggetto WebBrowser
Set WebBrowser1 = Nothing 'libero la memoria
Set WebBrowser1 = frmRa_Princ.Controls.Add("shell.explorer.2", "WebBrowser1")
WebBrowser1.Visible = True
WebBrowser1.Height = RETV 'può essere a dimensioni normali o minimizzate
WebBrowser1.Width = 14415
WebBrowser1.Left = 120
WebBrowser1.Top = 120
WebBrowser1.TabIndex = 8
'rimuovo, annullo e ri-creo l'oggetto label con gli indirizzi web
frmRa_Princ.Controls.Remove ("lblUltimo") 'rimuovo l'oggetto lblUltimo
Set lblUltimo = Nothing 'libero la memoria
Set lblUltimo = frmRa_Princ.Controls.Add("VB.label", "lblUltimo", frmRa_Princ.Frame2)
lblUltimo.Alignment = 0 'left
lblUltimo.AutoSize = False
lblUltimo.BackColor = &H0& 'nero
lblUltimo.BorderStyle = 0
lblUltimo.Caption = "Azzeramento WebBrowser in corso..."
lblUltimo.FontName = "Tahoma"
lblUltimo.FontBold = True
lblUltimo.FontSize = 9
lblUltimo.ForeColor = &HFF00& 'verde
lblUltimo.Height = 255
lblUltimo.Width = 11535
lblUltimo.Left = 120
lblUltimo.Top = 360
lblUltimo.Visible = ULTI
'rimuovo, annullo e ri-creo l'oggetto label con il codice corrente
frmRa_Princ.Controls.Remove ("lblCodCorrente") 'rimuovo l'oggetto lblCodCorrente
Set lblCodCorrente = Nothing 'libero la memoria
Set lblCodCorrente = frmRa_Princ.Controls.Add("VB.label", "lblCodCorrente", frmRa_Princ.Frame2)
lblCodCorrente.Alignment = 0 'left
lblCodCorrente.AutoSize = False
lblCodCorrente.BackColor = &H0& 'nero
lblCodCorrente.BorderStyle = 0
lblCodCorrente.Caption = "-"
lblCodCorrente.FontName = "Tahoma"
lblCodCorrente.FontBold = True
lblCodCorrente.FontSize = 9
lblCodCorrente.ForeColor = &HFF00& 'verde
lblCodCorrente.Height = 255
lblCodCorrente.Width = 10800
lblCodCorrente.Left = 855
lblCodCorrente.Top = 1680
lblCodCorrente.Visible = True
End If
ControllaUsoRam = RISULTATO
End Function
Rispondi quotando
