modcmdialog.bas

一个简单易用的串口调试工具.全api完成.

Attribute VB_Name = "modCMDialog"

Option Explicit
Public giCommonDialogStyle As COMMON_DIALOG_STYLE
Public Const WM_NOTIFY = &H4E
Public Const CDN_FIRST = (-601)
Public Const CDN_LAST = (-699)
Public Const CDN_INITDONE = (CDN_FIRST - &H0)
Public Const CDN_SELCHANGE = (CDN_FIRST - &H1)
Public Const CDN_FOLDERCHANGE = (CDN_FIRST - &H2)
Public Const CDN_SHAREVIOLATION = (CDN_FIRST - &H3)
Public Const CDN_HELP = (CDN_FIRST - &H4)
Public Const CDN_FILEOK = (CDN_FIRST - &H5)
Public Const CDN_TYPECHANGE = (CDN_FIRST - &H6)
Public Const DWL_MSGRESULT = 0
Public Const SWP_SHOWWINDOW = &H40
Public Const OFN_READONLY = &H1
Public Const OFN_OVERWRITEPROMPT = &H2
Public Const OFN_HIDEREADONLY = &H4
Public Const OFN_NOCHANGEDIR = &H8
Public Const OFN_SHOWHELP = &H10
Public Const OFN_ENABLEHOOK = &H20
Public Const OFN_ENABLETEMPLATE = &H40
Public Const OFN_ENABLETEMPLATEHANDLE = &H80
Public Const OFN_NOVALIDATE = &H100
Public Const OFN_ALLOWMULTISELECT = &H200
Public Const OFN_EXTENSIONDIFFERENT = &H400
Public Const OFN_PATHMUSTEXIST = &H800
Public Const OFN_FILEMUSTEXIST = &H1000
Public Const OFN_CREATEPROMPT = &H2000
Public Const OFN_SHAREAWARE = &H4000
Public Const OFN_NOREADONLYRETURN = &H8000
Public Const OFN_NOTESTFILECREATE = &H10000
Public Const OFN_EXPLORER = &H80000
Public Const OFN_LONGNAMES = &H200000
Public Const OFN_SHAREFALLTHROUGH = 2
Public Const OFN_SHARENOWARN = 1
Public Const OFN_SHAREWARN = 0
Public Const IDOK = 1
Public Const IDCANCEL = 2
Type OPENFILENAME
    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
Public Enum COMMON_DIALOG_STYLE
  OPENFILE_PICTURE = 1
  OPENFILE_AUDIO = 2
  OPENFILE_DELETEFILE = 3
  OPEN_FONT_DIALOG = 4
  OPEN_COLOR_DIALOG = 5
  OPENFILE_LIST = 6
End Enum
Private Type POINTAPI
  X As Long
  Y As Long
End Type
Private Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type
Type OPENFILENAME2
        lStructSize As Long
        hwndOwner As Long
        hInstance As Long
        lpstrFilter As Long
        lpstrCustomFilter As Long
        nMaxCustFilter As Long
        nFilterIndex As Long
        lpstrFile As Long
        nMaxFile As Long
        lpstrFileTitle As Long
        nMaxFileTitle As Long
        lpstrInitialDir As Long
        lpstrTitle As Long
        Flags As Long
        nFileOffset As Integer
        nFileExtension As Integer
        lpstrDefExt As Long
        lCustData As Long
        lpfnHook As Long
        lpTemplateName As Long
End Type
Type NMHDR
    hwndFrom As Long
    idFrom As Long
    code As Long
End Type
Type OFNOTIFY
        hdr As NMHDR
        lpOFN As OPENFILENAME2
        pszFile As Long
End Type
Private Declare Function GetDlgItem Lib "user32" (ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long
Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String) As Long
Private Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Sub CopyMemory2 Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, ByVal Source As Any, ByVal Length As Long)
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, Source As Any, ByVal Lenght As Long)
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private 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
Declare Function CommDlgExtendedError Lib "comdlg32.dll" () As Long
Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
Declare Function GetFileTitle Lib "comdlg32.dll" Alias "GetFileTitleA" (ByVal lpszFile As String, ByVal lpszTitle As String, ByVal cbBuf As Integer) As Integer
Function CDNotify(ByVal hWnd As Long, ByVal lp As Long) As Long
Dim hdlgParent As Long
Dim rc As RECT, rcDesk As RECT, rL As RECT, rcDE As RECT
Dim lpon As OFNOTIFY
Const MAX_PATH = 255
Dim hLV As Long
Dim oldParent As Long
Dim hPic As Long
Dim pt As POINTAPI
Dim lRet As Long
Static X As Long, Y As Long, H As Long, W As Long
Dim api As Long, hCaption As Long
Dim hButtonOK As Long
Dim hCtrl As Long, rCtrl As RECT, hToolBar As Long, xPos As Long, yPos As Long
Dim rcTB As RECT
    CopyMemory2 lpon, lp&, Len(lpon)
    Select Case lpon.hdr.code
          Case CDN_INITDONE:
            hdlgParent = GetParent(hWnd)
            GetWindowRect hdlgParent, rc
            If giCommonDialogStyle = OPENFILE_DELETEFILE Then
                hCtrl = GetDlgItem(hdlgParent, IDOK)
                SetWindowText& hCtrl, "打开"
            End If
            rcDesk.Left = 0
            rcDesk.Top = 0
            rcDesk.Right = Screen.Width / Screen.TwipsPerPixelX
            rcDesk.Bottom = Screen.Height / Screen.TwipsPerPixelY
            SetWindowPos hdlgParent, 0, (rcDesk.Right - (rc.Right - rc.Left)) / 2, (rcDesk.Bottom - (rc.Bottom - rc.Top)) / 2, rc.Right - rc.Left, rc.Bottom - rc.Top, SWP_SHOWWINDOW
    End Select

    Exit Function
    
Salta:
End Function
Sub szTrimNull(st As String)
Dim pos As Long
  pos = InStr(st, vbNullChar)
    If pos > 0 Then
        st = Left$(st, pos - 1)
    End If
End Sub
Function pFileOpen(ByVal myForm As Form, FError&, Filter$, IDir$, Title$, Index%, Flags&, Optional sFileName$) As String

    pFileOpen = 0: FError = 0
    Dim O As OPENFILENAME
    Dim Address As Long
    Dim szFile$, szFilter$, szInitialDir$, szTitle$
    Dim result As Long
    Dim File$, FullPath$

    szFile$ = sFileName & String$(256 - Len(sFileName), 0)
    szFilter$ = Filter$
    szInitialDir$ = IDir$
    szTitle$ = Title$
    
    O.lStructSize = Len(O)
    O.hwndOwner = myForm.hWnd
    O.Flags = Flags&
    O.lpstrFilter = szFilter$ & vbNullChar
    O.nFilterIndex = Index%
    O.lpstrFile = szFile
    O.nMaxFile = Len(szFile$)
    O.lpstrFileTitle = szFile$ & vbNullChar
    O.lpstrInitialDir = szInitialDir$ & vbNullChar
    O.lpstrTitle = szTitle$ & vbNullChar
    O.lpfnHook = VBGetProcAddress(AddressOf CDCallBack)
    result = GetOpenFileName(O)
    FError& = CommDlgExtendedError()
    If result = 0 Then
        pFileOpen = 3
    End If
    If (InStr(O.lpstrFileTitle, Chr$(0)) - 1) = 0 Then
        FullPath$ = Left$(O.lpstrFile, InStr(O.lpstrFile, Chr(0)) - 1)
        File$ = szFile$
    Else
        File$ = Left$(O.lpstrFileTitle, InStr(O.lpstrFileTitle, Chr$(0)) - 1)
        FullPath$ = Left$(O.lpstrFile, O.nFileOffset) & File$
    End If
    Dim Buffer As String
    Buffer = String(255, 0)
    GetFileTitle FullPath$, Buffer, Len(Buffer)
    pFileOpen = FullPath$
End Function
Function pFileSave(myForm As Form, FError As Long, Filter As String, IDir As String, FileMask As String, Index As Integer, Title As String, Flags As String, DefExt As String, Optional sFileName As String) As Long
    pFileSave = 0: FError = 0
    Dim s As OPENFILENAME
    Dim Address As Long
    Dim szFile As String, szFilter As String, szInitialDir As String, szTitle As String, NoTitle As String
    Dim result As Long
    Dim File As String, FullPath As String
    NoTitle = FileMask
    szFile = NoTitle + String(256 - Len(NoTitle), 0)
    szFilter = Filter
    szInitialDir = IDir
    szTitle = Title
    s.lStructSize = Len(s)
    s.hwndOwner = myForm.hWnd
    s.Flags = Flags
    s.nFilterIndex = 0
    s.lpstrFile = szFile
    s.nMaxFile = Len(szFile$)
    s.lpstrFileTitle = szFile & vbNullChar
    s.lpstrFilter = szFilter & vbNullChar
    s.lpstrInitialDir = szInitialDir & vbNullChar
    s.lpstrTitle = szTitle & vbNullChar
    s.lpstrDefExt = DefExt
    s.lpfnHook = VBGetProcAddress(AddressOf CDCallBack)
    result = GetSaveFileName(s)
    FError = CommDlgExtendedError()
    If result = 0 Then
        pFileSave = 3
        Exit Function
    End If
    File$ = Left$(s.lpstrFileTitle, InStr(s.lpstrFileTitle, Chr$(0)) - 1)
    FullPath = Left$(s.lpstrFile, s.nFileOffset) & File$
End Function
Public Function CmdError(X As Long) As String
Dim pError As String

    If X = 32765 Then
        pError = "#" + LTrim$(Str$(X)) + ",  " + "Common dialog function failed during initialization (not enough memory?)."
    ElseIf X = 32761 Then
        pError = "#" + LTrim$(Str$(X)) + ",  " + "Common dialog function failed to load a specified string."
    ElseIf X = 32760 Then
        pError = "#" + LTrim$(Str$(X)) + ",  " + "Common dialog function failed to load a specified resource."
    ElseIf X = 32759 Then
        pError = "#" + LTrim$(Str$(X)) + ",  " + "Common dialog function failed to lock a specified resource."
    ElseIf X = 32758 Then
        pError = "#" + LTrim$(Str$(X)) + ",  " + "Common dialog function unable to allocate memory for internal data structures."
    ElseIf X = 32757 Then
        pError = "#" + LTrim$(Str$(X)) + ",  " + "Common dialog function unable to lock memory associated with a handle."
    ElseIf X = 32755 Then
        pError = "#" + LTrim$(Str$(X)) + ",  " + "Cancel was selected."
    ElseIf X = 32752 Then
        pError = "#" + LTrim$(Str$(X)) + ",  " + "Couldn't allocate memory for FileName or Filter."
    ElseIf X = 32751 Then
        pError = "#" + LTrim$(Str$(X)) + ",  " + "The call to WinHelp failed.  Check the Help property values."
    ElseIf X = 28671 Then
        pError = "#" + LTrim$(Str$(X)) + ",  " + "The PD_RETURNDEFAULT flag was set in the Flags member of PRINTDLG data structure, but either hDevMode or hDevNames field were nonzero."
    ElseIf X = 28670 Then
        pError = "#" + LTrim$(Str$(X)) + ",  " + "Load of the required resources failed."
    ElseIf X = 28669 Then
        pError = "#" + LTrim$(Str$(X)) + ",  " + "The common dialog function failed to parse the strings in the [devices] section of the WIN.INI file."
    ElseIf X = 28668 Then
        pError = "#" + LTrim$(Str$(X)) + ",  " + "The PD_RETURNDEFAULT flag was set in the Flags member of PRINTDLG data structure, but either hDevMode or hDevNames field were nonzero."
    ElseIf X = 28667 Then
        pError = "#" + LTrim$(Str$(X)) + ",  " + "The PRINTDLG function failed to load the specified printer's device driver."
    ElseIf X = 28666 Then
        pError = "#" + LTrim$(Str$(X)) + ",  " + "The printer device-driver failed to initialize a DEVMODE data structure (print driver written for WIN 3.0 or later)."
    ElseIf X = 28665 Then
        pError = "#" + LTrim$(Str$(X)) + ",  " + "The PRINTDLG function failed during initialization."
    ElseIf X = 28664 Then
        pError = "#" + LTrim$(Str$(X)) + ",  " + "No printer device-drivers were found."
    ElseIf X = 28663 Then
        pError = "#" + LTrim$(Str$(X)) + ",  " + "A default printer does not exist."
    ElseIf X = 28662 Then
        pError = "#" + LTrim$(Str$(X)) + ",  " + "The data in the DEVMODE and DEVNAMES data structrues describes two different printers."
    ElseIf X = 28661 Then
        pError = "#" + LTrim$(Str$(X)) + ",  " + "The PRINTDLG function failed when it attempted to create an information context."
    ElseIf X = 28660 Then
        pError = "#" + LTrim$(Str$(X)) + ",  " + "The [devices] section of the WIN.INI file does not contain an entry for requested printer."
    ElseIf X = 24574 Then
        pError = "#" + LTrim$(Str$(X)) + ",  " + "No fonts exist.  Must set internally to CF_BOTH, CF_PRINTERFONTS or CF_SCREENFONTS."
    ElseIf X = 20478 Then
        pError = "#" + LTrim$(Str$(X)) + ",  " + "An attempt to subclass a listbox failed due to insufficient memory."
    ElseIf X = 20477 Then
        pError = "#" + LTrim$(Str$(X)) + ",  " + "File name is invalid."
    ElseIf X = 20476 Then
        pError = "#" + LTrim$(Str$(X)) + ",  " + "The buffer at which the member lpstrFile points to is too small."
    Else
        pError = "Unknow Printer Error:  #" & Str(X)
    End If
    CmdError = pError
    End Function
Public Function VBGetProcAddress(ByVal lpfn As Long) As Long
    VBGetProcAddress = lpfn
End Function

Function CDCallBack(ByVal hWnd As Long, ByVal msg As Long, ByVal wp As Long, ByVal lp As Long) As Long
Dim retV As Long, lRet As Long
On Error GoTo CDCallBack_Error
 retV = False
    Select Case msg
        Case WM_NOTIFY
            retV = CDNotify(hWnd, lp)
        End Select
    CDCallBack = retV
On Error GoTo 0
  Exit Function

CDCallBack_Error:
  Debug.Print "Error " & Err.Number & " (" & Err.Description & ")" & vbCrLf & "in procedure CDCallBack of Modulo modCMDialog"
  Resume Next
End Function