cdlg.cls

通用认证码识别(Captchio),非常好的,通用的开发模块

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cDlg"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Type BROWSEINFO  ' Folder Dialog
   hOwner           As Long
   pidlRoot         As Long
   pszDisplayName   As String
   lpszTitle        As String
   ulFlags          As Long
   lpfn             As Long
   lParam           As Long
   iImage           As Long
End Type
Private Declare Function SHBrowseForFolder Lib "shell32" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
' -------------- Extra functions for FolderDialog
Private Declare Function SHSimpleIDListFromPath Lib "shell32" Alias "#162" (ByVal szPath As String) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHFree Lib "shell32" Alias "#196" ()
Private Declare Function ILFree Lib "shell32" Alias "#195" (ByVal pidlFree As Long)
Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal pv As Long)

Private Type OPENFILENAME 'Open & Save Dialog
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As String
    nMaxCustFilter As Long
    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


Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long

' kernel32 functions
' For Font Dialog
Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (p1 As Any, p2 As Any) As Long

Public Enum CdlgExt_Actions
       cdlgOpen = 1
       cdlgSave = 2
 End Enum

' --------------- Enum Flags
Public Enum CdlgExt_Flags
 ' Open & Save Dialog
 cdlOFNAllowMultiselect = &H200
 cdlOFNCreatePrompt = &H2000
 cdlOFNExplorer = &H80000
 cdlOFNExtensionDifferent = &H400
 cdlOFNFileMustExist = &H1000
 cdlOFNHelpButton = &H10
 cdlOFNHideReadOnly = &H4
 cdlOFNLongNames = &H200000
 cdlOFNNoChangeDir = &H8
 cdlOFNNoDereferenceLinks = &H100000
 cdlOFNNoLongNames = &H40000
 cdlOFNNoReadOnlyReturn = &H8000
 cdlOFNNoValidate = &H100
 cdlOFNOverwritePrompt = &H2
 cdlOFNPathMustExist = &H800
 cdlOFNReadOnly = &H1
 cdlOFNShareAware = &H4000
 Folder_COMPUTER = &H1000
 Folder_PRINTER = &H2000
 Folder_INCLUDEFILES = &H4001
End Enum

Private RetValue As Long 'General
Const MAX_PATH = 260 'General
Private OFN As OPENFILENAME ' Open & Save Dialog

'Inner variables for properties
Private mFileName As String
Private mFileTitle As String
Private mhOwner As Long
Private mDialogTitle As String
Private mFilter As String
Private mInitDir As String
Private mDefaultExt As String
Private mFilterIndex As Long
Private mFlags As CdlgExt_Flags
Private mDialogPrompt As String
Private mCancelError As Boolean


' Let/Get Properties: General
Public Property Let Action(ByVal New_Action As CdlgExt_Actions)
   Select Case New_Action
       Case 1
            ShowOpen
       Case 2
            ShowSave
       Case Else
   End Select
End Property

Public Property Let CancelError(ByVal vData As Boolean)
   mCancelError = vData
End Property

Public Property Get CancelError() As Boolean
  CancelError = mCancelError
End Property

Public Property Get hOwner() As Long
    hOwner = mhOwner
End Property

Public Property Let hOwner(ByVal New_hOwner As Long)
    mhOwner = New_hOwner
End Property

Public Property Get flags() As CdlgExt_Flags
    flags = mFlags
End Property

Public Property Let flags(ByVal New_Flags As CdlgExt_Flags)
    mFlags = New_Flags
End Property

Public Property Get DialogTitle() As String
   DialogTitle = mDialogTitle
End Property

Public Property Let DialogTitle(sTitle As String)
   mDialogTitle = sTitle
End Property

Public Property Get DialogPrompt() As String
    DialogPrompt = mDialogPrompt
End Property

Public Property Let DialogPrompt(ByVal New_Prompt As String)
    mDialogPrompt = New_Prompt
End Property

' Open , Save, Folder, Icon

Public Property Get DefaultExt() As String
   DefaultExt = mDefaultExt
End Property

Public Property Let DefaultExt(sDefExt As String)
   mDefaultExt = DefaultExt
End Property

Public Property Get FileName() As String
   FileName = mFileName
End Property

Public Property Let FileName(sFileName As String)
   mFileName = sFileName
End Property

Public Property Get FileTitle() As String
   FileTitle = mFileTitle
End Property

Public Property Let FileTitle(sTitle As String)
   mFileTitle = sTitle
End Property

Public Property Get Filter() As String
   Filter = mFilter
End Property

Public Property Let Filter(sFilter As String)
   mFilter = sFilter
End Property

Public Property Get FilterIndex() As Long
   FilterIndex = mFilterIndex
End Property

Public Property Let FilterIndex(lIndex As Long)
    mFilterIndex = lIndex
End Property

Public Property Get InitDir() As String
   InitDir = mInitDir
End Property

Public Property Let InitDir(sDir As String)
    mInitDir = sDir
End Property


' Standard  Dialogs
Public Sub ShowOpen()
  Dim iDelim As Integer
  InitOFN
  If (flags And cdlOFNAllowMultiselect) = cdlOFNAllowMultiselect Then
    Dim s As String
    s = FileName & String$(8192 - Len(FileName), 0)
    With OFN
        .lpstrFile = s
        .nMaxFile = 8192
        s = FileTitle & String$(8192 - Len(FileTitle), 0)
        .lpstrFileTitle = s
        .nMaxFileTitle = 8192
    End With
  End If
  RetValue = GetOpenFileName(OFN)
  If RetValue > 0 Then
     If (flags And cdlOFNAllowMultiselect) = cdlOFNAllowMultiselect Then
        mFileName = OFN.lpstrFile
     Else
        iDelim = InStr(OFN.lpstrFileTitle, vbNullChar)
        If iDelim Then mFileTitle = Left$(OFN.lpstrFileTitle, iDelim - 1)
        iDelim = InStr(OFN.lpstrFile, vbNullChar)
        If iDelim Then mFileName = Left$(OFN.lpstrFile, iDelim - 1)
    End If
  Else
    mFileName = vbNullString
     If mCancelError Then Err.Raise 0
  End If
End Sub
Public Sub ShowSave()
  Dim iDelim As Integer
  InitOFN
  RetValue = GetSaveFileName(OFN)
  If RetValue > 0 Then
     iDelim = InStr(OFN.lpstrFileTitle, vbNullChar)
     If iDelim Then mFileTitle = Left$(OFN.lpstrFileTitle, iDelim - 1)
     iDelim = InStr(OFN.lpstrFile, vbNullChar)
     If iDelim Then mFileName = Left$(OFN.lpstrFile, iDelim - 1)
  Else
    mFileName = vbNullString
     If mCancelError Then Err.Raise 0
  End If
End Sub
Public Function ShowFolder() As String '(Optional ByVal SelFolder As String) As String
  Dim bi As BROWSEINFO
  Dim pidl As Long, Path As String, pos As Integer, uFlag As Long
  'TopFolder = TopFolder & Chr$(0)
  'SelFolder = SelFolder & Chr$(0)
  bi.hOwner = mhOwner
  If mInitDir <> vbNullString Then
    bi.pidlRoot = SHSimpleIDListFromPath(mInitDir) 'Translate String (Path) to pointer (pidl)
End If
  bi.lpszTitle = mDialogPrompt
'  bi.lpfn = FARPROC(AddressOf BrowseCallbackProc) 'this string allow you preselect folder
'  bi.lParam = SHSimpleIDListFromPath(SelFolder) 'Translate String (Path) to pointer (pidl)
' If you want pre-select folder, you need add bas module
' to your project with following code:
'Const WM_USER = &H400
'Const BFFM_SETSELECTIONA As Long = (WM_USER + 102)
'Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
'
'Public Function FARPROC(pfn As Long) As Long
'  FARPROC = pfn
'End Function
'
'Public Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lParam As Long, ByVal lpData As Long) As Long
'   Select Case uMsg
'      Case BFFM_INITIALIZED
'           Call SendMessage(hWnd, BFFM_SETSELECTIONA, False, ByVal lpData)
'      Case Else:
'   End Select
'End Function
  uFlag = mFlags And (&H1000 Or &H2000 Or &H4001)
  If uFlag < Folder_COMPUTER Then
     bi.ulFlags = &H1
  Else
     bi.ulFlags = uFlag
  End If
  pidl = SHBrowseForFolder(bi) ' Get pidl for selected folder
  Path = String$(MAX_PATH, 0)
  ' translate pidl to Path
  If SHGetPathFromIDList(ByVal pidl, ByVal Path) Then
     pos = InStr(Path, Chr$(0))
     ShowFolder = Left(Path, pos - 1)
    Else
    ShowFolder = vbNullString
  End If
  Call CoTaskMemFree(pidl) ' Free Memory
End Function

Private Sub InitOFN()
  Dim sTemp As String, i As Integer
  Dim uFlag As Long
  uFlag = mFlags And (&H1 Or &H2 Or &H4 Or &H8 Or &H10 Or &H100 Or &H200 Or &H400 Or &H800 Or &H1000 Or &H2000 Or &H4000 Or &H8000 Or &H40000 Or &H80000 Or &H100000 Or &H200000)
  With OFN
       .lStructSize = Len(OFN)
       .hwndOwner = mhOwner
       .flags = uFlag
       .lpstrDefExt = mDefaultExt
       sTemp = mInitDir
       'If sTemp = "" Then sTemp = App.path
       .lpstrInitialDir = sTemp
       sTemp = mFileName
       If Len(sTemp) < 255 Then
        .lpstrFile = sTemp & String$(255 - Len(sTemp), 0)
        End If
       .nMaxFile = 255
       .lpstrFileTitle = String$(255, 0)
       .nMaxFileTitle = 255
        sTemp = mFilter
        For i = 1 To Len(sTemp)
            If Mid(sTemp, i, 1) = "|" Then
               Mid(sTemp, i, 1) = vbNullChar
            End If
        Next
        sTemp = sTemp & String$(2, 0)
        .lpstrFilter = sTemp
        .nFilterIndex = mFilterIndex
        .lpstrTitle = mDialogTitle
        .hInstance = App.hInstance
 End With
End Sub

Public Sub ParseMultiFileName( _
      ByRef sDir As String, _
      ByRef sFiles() As String, _
      ByRef iFileCount As Long _
   )
Dim iPos As Long
Dim iNextPos As Long
Dim sAllFiles As String
Dim i As Long

   iPos = InStr(mFileName, vbNullChar & vbNullChar)
   Debug.Print iPos
   If iPos <> 0 Then
      ' multi names
      sAllFiles = Left$(mFileName, iPos - 1)
      iPos = 1
      iNextPos = InStr(sAllFiles, vbNullChar)
      Do While iNextPos <> 0
        Debug.Print iNextPos
         If (sDir = "") Then
            sDir = Mid$(sAllFiles, iPos, iNextPos - iPos)
         Else
            iFileCount = iFileCount + 1
            ReDim Preserve sFiles(1 To iFileCount) As String
            sFiles(iFileCount) = Mid$(sAllFiles, iPos, iNextPos - iPos)
         End If
         iPos = iNextPos + 1
         iNextPos = InStr(iPos, sAllFiles, vbNullChar)
      Loop
      iFileCount = iFileCount + 1
      ReDim Preserve sFiles(1 To iFileCount) As String
      sFiles(iFileCount) = Mid$(sAllFiles, iPos)
   Else
      ' single file
      iFileCount = 1
      ReDim sFiles(1 To 1) As String
      For i = Len(mFileName) To 1 Step -1
         If Mid$(mFileName, i, 1) = "\" Then
            If (i > 1) Then
               sDir = Left$(mFileName, i - 1)
               sFiles(1) = Mid$(mFileName, i + 1)
            Else
               sDir = ""
               sFiles(1) = mFileName
            End If
            Exit Sub
         End If
      Next i
      sDir = ""
      sFiles(1) = mFileName
   End If
End Sub