modbff.bas

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

Attribute VB_Name = "ModBFF"
'This is a hacked version of Bobo's Browse for folder.  Don't use this.
'Go to PSC and get the original!

'***************BOBO  ENTERPRISES  2001**********************
'Please report any bugs through PSC or to [e-mail]
'(Subject: Browse for Folders BUG)
'
'Still to be implemented features:
'       Context help
'       Popup menu from Treeview
'       New folder update without restarting BFF
'Credit to "Mr. BoBo"
Option Explicit
'**************Win 2K compliant FileExists********************
Private Const INVALID_HANDLE_VALUE = -1
Private Const MAX_PATH = 260
Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime As FILETIME
    nFileSizeHigh As Long
    nFileSizeLow As Long
    dwReserved0 As Long
    dwReserved1 As Long
    cFileName As String * MAX_PATH
    cAlternate As String * 14
End Type
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Declare Function GetLogicalDriveStrings Lib "kernel32" Alias "GetLogicalDriveStringsA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
'**************CHECK OS*****************************
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (LpVersionInformation As OSVERSIONINFO) As Long
Private Type OSVERSIONINFO
    dwOSVersionInfoSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatformId As Long
    szCSDVersion As String * 128
End Type
'*********************General Declares**************************
Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function Putfocus Lib "user32" Alias "SetFocus" (ByVal hwnd As Long) As Long
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Private Declare Function SendMessageByString Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal x As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function RedrawWindow Lib "user32" (ByVal hwnd As Long, lprcUpdate As Any, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long
Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal cBytes&)
'constants required
Private Const GWL_WNDPROC = (-4)                'Used in setting hooks
Private Const GW_NEXT = 2                       'used to enumerate child windows
Private Const GW_CHILD = 5                      'used to enumerate child windows

Private Const WM_GETMINMAXINFO As Long = &H24&  'scrollbar settings
Private Const WM_LBUTTONUP = &H202              'used in hooks
Private Const WM_LBUTTONDOWN = &H201            'used in hooks
Private Const WM_CHAR = &H102                   'used in hooks
Private Const WM_SIZE = &H5                     'used in hooks
Private Const WM_GETFONT = &H31                 'used to get the current font
Private Const WM_SETFONT = &H30                 'used to set the font in any new windows
Private Const WM_EXITSIZEMOVE = &H232           'used in hooks
Private Const WM_GETTEXT = &HD                  'used to read textboxes
Private Const WM_GETTEXTLENGTH = &HE            'used to read textboxes
Private Const WM_HELP = &H53                    'used in hooks
Private Const WM_SETTEXT = &HC                  'used to update textboxes

Private Const WS_CHILD = &H40000000             'style setting
Private Const WS_EX_CLIENTEDGE = &H200&         'style setting
Private Const WS_EX_RIGHTSCROLLBAR = &H0&       'style setting
Private Const WS_DISABLED = &H8000000           'style setting
Private Const WS_EX_STATICEDGE = &H20000        'style setting

Private Const BM_GETCHECK = &HF0                'checking the state of the checkbox
Private Const BM_SETCHECK = &HF1                'checking the state of the checkbox
Private Const BM_CLICK = &HF5                   'simulate a button click

Private Const BS_CHECKBOX = &H2&                'style setting

Private Const EM_SETSEL = &HB1                  'used to update textboxes

Private Const ES_AUTOHSCROLL = &H80&            'style setting
Private Const ES_WANTRETURN = &H1000&           'style setting
Private Const ES_MULTILINE = &H4&               'style setting

Private Const SBS_SIZEGRIP = &H10&              'style setting
Private Const SBS_SIZEBOX = &H8&                'style setting

Private Const RDW_INVALIDATE = &H1              'redraw command



'Used to set the minimum scroll size
Private Type POINTAPI
    x As Long
    Y As Long
End Type
Private Type MINMAXINFO
    ptReserved As POINTAPI
    ptMaxSize As POINTAPI
    ptMaxPosition As POINTAPI
    ptMinTrackSize As POINTAPI
    ptMaxTrackSize As POINTAPI
End Type
'used to create new buttons,labels,checkboxes etc.
Private Type CREATESTRUCT
    lpCreateParams As Long
    hInstance As Long
    hMenu As Long
    hWndParent As Long
    cy As Long
    cx As Long
    Y As Long
    x As Long
    Style As Long
    lpszName As String
    lpszClass As String
    ExStyle As Long
End Type
'used to locate window positions
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Dim R As RECT
'********************Browse for Folders*****************************
Private Type BrowseInfo
  hWndOwner      As Long
  pIDLRoot       As Long
  pszDisplayName As Long
  lpszTitle      As Long
  ulFlags        As Long
  lpfnCallback   As Long
  lParam         As Long
  iImage         As Long
End Type
Private Const BIF_RETURNONLYFSDIRS = &H1
Private Const BIF_DONTGOBELOWDOMAIN = &H2
Private Const BIF_STATUSTEXT = &H4
Private Const BIF_RETURNFSANCESTORS = &H8
Private Const BIF_EDITBOX = &H10
Private Const BIF_VALIDATE = &H20
Private Const BIF_BROWSEFORCOMPUTER = &H1000
Private Const BIF_BROWSEFORPRINTER = &H2000
Private Const BIF_BROWSEINCLUDEFILES = &H4000
Private Const BFFM_ENABLEOK = &H465
Private Const BFFM_SETSELECTION = &H466
Private Const BFFM_SETSTATUSTEXT = &H464
Private Const BFFM_INITIALIZED = 1
Private Const BFFM_SELCHANGED = 2
Private Const BFFM_VALIDATEFAILED = 3
Public Const BIF_USENEWUI = &H40               '(SHELL32.DLL Version 5.0). Use the new user interface, including an edit box.

'****************Browse Load Variables********************
Public Type BoboBrowse
    Titlebar As String           'Browse for Folder window caption
    Prompt As String             'Descriptive text
    InitDir As String            'Start browsing from this folder
    CHCaption As String          'Checkbox caption
    OKCaption As String          'Browse for Folder OK button caption
    CancelCaption As String      'Browse for Folder Cancel button caption
    NewFCaption As String        'New folder button caption
    RootDir As Long              'Special folder to browse from
    AllowResize As Boolean       'Use the resize ability
    CenterDlg As Boolean         'Center the Browse for Folder window
    DoubleSizeDlg As Boolean     'Make the Browse for Folder window large (Not Double)
    FSDlg As Boolean             'Make the Browse for Folder window full screen
    ShowButton As Boolean        'Show the New folder button
    ShowCheck As Boolean         'Show the checkbox
    EditBoxOld As Boolean        'Use the default Browse for Folder Edit window
    EditBoxNew As Boolean        'Use Win2K style Browse for Folder Edit window
    StatusText As Boolean        'Show Browse for Folder Status text
    ShowFiles As Boolean         'Include files
    CHvalue As Integer           'Value returned by the checkbox
    OwnerForm As Long            'Handle to the calling form - if invalid Desktop window is used
End Type
Public BB As BoboBrowse

'*****************Browsing Variables**************
Dim DialogWindow As Long            'Browse for Folder window
Dim SysTreeWindow As Long           'Browse for Folder Treeview window
Dim OKbuttonWindow As Long          'Browse for Folder OK button window
Dim CancelbuttonWindow As Long      'Browse for Folder Cancel button window
Dim ScrollWindow As Long            'The scroll control to resize
Dim dummyWindow As Long             'Workaround Sizegrip for Win 95/98
Dim ButtonWindow As Long            'Either New folder button or checkbox
Dim StattxtWindow As Long           'Browse for Folder Status text window
Dim EditWindowOld As Long           'Browse for Folder Edit window
Dim EditWindow As Long              'New style edit window
Dim LabelWindow As Long             'Label for new style edit window
Dim EditTop As Long                 'Top of Browse for Folder Edit window
Dim EditHeight As Long              'Height of Browse for Folder Edit window
Dim StattxtTop As Long              'Top of Browse for Folder Status text window
Dim StattxtHeight As Long           'Height of Browse for Folder Status text window
Dim TreeTop As Long                 'Top of Browse for Treeview window
Dim CurrentDir As String            'Currently selected folder
Dim Newboy As Boolean               'User created a new folder
Dim RoomForSizer As Long            'Allow space for the scroll window
Private glPrevWndProc As Long       'Window hook for New Folder button
Private glPrevWndProcDlg As Long    'Window hook for Browse for Folder window
Private glPrevWndProcEdit As Long   'Window hook for new style edit window
Private glPrevWndProcFS As Long     'Window hook for Size grip (needed in Win2K)

Public Function BrowseFF() As String
'Call this function from your form

    'Example Calls :
    
    'Private Sub Command1_Click()
    '    BB.AllowResize = True
    '    BB.DoubleSizeDlg = True
    '    BB.OKCaption = "Open"
    '    BB.ShowFiles = True
    '    Label1 = BrowseFF
    'End Sub
    
    'or just:
    'Private Sub Command1_Click()
    '    Label1 = BrowseFF
    'End Sub
    
    Dim hFont As Long
    Dim IDList As Long
    Dim mTemp As String
    Dim mFlags As Long
    Dim tBrowseInfo As BrowseInfo
    BB.CHvalue = 0
startagain: 'If a new folder was created we need to come back here
    If IsWindow(BB.OwnerForm) = 0 Then BB.OwnerForm = GetDesktopWindow
    If Len(BB.Prompt) = 0 Then BB.Prompt = "Select a folder"
    mFlags = BIF_VALIDATE
    If BB.EditBoxOld Then mFlags = mFlags + BIF_EDITBOX
    If BB.StatusText Then mFlags = mFlags + BIF_STATUSTEXT
    If BB.ShowFiles Then mFlags = mFlags + BIF_BROWSEINCLUDEFILES
    With tBrowseInfo
      .hWndOwner = BB.OwnerForm
      .lpszTitle = lstrcat(BB.Prompt, "")
      .pIDLRoot = BB.RootDir
      .ulFlags = mFlags
      .lpfnCallback = GetAddressofFunction(AddressOf BrowseCallbackProc)