mirror of
https://e.coding.net/circlecloud/VBFunctionBas.git
synced 2024-10-31 22:38:50 +00:00
238 lines
9.2 KiB
QBasic
238 lines
9.2 KiB
QBasic
Attribute VB_Name = "System"
|
||
'#######################################用户控件说明#########################################
|
||
|
||
'名称:系统控件
|
||
|
||
'功能:获取系统信息
|
||
|
||
'最后更新日期:2014年12月8日
|
||
|
||
'创建人:蒋天蓓
|
||
|
||
'单位:上海市定海水电工程安装有限公司
|
||
|
||
''====================================用户控件使用说明=======================================
|
||
|
||
Option Explicit
|
||
''================================API调用打开文件窗口=========================================
|
||
'调用“打开”窗体
|
||
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long 'API调用打开
|
||
Private Type OPENFILENAME
|
||
lStructSize As Long
|
||
hwndOwner As Long
|
||
hInstance As Long
|
||
lpstrFilter As String
|
||
lpstrCustomFilter As String
|
||
nMaxCustFilter As Long 'API调用打开
|
||
nFilterIndex As Long
|
||
lpstrFile As String
|
||
nMaxFile As Long
|
||
lpstrFileTitle As String
|
||
nMaxFileTitle As Long
|
||
lpstrInitialDir As String
|
||
lpstrTitle As String
|
||
Flags As Long
|
||
nFileOffset As Integer
|
||
nFileExtension As Integer
|
||
lpstrDefExt As String
|
||
lCustData As Long
|
||
lpfnHook As Long
|
||
lpTemplateName As String
|
||
End Type 'API调用打开
|
||
Private Const MAX_PATH As Long = 260
|
||
''================================获得进程最高权限=========================================
|
||
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
|
||
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
|
||
Private Const PROCESS_ALL_ACCESS = &H1F0FFF '全权打开进程
|
||
|
||
''================================删除文件=========================================
|
||
Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
|
||
Private Type SHFILEOPSTRUCT
|
||
hWnd As Long
|
||
wFunc As Long
|
||
pFrom As String
|
||
pTo As String
|
||
fFlags As Integer
|
||
fAborted As Boolean
|
||
hNameMaps As Long
|
||
sProgress As String
|
||
End Type
|
||
Private Const FO_DELETE = &H3
|
||
Private Const FOF_ALLOWUNDO = &H40 ' 移入回收站
|
||
Private Const FOF_CONFIRMMOUSE = &H2 ' 删除。不放入回收站
|
||
Private Const FOF_NOCONFIRMATION = &H10 ' 没有提示
|
||
|
||
''#####################################################模块代码#####################################################
|
||
'#############################################控件函数模块#################################################
|
||
'**********************************************************************************************************
|
||
'***过程名：DeleteFolder
|
||
'***功 能 ：删除一个文件或文件夹。该过程可以删除非空的文件夹
|
||
'***输入值：(文件夹或文件名称 As String)
|
||
'***输出值：NULL
|
||
'***说 明：NULL
|
||
'**********************************************************************************************************
|
||
Public Sub DeleteFolder(sObject As String)
|
||
Dim SHFileOp As SHFILEOPSTRUCT
|
||
|
||
With SHFileOp
|
||
.wFunc = FO_DELETE
|
||
.pFrom = sObject
|
||
.fFlags = FOF_CONFIRMMOUSE Or FOF_NOCONFIRMATION
|
||
End With
|
||
SHFileOperation SHFileOp
|
||
End Sub
|
||
'**********************************************************************************************************
|
||
'***过程名：GetFilePath
|
||
'***功 能 ：API调用打开窗口
|
||
'***输入值：(PID As Long)
|
||
'***输出值：String
|
||
'***说 明：NULL
|
||
'**********************************************************************************************************
|
||
Public Function GetFilePath(ByVal hWnd As Long, _
|
||
Optional ByVal DefaultFile As String, _
|
||
Optional ByVal DefaultFilterStr As String, _
|
||
Optional ByVal DefaultFilter As String, _
|
||
Optional ByVal DefaultTitle As String, Optional ByVal DefaultPath As String) As String
|
||
Dim ofn As OPENFILENAME
|
||
Dim rtn As Long
|
||
ofn.lStructSize = Len(ofn)
|
||
ofn.hwndOwner = hWnd
|
||
ofn.hInstance = App.hInstance
|
||
If DefaultFilter & DefaultFilterStr <> "" Then
|
||
ofn.lpstrFilter = DefaultFilterStr & "(" & DefaultFilter & ")" + Chr$(0) + DefaultFilter + Chr$(0) + _
|
||
"所有文件 (*.*)" + Chr$(0) + "*.*" + Chr$(0) + Chr$(0)
|
||
Else
|
||
ofn.lpstrFilter = "所有文件 (*.*)" + Chr$(0) + "*.*" + Chr$(0) + Chr$(0)
|
||
End If
|
||
ofn.lpstrFile = DefaultFile + Space(255 - Len(DefaultFile)) '这里可以改一个默认的文件名
|
||
ofn.nMaxFile = MAX_PATH
|
||
ofn.lpstrFileTitle = Space(255)
|
||
ofn.nMaxFileTitle = MAX_PATH
|
||
ofn.lpstrInitialDir = DefaultPath
|
||
ofn.lpstrTitle = DefaultTitle
|
||
ofn.Flags = 6148
|
||
rtn = GetOpenFileName(ofn)
|
||
If rtn >= 1 Then GetFilePath = ofn.lpstrFile Else GetFilePath = ""
|
||
End Function
|
||
'**********************************************************************************************************
|
||
'***过程名：CheckPid
|
||
'***功 能 ：检查PID是否存活
|
||
'***输入值：(PID As Long)
|
||
'***输出值：Boolean
|
||
'***说 明：NULL
|
||
'**********************************************************************************************************
|
||
Public Function CheckPid(ByVal PID As Long) As Boolean
|
||
Dim info As Long
|
||
info = OpenProcess(PROCESS_ALL_ACCESS, &O0, PID)
|
||
If info = 0 Then
|
||
CheckPid = False
|
||
Else
|
||
CloseHandle CheckPid
|
||
CloseHandle PID
|
||
CheckPid = True
|
||
End If
|
||
End Function
|
||
|
||
Public Function GetSystemPath() As String
|
||
Dim aa$, jj%
|
||
aa = Environ("ComSpec")
|
||
jj = InStrRev(aa, "\")
|
||
GetSystemPath = Mid(aa, 1, jj - 1)
|
||
End Function
|
||
|
||
Public Function IsX86() As Boolean
|
||
'If Environ("PROCESSOR_ARCHITECTURE") = "x86" Then IsX86 = True: Exit Function
|
||
If Dir(Left(Environ("ComSpec"), 1) & ":\Windows\SysWOW64", vbDirectory) = "" Then
|
||
IsX86 = True
|
||
Else
|
||
IsX86 = False
|
||
End If
|
||
End Function
|
||
|
||
Public Function FileCheck(ByVal FileName As String, Optional ByVal Reg As Boolean) As Boolean
|
||
Dim FileData() As Byte
|
||
Dim FileInfo() As String
|
||
Dim SystemPath As String
|
||
SystemPath = GetSystemPath
|
||
If Dir(SystemPath & "\" & FileName) = "" Then
|
||
FileInfo = Split(FileName, ".")
|
||
If UBound(FileInfo) < 1 Then MsgBox "文件" & FileName & "名称错误！", vbCritical
|
||
FileData = LoadResData(UCase(FileInfo(0)), UCase(FileInfo(1)))
|
||
Open SystemPath & "\" & FileName For Binary As #1 '以二进制方式写（生成）控件（kjmc.kjlx）到主程序所在的目录
|
||
Put #1, , FileData
|
||
Close #1
|
||
If Reg Then Shell "regsvr32 \s " & SystemPath & "\" & FileName, vbHide
|
||
End If
|
||
End Function
|
||
|
||
Public Sub MkMulDirs(ByVal Path As String)
|
||
Dim FilePath As String
|
||
Dim Index As Long
|
||
Index = InStr(1, Path, "\")
|
||
Debug.Print Index
|
||
Do While Index > 0
|
||
FilePath = Left(Path, Index)
|
||
If Dir(FilePath, vbDirectory) = "" Then _
|
||
MkDir FilePath
|
||
Index = InStr(Index + 1, Path, "\")
|
||
Loop
|
||
Debug.Print "创建文件夹: " & Path
|
||
End Sub
|
||
|
||
Public Function FindPath(ByVal AppName As String) As String
|
||
On Error Resume Next
|
||
Dim PathDir As String
|
||
Dim WshShell
|
||
Set WshShell = CreateObject("Wscript.Shell")
|
||
' 注册表写入
|
||
' WshShell.RegWrite "HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\Run\" & App.EXEName, App.Path & "\" & App.EXEName & ".exe"
|
||
' 注册表删除
|
||
' WshShell.RegDelete "HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\Run\" & App.EXEName
|
||
' 注册表读取
|
||
FindPath = WshShell.RegRead("HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\" & AppName & "\Path")
|
||
Set WshShell = Nothing
|
||
' PathDir = Left(Environ("ComSpec"), 1)
|
||
' If Dir(PathDir & ":\Program Files\Java\jre6\bin\java.exe") <> "" Then
|
||
' FindJava = PathDir & ":\Program Files\Java\jre6\bin\java.exe"
|
||
' ElseIf Dir(PathDir & ":\Program Files (x86)\Java\jre6\bin\java.exe") <> "" Then
|
||
' FindJava = PathDir & ":\Program Files (x86)\Java\jre6\bin\java.exe"
|
||
' ElseIf Dir(PathDir & ":\Program Files\Java\jre7\bin\java.exe") <> "" Then
|
||
' FindJava = PathDir & ":\Program Files\Java\jre7\bin\java.exe"
|
||
' ElseIf Dir(PathDir & ":\Program Files (x86)\Java\jre7\bin\java.exe") <> "" Then
|
||
' FindJava = PathDir & ":\Program Files (x86)\Java\jre7\bin\java.exe"
|
||
' ElseIf Dir(PathDir & ":\Program Files\Java\jre8\bin\java.exe") <> "" Then
|
||
' FindJava = PathDir & ":\Program Files\Java\jre8\bin\java.exe"
|
||
' ElseIf Dir(PathDir & ":\Program Files (x86)\Java\jre8\bin\java.exe") <> "" Then
|
||
' FindJava = PathDir & ":\Program Files (x86)\Java\jre8\bin\java.exe"
|
||
' Else
|
||
' FindJava = ""
|
||
' End If
|
||
End Function
|
||
|
||
Public Function FindJar() As String
|
||
If Dir(App.Path & "/*.jar") <> "" Then
|
||
FindJar = Dir(App.Path & "/*.jar")
|
||
End If
|
||
End Function
|
||
|
||
Public Function GetMaxMem() As String
|
||
Dim strComputer
|
||
Dim strNameSpace
|
||
Dim strClass
|
||
Dim objSWbemObject
|
||
Dim objSWbemServices
|
||
Dim objSWbemObjectSet
|
||
Dim MaxMemN
|
||
MaxMemN = 0
|
||
Set objSWbemServices = GetObject("winmgmts:")
|
||
Set objSWbemObjectSet = objSWbemServices.ExecQuery("select Capacity from Win32_PhysicalMemory where CreationClassName='Win32_PhysicalMemory'")
|
||
For Each objSWbemObject In objSWbemObjectSet
|
||
MaxMemN = objSWbemObject.Capacity + MaxMemN
|
||
Next
|
||
GetMaxMem = Int(MaxMemN / 1024 / 1024)
|
||
GetMaxMem = Trim(Str(GetMaxMem))
|
||
Set objSWbemObject = Nothing
|
||
Set objSWbemServices = Nothing
|
||
Set objSWbemObjectSet = Nothing
|
||
End Function
|