commondialogs.bas

关于国际象棋的VB示例

'// Syntax:
'// BOOL = SetDefaultPrinter(object)
'//
'// Example:
'// Dim objNewPrinter As Printer
'// Set objNewPrinter = Printers(2)
'// SetDefaultPrinter objNewPrinter
'//

Public Function SetDefaultPrinter(objPrn As Printer) As Boolean

    Dim X As Long, szTmp As String
    
    szTmp = objPrn.DeviceName & "," & objPrn.DriverName & "," & objPrn.Port
    X = WriteProfileString("windows", "device", szTmp)
    X = SendMessageByString(HWND_BROADCAST, WM_WININICHANGE, 0&, "windows")
    
End Function

'//
'// GetDefaultPrinter Function
'//
'// Description:
'// Retuns the device name of the default printer.
'//
'// Syntax:
'// StrVar = GetDefaultPrinter()
'//
'// Example:
'// szDefPrinter = GetDefaultPrinter
'//

Public Function GetDefaultPrinter() As String

    Dim X As Long, szTmp As String, dwBuf As Long

    dwBuf = 1024
    szTmp = Space(dwBuf + 1)
    X = GetProfileString("windows", "device", "", szTmp, dwBuf)
    GetDefaultPrinter = Trim(Left(szTmp, X))

End Function

'//
'// ResetDefaultPrinter Function
'//
'// Description:
'// Resets the default printer to the passed device name.
'//
'// Syntax:
'// BOOL = ResetDefaultPrinter(StrVar)
'//
'// Example:
'// szDefPrinter = GetDefaultPrinter()
'// If Not ResetDefaultPrinter(szDefPrinter) Then
'//     MsgBox "Could not reset default printer.", vbExclamation
'// End If
'//

Public Function ResetDefaultPrinter(szBuf As String) As Boolean

    Dim X As Long
    
    X = WriteProfileString("windows", "device", szBuf)
    X = SendMessageByString(HWND_BROADCAST, WM_WININICHANGE, 0&, "windows")

End Function

'//
'// BrowseFolder Function
'//
'// Description:
'// Allows the user to interactively browse and select a folder found in the file system.
'//
'// Syntax:
'// StrVar = BrowseFolder(hWnd, StrVar)
'//
'// Example:
'// szFilename = BrowseFolder(Me.hWnd, "Browse for application folder:")
'//

Public Function BrowseFolder(hWnd As Long, szDialogTitle As String) As String

    Dim X As Long, BI As BROWSEINFO, dwIList As Long, szPath As String, wPos As Integer
    
    BI.hOwner = hWnd
    BI.lpszTitle = szDialogTitle
    BI.ulFlags = BIF_RETURNONLYFSDIRS
    dwIList = SHBrowseForFolder(BI)
    szPath = Space$(512)
    X = SHGetPathFromIDList(ByVal dwIList, ByVal szPath)
    If X Then
        wPos = InStr(szPath, Chr(0))
        BrowseFolder = Left$(szPath, wPos - 1)
    Else
        BrowseFolder = ""
    End If

End Function

'//
'// DialogConnectToPrinter Function
'//
'// Description:
'// Allows users to interactively selection and connect to local and network printers.
'//
'// Syntax:
'// DialogConnectToPrinter
'//
'// Example:
'// DialogConnectToPrinter
'//

Public Function DialogConnectToPrinter() As Boolean

    Shell "rundll32.exe shell32.dll,SHHelpShortcuts_RunDLL AddPrinter", vbNormalFocus
    
End Function

'//
'// ByteToString Function
'//
'// Description:
'// Converts an array of bytes into a string
'//
'// Syntax:
'// StrVar = ByteToString(ARRAY)
'//
'// Example:
'// szBuf = BytesToString(aChars(10))
'//

Private Function ByteToString(aBytes() As Byte) As String

    Dim dwBytePoint As Long, dwByteVal As Long, szOut As String
    
    dwBytePoint = LBound(aBytes)
    
    While dwBytePoint <= UBound(aBytes)
        
        dwByteVal = aBytes(dwBytePoint)
        
        If dwByteVal = 0 Then
            ByteToString = szOut
            Exit Function
        Else
            szOut = szOut & Chr$(dwByteVal)
        End If
        
        dwBytePoint = dwBytePoint + 1
    
    Wend
    
    ByteToString = szOut
    
End Function

'//
'// DialogColor Function
'//
'// Description:
'// Displays the Color common dialog box and sets a passed controls foreground color.
'//
'// Syntax:
'// BOOL = DialogColor(hWnd, CONTROL)
'//
'// Example:
'// Dim yn as Boolean
'// yn = DialogColor(Me.hWnd, txtEditor)
'//

Public Function DialogColor(hWnd As Long, C As Control) As Boolean

    Dim X As Long, CS As COLORSTRUC, CustColor(16) As Long
    
    CS.lStructSize = Len(CS)
    CS.hWnd = hWnd
    CS.hInstance = App.hInstance
    CS.Flags = CC_SOLIDCOLOR
    CS.lpCustColors = String$(16 * 4, 0)
    X = ChooseColor(CS)
    If X = 0 Then
        DialogColor = False
    Else
        DialogColor = True
        C.ForeColor = CS.rgbResult
    End If
    
End Function

'//
'// DialogFont Function
'//
'// Description:
'// Displays the Font common dialog box and sets a passed controls font properties.
'//
'// Syntax:
'// BOOL = DialogFont(hWnd, CONTROL)
'//
'// Example:
'// Dim yn as Boolean
'// yn = DialogFont(Me.hWnd, txtEditor)
'//

Public Function DialogFont(hWnd As Long, C As Control) As Boolean

    Dim LF As LOGFONT, FS As FONTSTRUC
    Dim lLogFontAddress As Long, lMemHandle As Long
    
    If C.Font.Bold Then LF.lfWeight = FW_BOLD
    If C.Font.Italic = True Then LF.lfItalic = 1
    If C.Font.Underline = True Then LF.lfUnderline = 1
    
    FS.lStructSize = Len(FS)
    
    lMemHandle = GlobalAlloc(GHND, Len(LF))
    If lMemHandle = 0 Then
        DialogFont = False
        Exit Function
    End If
    
    lLogFontAddress = GlobalLock(lMemHandle)
    If lLogFontAddress = 0 Then
        DialogFont = False
        Exit Function
    End If
    
    CopyMemory ByVal lLogFontAddress, LF, Len(LF)
    FS.lpLogFont = lLogFontAddress
    FS.iPointSize = C.Font.Size * 10
    FS.Flags = CF_SCREENFONTS Or CF_EFFECTS
    
    If ChooseFont(FS) = 1 Then
    
        CopyMemory LF, ByVal lLogFontAddress, Len(LF)
            
        If LF.lfWeight >= FW_BOLD Then
            C.Font.Bold = True
        Else
            C.Font.Bold = False
        End If
                        
        If LF.lfItalic = 1 Then
            C.Font.Italic = True
        Else
            C.Font.Italic = False
        End If
            
        If LF.lfUnderline = 1 Then
            C.Font.Underline = True
        Else
            C.Font.Underline = False
        End If
        
        C.Font.Name = ByteToString(LF.lfFaceName())
        C.Font.Size = CLng(FS.iPointSize / 10)
        
        DialogFont = True
            
    Else
    
        DialogFont = False
            
    End If
    
End Function

'//
'// DialogFile Function
'//
'// Description:
'// Displays the File Open/Save As common dialog boxes.
'//
'// Syntax:
'// StrVar = DialogFile(hWnd, IntVar, StrVar, StrVar, StrVar, StrVar, StrVar)
'//
'// Example:
'// szFilename = DialogFile(Me.hWnd, 1, "Open", "MyFileName.doc", "Documents" & Chr(0) & "*.doc" & Chr(0) & "All files" & Chr(0) & "*.*", App.Path, "doc", Path)
'//
'// Please note that the szFilter var works a bit differently
'// from the filter property associated with the common dialog
'// control. Instead of separating the differents parts of the
'// string with pipe chars, |, you should use null chars, Chr(0),
'// as separators.

Public Function DialogFile(hWnd As Long, wMode As Integer, szDialogTitle As String, szFilename As String, szFilter As String, szDefDir As String, szDefExt As String, szDestDir As String) As String

    Dim X As Long, OFN As OPENFILENAME, szFile As String, szFileTitle As String
    
    OFN.lStructSize = Len(OFN)
    OFN.hWnd = hWnd
    OFN.lpstrTitle = szDialogTitle
    OFN.lpstrFile = szFilename & String$(250 - Len(szFilename), 0)
    OFN.nMaxFile = 255
    OFN.lpstrFileTitle = String$(255, 0)
    OFN.nMaxFileTitle = 255
    OFN.lpstrFilter = szFilter
    OFN.nFilterIndex = 1
    OFN.lpstrInitialDir = szDefDir
    OFN.lpstrDefExt = szDefExt

    If wMode = 1 Then
        OFN.Flags = OFN_HIDEREADONLY Or OFN_PATHMUSTEXIST Or OFN_FILEMUSTEXIST
        X = GetOpenFileName(OFN)
    Else
        OFN.Flags = OFN_HIDEREADONLY Or OFN_OVERWRITEPROMPT Or OFN_PATHMUSTEXIST
        X = GetSaveFileName(OFN)
    End If
    
    If X <> 0 Then
    
        '// If InStr(OFN.lpstrFileTitle, Chr$(0)) > 0 Then
        '//     szFileTitle = Left$(OFN.lpstrFileTitle, InStr(OFN.lpstrFileTitle, Chr$(0)) - 1)
        '// End If
        If InStr(OFN.lpstrFile, Chr$(0)) > 0 Then
            szFile = Left$(OFN.lpstrFile, InStr(OFN.lpstrFile, Chr$(0)) - 1)
        End If
        '// OFN.nFileOffset is the number of characters from the beginning of the
        '// full path to the start of the file name
        '// OFN.nFileExtension is the number of characters from the beginning of the
        '// full path to the file's extention, including the (.)
        '// MsgBox "File Name is " & szFileTitle & Chr$(13) & Chr$(10) & "Full path and file is " & szFile, , "Open"
        
        '// DialogFile = szFile & "|" & szFileTitle
        DialogFile = szFile
        szDestDir = Left(szFile, OFN.nFileOffset)
        
    Else
    
        DialogFile = ""
        
    End If
    
End Function


'//
'// DialogPrint Function
'//
'// Description:
'// Displays the Print common dialog box and returns a structure containing user entered
'// information from the common dialog box.
'//
'// Syntax:
'// PRINTPROPS = DialogPrint(hWnd, BOOL, DWORD)
'//
'// Example:
'// Dim PP As PRINTPROPS
'// PP = DialogPrint(Me.hWnd, True, PD_PAGENUMS or PD_SELECTION or PD_SHOWHELP)
'//

Public Function DialogPrint(hWnd As Long, bPages As Boolean, Flags As Long) As PRINTPROPS

    Dim DM As DEVMODE, PD As PRINTDLGSTRUC
    Dim lpDM As Long, wNull As Integer, szDevName As String
    
    PD.lStructSize = Len(PD)
    PD.hWnd = hWnd
    PD.hDevMode = 0
    PD.hDevNames = 0
    PD.hDC = 0
    PD.Flags = Flags
    PD.nFromPage = 0
    PD.nToPage = 0
    PD.nMinPage = 0
    If bPages Then PD.nMaxPage = bPages - 1
    PD.nCopies = 0
    DialogPrint.Cancel = True
    
    If PrintDlg(PD) Then
    
        lpDM = GlobalLock(PD.hDevMode)
        CopyMemory DM, ByVal lpDM, Len(DM)
        lpDM = GlobalUnlock(PD.hDevMode)
        
        DialogPrint.Cancel = False
        DialogPrint.Device = Left$(DM.dmDeviceName, InStr(DM.dmDeviceName, Chr(0)) - 1)
        DialogPrint.FromPage = 0
        DialogPrint.ToPage = 0
        DialogPrint.All = True
        If PD.Flags And PD_PRINTTOFILE Then DialogPrint.File = True Else DialogPrint.File = False
        If PD.Flags And PD_COLLATE Then DialogPrint.Collate = True Else DialogPrint.Collate = False
        If PD.Flags And PD_PAGENUMS Then
            DialogPrint.Pages = True
            DialogPrint.All = False
            DialogPrint.FromPage = PD.nFromPage
            DialogPrint.ToPage = PD.nToPage
        Else
            DialogPrint.Pages = False
        End If
        If PD.Flags And PD_SELECTION Then
            DialogPrint.Selection = True
            DialogPrint.All = False
        Else
            DialogPrint.Pages = False
        End If
        
        If PD.nCopies = 1 Then
            DialogPrint.Copies = DM.dmCopies
        End If
        
        DialogPrint.DM = DM
        
    End If
    
End Function

'//
'// DialogPrintSetup Function
'//
'// Description:
'// Displays the Print Setup common dialog box.
'//
'// Syntax:
'// BOOL = DialogPrintSetup(hWnd)
'//
'// Example:
'// If DialogPrintSetup(Me.hWnd) Then
'// End If
'//

Public Function DialogPrintSetup(hWnd As Long) As Boolean

    Dim X As Long, PD As PRINTDLGSTRUC

    PD.lStructSize = Len(PD)
    PD.hWnd = hWnd
    PD.Flags = PD_PRINTSETUP
    X = PrintDlg(PD)
    
End Function