frminsert.frm

VB开发的自动更新程序

    dwProductVersionLS  As Long
    dwFileFlagsMask     As Long
    dwFileFlags         As Long
    dwFileOS            As Long
    dwFileType          As Long
    dwFileSubtype       As Long
    dwFileDateMS        As Long
    dwFileDateLS        As Long
End Type

Private lLastLine       As Long '------------ Stores line value for inserting next file

Private Sub chkMustExist_GotFocus()
    Call DisplayTip(Me.ActiveControl.Tag, Me)
End Sub

Private Sub chkMustUpdate_GotFocus()
    Call DisplayTip(Me.ActiveControl.Tag, Me)
End Sub

Private Sub cmbDefConst_GotFocus()
    Call DisplayTip(Me.ActiveControl.Tag, Me)
End Sub

Private Sub Form_Load()
Dim x As Byte
    For x = 0 To 7 '----------------------------------------------- Color labels
        Me.lbl(x).ForeColor = Setup.KeyTagColor
    Next x
    Me.lblSec.ForeColor = Setup.SecTagColor
    With Me.cmbDefConst
        .Text = Setup.DefaultConst '------------------------------- Set default script constant
        .ForeColor = Setup.ValTagColor
    End With
    Me.lblSec.Caption = "[File " & Format(FindNextFile, "00]") '--- Display next file assignment
    Me.txtURL.Text = Setup.DefaultWeb '---------------------------- Set deafult web URL
End Sub

Private Sub cmdHelp_Click()
    '//Open help file and display contents
    WinHelp Me.hwnd, App.path & "\ReVive.hlp", HELP_CONTEXT, CLng(3)
End Sub

Private Sub cmdCancel_Click()
    Unload Me
End Sub

Private Sub cmdOK_Click()
'//Create file entry and add it to the richtextbox.
Dim s As String
Dim x As Long
    If Not IsVersionValid(Me.txtVer.Text) Then
        MsgBox "Version number is not valid. Please see tip window for details.   ", vbExclamation, "Version Number Error"
        Me.txtVer.SetFocus
        Exit Sub
    End If
    s = vbNewLine
    s = s & Me.lblSec.Caption
    s = s & vbNewLine
    s = s & vbTab & "Description=" & vbTab & Me.txtDesc.Text
    s = s & vbNewLine
    s = s & vbTab & "UpdateVersion=" & vbTab & Me.txtVer.Text
    s = s & vbNewLine
    s = s & vbTab & "DownloadURL=" & vbTab & Me.txtURL.Text
    s = s & vbNewLine
    s = s & vbTab & "InstallPath=" & vbTab & Me.cmbDefConst.Text & Me.txtPath.Text
    s = s & vbNewLine
    s = s & vbTab & "FileSize=" & vbTab & vbTab & Me.txtFileSize.Text
    s = s & vbNewLine
    s = s & vbTab & "MustUpdate=" & vbTab & vbTab & CBool(Me.chkMustUpdate.Value)
    s = s & vbNewLine
    s = s & vbTab & "MustExist=" & vbTab & vbTab & CBool(Me.chkMustExist.Value)
    s = s & vbNewLine
    If Len(Trim$(Me.txtUpdateMessage.Text)) Then
        s = s & vbTab & "UpdateMessage=" & vbTab & Me.txtUpdateMessage.Text
        s = s & vbNewLine
    End If
    SetWindowState bLocked
    With frmMain.rtBox
        .Text = .Text & s
        For x = 1 To lLastLine + 10
            frmMain.ColorLine x
        Next x
        .SelStart = Len(.Text)
    End With
    SetWindowState bUnLocked
    Unload Me
End Sub

Private Function FindNextFile() As Byte
'//Discovers next available file entry number.
Dim x           As Long
Dim Y           As Long
Dim sUsed       As String
Dim lLineCount  As Long
Dim sText       As String * 255 '--------- Buffer for EM_GETLINE call
Dim sLineText   As String '--------------- Line text before trimming
Dim lStartChar  As Long
Dim lLineLength As Long
    lLineCount = SendMessage(rtHwnd, EM_GETLINECOUNT, ByVal 0&, ByVal 0&)
    lLastLine = lLineCount      '//Save line number for inserting new file
    sUsed = "|"
    For x = 0 To lLineCount - 1
        lStartChar = SendMessage(rtHwnd, EM_LINEINDEX, x, ByVal 0&)
        lLineLength = SendMessage(rtHwnd, EM_LINELENGTH, lStartChar, ByVal 0&)
        sText = Space(255): Call SendMessage(rtHwnd, EM_GETLINE, x, ByVal sText)
        sLineText = Trim$(StripNulls(Left$(sText, lLineLength))): sText = ""
        If Left$(sLineText, 1) = "[" Then
            For Y = 1 To 99
                If Left$(sLineText, 9) = "[File " & Format(Y, "00]") Then
                    sUsed = sUsed & Y & "|"
                    Exit For
                End If
            Next Y
        End If
    Next x
    For x = 1 To 99
        If InStr(1, sUsed, "|" & x & "|") = 0 Then
            Exit For
        End If
    Next x
    FindNextFile = x
End Function

Private Function StripNulls(ByVal sString As String) As String
    sString = Replace(sString, vbTab, " ")
    sString = Replace(sString, vbLf, " ")
    sString = Replace(sString, vbCr, " ")
    StripNulls = sString
End Function

Private Sub SelectAllText()
On Error Resume Next
    With Screen.ActiveControl
        .SelStart = 0
        .SelLength = Len(.Text)
    End With
    If Err Then Err.Clear
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Set frmInsert = Nothing
End Sub

Private Sub lblSelFile_Click()
'//Opens file open dialog and fills file textboxes with selected file information
On Error GoTo Errs
Dim sFile       As String
Dim sFileName   As String
Dim x           As Long
    With frmMain.cd
        .Filter = "Executable files (*.exe;*.dll;*.ocx)|*.exe;*.dll;*.ocx|" & _
                    "Drivers (*.sys;*.drv;*.fnt)|*.sys;*.drv;*.fnt|" & _
                    "All files (*.*)|*.*"
        .DefaultExt = "*.exe"
        .DialogTitle = "Select an update file..."
        .Flags = cdlOFNFileMustExist Or cdlOFNExplorer _
            Or cdlOFNHideReadOnly Or cdlOFNPathMustExist _
            Or cdlOFNShareAware Or cdlOFNNoDereferenceLinks
        .ShowSave
        sFile = .FileName
    End With
    Me.txtDesc.Text = GetFileDescription(sFile)
    Me.txtVer.Text = GetFileVersion(sFile)
    Me.txtFileSize.Text = FileLen(sFile)
    sFileName = Right$(sFile, Len(sFile) - InStrRev(sFile, "\"))
    Me.txtPath.Text = "\" & sFileName
    Me.txtURL.Text = Setup.DefaultWeb & sFileName
    Me.txtDesc.SetFocus
    Me.txtDesc.SelLength = Len(Me.txtDesc.Text)
Errs:
    If Err Then Exit Sub
End Sub

Private Function GetFileVersion(ByVal sFileName As String) As String
'**********************************************************************
'Adapted from code posted by Eric D. Burdo, http://www.rlisolutions.com
'"Retrieve the version number of a DLL"
'See full post here: http://programmers-corner.com/viewSource.php/71
'**********************************************************************
Dim lFreeSize   As Long
Dim tVerBuf()   As Byte
Dim sVerInfo    As VS_FIXEDFILEINFO
Dim lFreeHandle As Long
Dim lBuff       As Long
Dim iMajor      As Integer
Dim iMinor      As Integer
Dim sMajor      As String
Dim sMinor      As String
    lFreeSize = GetFileVersionInfoSize(sFileName, lFreeHandle)
    If lFreeSize Then
        If lFreeSize > 64000 Then lFreeSize = 64000
        ReDim tVerBuf(lFreeSize)
        GetFileVersionInfo sFileName, 0&, lFreeSize, tVerBuf(0)
        VerQueryValue tVerBuf(0), "\" & "", lBuff, lFreeSize
        CopyMemory sVerInfo, ByVal lBuff, lFreeSize
    End If
    iMajor = CInt(sVerInfo.dwFileVersionMS \ &H10000)
    iMinor = CInt(sVerInfo.dwFileVersionMS And &HFFFF&)
    sMajor = CStr(iMajor) & "." & LTrim$(CStr(iMinor))
    iMajor = CInt(sVerInfo.dwFileVersionLS \ &H10000)
    iMinor = CInt(sVerInfo.dwFileVersionLS And &HFFFF&)
    sMinor = CStr(iMajor) & "." & LTrim$(CStr(iMinor))
    GetFileVersion = sMajor & "." & sMinor
End Function

Private Function GetFileDescription(ByVal sFileName As String) As String
Dim nDummy          As Long
Dim nRet            As Long
Dim sBuffer()       As Byte
Dim nBufferLen      As Long
Dim lplpBuffer      As Long
Dim udtVerBuffer    As VS_FIXEDFILEINFO
Dim puLen           As Long
Dim nLanguage       As Integer
Dim nCodePage       As Integer
Dim sSubBlock       As String
    nBufferLen = GetFileVersionInfoSize(sFileName, nDummy)
    If nBufferLen = 0 Then Exit Function
    ReDim sBuffer(nBufferLen) As Byte
    Call GetFileVersionInfo(sFileName, 0&, nBufferLen, sBuffer(0))
    Call VerQueryValue(sBuffer(0), "\", lplpBuffer, puLen)
    Call CopyMemory(udtVerBuffer, ByVal lplpBuffer, Len(udtVerBuffer))
    If VerQueryValue(sBuffer(0), "\VarFileInfo\Translation", lplpBuffer, puLen) Then
        If puLen Then
            nRet = PointerToDWord(lplpBuffer)
            nLanguage = LoWord(nRet)
            nCodePage = HiWord(nRet)
            sSubBlock = "\StringFileInfo\" & FmtHex(&H409, 4) & FmtHex(nCodePage, 4) & "\"
            GetFileDescription = GetStdValue(VarPtr(sBuffer(0)), sSubBlock & "FileDescription")
        End If
    End If
End Function

Private Function GetStdValue(ByVal lpBlock As Long, ByVal Value As String) As String
Dim lplpBuffer       As Long
Dim puLen     As Long
    If VerQueryValue(ByVal lpBlock, Value, lplpBuffer, puLen) Then
        If puLen Then
            GetStdValue = PointerToString(lplpBuffer)
        End If
    End If
End Function

Private Function PointerToString(lpString As Long) As String
Dim Buffer As String
Dim nLen As Long
    If lpString Then
        nLen = lstrlenA(lpString)
        If nLen Then
            Buffer = Space(nLen)
            CopyMemory ByVal Buffer, ByVal lpString, nLen
            PointerToString = Buffer
        End If
    End If
End Function

Private Function FmtHex(ByVal InVal As Long, ByVal OutLen As Integer) As String
    FmtHex = Right$(String$(OutLen, "0") & Hex$(InVal), OutLen)
End Function

Private Function PointerToDWord(ByVal lpDWord As Long) As Long
Dim nRet As Long
    If lpDWord Then
        CopyMemory nRet, ByVal lpDWord, 4
        PointerToDWord = nRet
    End If
End Function

Private Function LoWord(ByVal LongIn As Long) As Integer
    Call CopyMemory(LoWord, LongIn, 2)
End Function

Private Function HiWord(ByVal LongIn As Long) As Integer
    Call CopyMemory(HiWord, ByVal (VarPtr(LongIn) + 2), 2)
End Function

Private Sub lblSelFile_MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single)
On Error Resume Next
    If x >= 0 And Y >= 0 And x < Me.ActiveControl.Width And Y < Me.ActiveControl.Height Then
        SetCursor LoadCursor(0, IDC_HAND)
    End If
    Err.Clear
End Sub

Private Function LimitTextInput(ByVal source As Integer, ByVal bAllowSeperators As Boolean) As String
'//Limits character input into a control.
Dim Numbers As String
    Numbers = IIf(bAllowSeperators, "0123456789.", "0123456789")
    If source <> 8 Then
        If InStr(Numbers, Chr(source)) = 0 Then
            LimitTextInput = 0
            Beep
            Exit Function
        End If
    End If
    LimitTextInput = source
End Function

Private Sub txtDesc_GotFocus()
    Call SelectAllText
    Call DisplayTip(Me.ActiveControl.Tag, Me)
End Sub

Private Sub txtFileSize_GotFocus()
    SelectAllText
    Call DisplayTip(Me.ActiveControl.Tag, Me)
End Sub

Private Sub txtPath_GotFocus()
    Call SelectAllText
    Call DisplayTip(Me.ActiveControl.Tag, Me)
End Sub

Private Sub txtUpdateMessage_GotFocus()
    Call SelectAllText
    Call DisplayTip(Me.ActiveControl.Tag, Me)
End Sub

Private Sub txtURL_GotFocus()
    Call SelectAllText
    Call DisplayTip(Me.ActiveControl.Tag, Me)
End Sub

Private Sub txtVer_GotFocus()
    Call SelectAllText
    Call DisplayTip(Me.ActiveControl.Tag, Me)
End Sub

Private Sub txtVer_KeyPress(KeyAscii As Integer)
    KeyAscii = LimitTextInput(KeyAscii, True)
End Sub

Private Sub txtFileSize_KeyPress(KeyAscii As Integer)
    KeyAscii = LimitTextInput(KeyAscii, False)
End Sub