modbff.bas

一个比较简单美观的魔域登陆器源码

'This is a hook on either the new folder button or checkbox
Select Case uMsg

Case WM_HELP 'comment this out if you think its too cheesy
    MsgBox "Creates a new folder in the currently selected directory", vbInformation, "Bobo Enterprises"
    Exit Function
'Case WM_LBUTTONUP
'    If BB.ShowButton Then GoNewboy ' new folder please
Case WM_LBUTTONDOWN
    If BB.ShowCheck Then 'check or uncheck the checkbox
        BB.CHvalue = SendMessage(ButtonWindow, BM_GETCHECK, 0&, ByVal 0&)
        If BB.CHvalue = 0 Then
            SendMessage ButtonWindow, BM_SETCHECK, 1, ByVal 1&
            BB.CHvalue = 1 'remember what it is
        Else
            SendMessage ButtonWindow, BM_SETCHECK, 0, ByVal 1&
            BB.CHvalue = 0 'remember what it is
        End If
    Putfocus DialogWindow
    End If
    Exit Function
End Select
pMyWindowProc = CallWindowProc(glPrevWndProc, hw, uMsg, wParam, lParam)
End Function

'Public Sub GoNewboy()
'Dim temp As String, tmpDir As String, blnBad As Boolean, strNewDir As String
'
'    tmpDir = StripTerminator(CurrentDir)
'    Do
'        temp = InputBox("Enter a name for your new folder" + vbCrLf + tmpDir + "\...", BB.Titlebar)
'        temp = StripIllegals(temp, "the folder name")
'        If Len(Trim(temp)) = 0 Then
'            Exit Sub
'        End If
'        strNewDir = getFullPath(tmpDir, temp)
'        If Dir(strNewDir, vbNormal + vbHidden + vbDirectory) <> "" Then
'            MsgBox "A Folder of that name already exists." + vbCrLf + "Enter a different name and try again.", vbCritical, BB.Titlebar
'            blnBad = True
'        End If
'    Loop Until Not blnBad
'    MkDir strNewDir
'    BB.InitDir = strNewDir  'set the new start folder
'    Newboy = True
'    'Clean up and close the window so we can re-open at the new folder
'    Call pUnSubClass
'    Call pUnSubClassDlg
'    Call pUnSubClassEdit
'    Call pUnSubClassFS
'    Call SendMessage(CancelbuttonWindow, BM_CLICK, 0, 0)
'    DestroyWindow LabelWindow
'    DestroyWindow EditWindow
'    DestroyWindow ButtonWindow
'    DestroyWindow ScrollWindow
'    DestroyWindow dummyWindow
'End Sub
Private Sub SizeAndPosition()
'Like a form_resize event except with API
Dim sysH As Long
sysH = 81
If BB.EditBoxNew Then sysH = 120
Call MoveWindow(EditWindow, 68, R.Bottom - R.Top - 107, R.Right - R.Left - 90, 23, True)
Call MoveWindow(LabelWindow, 19, R.Bottom - R.Top - 101, 45, 13, True)
Call MoveWindow(SysTreeWindow, 21, TreeTop, R.Right - R.Left - 44, R.Bottom - R.Top - TreeTop - sysH, True)
If Is2K Then
    Call MoveWindow(ScrollWindow, R.Right - R.Left - 24, R.Bottom - R.Top - 44, 16, 16, True)
Else
    Call MoveWindow(ScrollWindow, R.Right - R.Left - 18, R.Bottom - R.Top - 38, 16, 16, True)
End If
If BB.ShowButton Then
    Call MoveWindow(ButtonWindow, R.Right - R.Left - 96, R.Bottom - R.Top - 71, 75, 23, True)
    Call MoveWindow(CancelbuttonWindow, R.Right - R.Left - 177, R.Bottom - R.Top - 71, 75, 23, True)
    Call MoveWindow(OKbuttonWindow, R.Right - R.Left - 258, R.Bottom - R.Top - 71, 75, 23, True)
ElseIf BB.ShowCheck Then
    Call MoveWindow(CancelbuttonWindow, R.Right - R.Left - 96, R.Bottom - R.Top - 71, 75, 23, True)
    Call MoveWindow(OKbuttonWindow, R.Right - R.Left - 177, R.Bottom - R.Top - 71, 75, 23, True)
    Call MoveWindow(ButtonWindow, 20, R.Bottom - R.Top - 71, 110, 23, True)
Else
    Call MoveWindow(CancelbuttonWindow, R.Right - R.Left - 96, R.Bottom - R.Top - 71, 75, 23, True)
    Call MoveWindow(OKbuttonWindow, R.Right - R.Left - 177, R.Bottom - R.Top - 71, 75, 23, True)
End If
If BB.EditBoxOld Then Call MoveWindow(EditWindowOld, 21, EditTop, R.Right - R.Left - 44, EditHeight, True)
If BB.StatusText Then Call MoveWindow(StattxtWindow, 21, StattxtTop, R.Right - R.Left - 44, StattxtHeight, True)
RedrawWindow DialogWindow, ByVal 0&, ByVal 0&, RDW_INVALIDATE
End Sub
Private Sub CleanUp() 'Tidy things up when done
    Call pUnSubClass
    Call pUnSubClassDlg
    Call pUnSubClassFS
    Call pUnSubClassEdit
    DestroyWindow LabelWindow
    DestroyWindow EditWindow
    DestroyWindow ButtonWindow
    DestroyWindow ScrollWindow
    DestroyWindow dummyWindow
End Sub
'***************** WORKER FUNCTIONS **************************
'get text from a window
Private Function gettext(lngwindow As Long) As String
    Dim strBuffer As String, lngtextlen As Long
    Let lngtextlen& = SendMessage(lngwindow&, WM_GETTEXTLENGTH, 0&, 0&)
    Let strBuffer$ = String(lngtextlen&, 0&)
    Call SendMessageByString(lngwindow&, WM_GETTEXT, lngtextlen& + 1&, strBuffer$)
    Let gettext$ = strBuffer$
End Function
'parse out just the filename
Private Function FileOnly(ByVal FilePath As String) As String
    If Len(FilePath) = 3 Then
        FileOnly = FilePath
        Exit Function
    End If
    FileOnly = Mid$(FilePath, InStrRev(FilePath, "\") + 1)
End Function
'parse out just the path
Private Function PathOnly(ByVal FilePath As String) As String
Dim temp As String
    temp = Mid$(FilePath, 1, InStrRev(FilePath, "\"))
    If Right(temp, 1) = "\" Then temp = Left(temp, Len(temp) - 1)
    PathOnly = temp
End Function
'Fileexists that works with win2K
Private Function FileExists(sSource As String) As Boolean
If Right(sSource, 2) = ":\" Then
    Dim allDrives As String
    allDrives = Space$(64)
    Call GetLogicalDriveStrings(Len(allDrives), allDrives)
    FileExists = InStr(1, allDrives, Left(sSource, 1), 1) > 0
    Exit Function
Else
    If Not sSource = "" Then
        Dim WFD As WIN32_FIND_DATA
        Dim hFile As Long
        hFile = FindFirstFile(sSource, WFD)
        FileExists = hFile <> INVALID_HANDLE_VALUE
        Call FindClose(hFile)
    Else
        FileExists = False
    End If
End If
End Function
'Remove any null characters at the end of a string
Private Function StripTerminator(ByVal strString As String) As String
    Dim intZeroPos As Integer
    intZeroPos = InStr(strString, Chr$(0))
    If intZeroPos > 0 Then
        StripTerminator = Left$(strString, intZeroPos - 1)
    Else
        StripTerminator = strString
    End If
End Function
'Which operating system ?
Private Function Is2K() As Boolean
On Error Resume Next
Dim tempOSVerInfo As OSVERSIONINFO
Dim DL As Long
tempOSVerInfo.dwOSVersionInfoSize = 148
DL = GetVersionEx(tempOSVerInfo)
If tempOSVerInfo.dwMajorVersion > 4 Then
    Is2K = True
Else
    Is2K = False
End If
End Function

Public Function Browse(strPrompt As String, strTitle As String, strStart As String, _
    hwnd As Long, Optional blnNew As Boolean = False) As String
    'Dim bb As BoboBrowse
    With BB
        'All these settings are optional
        'Leave all of them out and you are
        'left with the default Browse for Folders
        .Titlebar = strTitle
        .Prompt = strPrompt
        If Right$(strStart, 1) = "\" And Len(strStart) > 3 Then
            .InitDir = Left$(strStart, Len(strStart) - 1)
        Else
            .InitDir = strStart
        End If
'        .CHCaption = "Add to Favorites"
'        .OKCaption = "OK"
'        .CancelCaption = "Cancel"
'        .NewFCaption = "New Folder"
        '.RootDir = 0
        .AllowResize = True
        .CenterDlg = True
        .DoubleSizeDlg = False
        .FSDlg = False
        .ShowButton = blnNew
        .ShowCheck = False
        .EditBoxOld = False
        .EditBoxNew = True
        .StatusText = False
        .ShowFiles = False
        .OwnerForm = hwnd
        .CHvalue = 0
        'call the function
        Browse = BrowseFF
        'If you included a checkbox this is where you
        'recieve the users' response
        'blnAddToFav = .CHvalue
    End With
End Function


Public Function StripIllegals(StrIn As String, Optional strSrcDesc As String) As String
Dim intLoop As Integer, strOut As String, strRem As String, _
    strChar As String * 1, strDesc As String

    strOut = ""
    strRem = ""
    For intLoop = 1 To Len(StrIn)
        strChar = Mid$(StrIn, intLoop, 1)
        
        Select Case Asc(strChar)
            Case 34, 42, 47, 58, 60, 62, 63, 92, 124
                strRem = strRem & strChar & "  "
                'If Not blnStrip Then
                strOut = strOut & ReplaceChar(strChar)
            Case 0 To 31, 128, 129, 141 To 144, 157, 158
                strRem = strRem & "ASCII: " & CStr(Asc(strChar)) & "  "
                'If Not blnStrip Then
                strOut = strOut & "_"
            Case Else
                strOut = strOut & strChar
        End Select
    Next intLoop
    If strRem <> "" And strSrcDesc <> "" Then
        'If blnStrip Then
            'strDesc = "removed from "
        'Else
            strDesc = "replaced in "
        'End If
        MsgBox "The following characters were " & strDesc & _
            vbNewLine & strSrcDesc & ":" & _
            vbNewLine & strRem, vbExclamation + vbOKOnly, "Illegal Characters"
    End If
    StripIllegals = strOut
End Function


Public Function ReplaceChar(strIllChar As String) As String
        Select Case strIllChar
            Case "/", "\", "*", "|"
                ReplaceChar = "_"
            Case "?"
                ReplaceChar = "."
            Case ":"
                ReplaceChar = "-"
            Case "<"
                ReplaceChar = "("
            Case ">"
                ReplaceChar = ")"
            Case Chr$(34)
                ReplaceChar = "''"
            Case Else 'Not Illegal!
                ReplaceChar = strIllChar
        End Select
End Function