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