module1.bas

这个源代码主要模仿了一个类似 深度操作系统安装程序中的一个软件自动安装管理器AutoIt v3

Attribute VB_Name = "Module1"
Option Explicit

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

'窗体top
Declare Function SetWindowPos _
        Lib "user32" (ByVal hwnd As Long, _
                      ByVal hWndInsertAfter As Long, _
                      ByVal X As Long, _
                      ByVal Y As Long, _
                      ByVal cx As Long, _
                      ByVal cy As Long, _
                      ByVal wFlags As Long) As Long
'窗口置前-----------------------------------
Public Const HWND_TOPMOST = -1
Public Const SWP_NOMOVE = &H2
Public Const SWP_NOSIZE = &H1
                      

'访问INI
'   ReadINI   读INI
'   WriteINI  写INI
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias _
"GetPrivateProfileStringA" (ByVal lpApplicationName As String, _
ByVal lpKeyName As Any, ByVal lpDefault As String, _
ByVal lpReturnedString As String, ByVal nSize As Long, _
ByVal lpFileName As String) As Long

Private Declare Function WritePrivateProfileString Lib "kernel32" Alias _
"WritePrivateProfileStringA" (ByVal AppName As String, _
ByVal KeyName As String, ByVal keydefault As String, _
ByVal Filename As String) As Long


Public Const iniFile = "ReaderINI.ini"

'如果没有section (appname),默认为第一
'如果没有key,则默认为第一
Public Function ReadINI(iniFile, inisection, inikey, iniDefault) As String
    Dim lpApplicationName As String, lpKeyName As String, _
    lpDefault As String, lpReturnedString As String, _
    lpFileName As String, Filename As String
    Dim nSize As Long, retval As Long
    lpDefault = Space$(254)
    lpDefault = iniDefault

    lpReturnedString = Space$(254)

    nSize = 254
    lpFileName = iniFile
    lpApplicationName = inisection
    lpKeyName = inikey
    Filename = lpFileName
    retval = GetPrivateProfileString(lpApplicationName, lpKeyName, lpDefault, lpReturnedString, nSize, lpFileName)
    ReadINI = LPSTRToVBString(lpReturnedString)
    
End Function

Public Function WriteINI(iniFile As String, inisection As String, inikey As String, Info As String) As String
    Dim retval As Long
    retval = WritePrivateProfileString(inisection, inikey, Info, iniFile)
    WriteINI = LTrim$(Str$(retval))
End Function


'判断文件是否存在
Public Function FileExists(fname$) As Boolean
    On Error Resume Next  '设置错误处理
    Dim freeX As Integer
 
    freeX = FreeFile      '取得一个空闲文件句柄
    Open fname$ For Input As freeX     '试图打开该文件
    If Err = 0 Then        '如果打开成功
        FileExists = True
    Else                   '否则
        FileExists = False
    End If
    Close freeX
End Function

Public Function ExtractPath(sFilename) As String
    Dim nIdx As Integer
    For nIdx = Len(sFilename) To 1 Step -1
        If Mid$(sFilename, nIdx, 1) = "\" Then
           ExtractPath = Mid$(sFilename, 1, nIdx)
           Exit Function
        End If
    Next nIdx
    ExtractPath = sFilename
End Function

'将Null结尾字符串转换到VB字符串
Public Function LPSTRToVBString$(ByVal s$)
    Dim nullpos&
    nullpos& = InStr(s$, Chr$(0))
    If nullpos > 0 Then
       LPSTRToVBString = Left$(s$, nullpos - 1)
    Else
       LPSTRToVBString = ""
    End If
End Function

Public Function RemoveBackslash(sFlName As String) As String
    Dim i As Integer
    i = Len(sFlName)
    If i <> 0 Then
       If Right$(sFlName, 1) = "\" Then
          RemoveBackslash = Left$(sFlName, i - 1)
       Else
          RemoveBackslash = sFlName
       End If
    Else
       RemoveBackslash = ""
    End If
End Function

'窗口置前
Public Function PutWindowOnTop(pFrm As Form)
  Dim lngWindowPosition As Long
  lngWindowPosition = SetWindowPos(pFrm.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
End Function

'----------------------------
'文本框格式限制函数
'用法:
'在Text的keypress事件中加入 KeyAscii = ValiText(KeyAscii, "0123456789.", True)
'0123456789.为允许接受的字符
'-----------------------------
Public Function ValiText(KeyIn As Integer, ValidateString As String, Editable As Boolean) As Integer '密码设置
    Dim ValidateList As String
    Dim KeyOut As Integer
    If Editable = True Then
        ValidateList = UCase(ValidateString) & Chr(8)
    Else
        ValidateList = UCase(ValidateString)
    End If
    If InStr(1, ValidateList, UCase(Chr(KeyIn)), 1) > 0 Then
        KeyOut = KeyIn
    Else
        KeyOut = 0
        Beep
    End If
    ValiText = KeyOut
End Function



'*/-------------------------------------------------------------
'*/过 程 名:Pause
'*/功    能:暂停函数，延时用
'*/返 回 值:无
'*/参    数:Dauer 延时值
'*/建立日期:2004-12-07 16:00
'*/修改日期:
'*/-------------------------------------------------------------
Sub Pause(Dauer)
    Dim start As Long
    start = Timer
    Do While Timer < start + Dauer
        DoEvents
    Loop
End Sub