comdlg.bas

这是用Vb编写的虚拟驱动程序,希望对大家有帮助.

Private Const CC_NONE = 0
Private Const CC_PIE = 2
Private Const CC_PREVENTFULLOPEN = &H4
Private Const CC_RGBINIT = &H1
Private Const CC_ROUNDRECT = 256 '
Private Const CC_SHOWHELP = &H8
Private Const CC_SOLIDCOLOR = &H80
Private Const CC_STYLED = 32
Private Const CC_WIDE = 16
Private Const CC_WIDESTYLED = 64
Private Const CCERR_CHOOSECOLORCODES = &H5000
Private Const LOGPIXELSY = 90
Private Const CCHDEVICENAME = 32
Private Const CCHFORMNAME = 32
Private Const SIMULATED_FONTTYPE = &H8000
Private Const PRINTER_FONTTYPE = &H4000
Private Const SCREEN_FONTTYPE = &H2000
Private Const BOLD_FONTTYPE = &H100
Private Const ITALIC_FONTTYPE = &H200
Private Const REGULAR_FONTTYPE = &H400
Private Const WM_CHOOSEFONT_GETLOGFONT = (&H400 + 1)
Private Const LBSELCHSTRING = "commdlg_LBSelChangedNotify"
Private Const SHAREVISTRING = "commdlg_ShareViolation"
Private Const FILEOKSTRING = "commdlg_FileNameOK"
Private Const COLOROKSTRING = "commdlg_ColorOK"
Private Const SETRGBSTRING = "commdlg_SetRGBColor"
Private Const FINDMSGSTRING = "commdlg_FindReplace"
Private Const HELPMSGSTRING = "commdlg_help"
Private Const CD_LBSELNOITEMS = -1
Private Const CD_LBSELCHANGE = 0
Private Const CD_LBSELSUB = 1
Private Const CD_LBSELADD = 2
Private Const NOERROR = 0
Private Const CSIDL_DESKTOP = &H0
Private Const CSIDL_PROGRAMS = &H2
Private Const CSIDL_CONTROLS = &H3
Private Const CSIDL_PRINTERS = &H4
Private Const CSIDL_PERSONAL = &H5
Private Const CSIDL_FAVORITES = &H6
Private Const CSIDL_STARTUP = &H7
Private Const CSIDL_RECENT = &H8
Private Const CSIDL_SENDTO = &H9
Private Const CSIDL_BITBUCKET = &HA
Private Const CSIDL_STARTMENU = &HB
Private Const CSIDL_DESKTOPDIRECTORY = &H10
Private Const CSIDL_DRIVES = &H11
Private Const CSIDL_NETWORK = &H12
Private Const CSIDL_NETHOOD = &H13
Private Const CSIDL_FONTS = &H14
Private Const CSIDL_TEMPLATES = &H15
Private Const BIF_RETURNONLYFSDIRS = &H1
Private Const BIF_DONTGOBELOWDOMAIN = &H2
Private Const BIF_STATUSTEXT = &H4
Private Const BIF_RETURNFSANCESTORS = &H8
Private Const BIF_BROWSEFORCOMPUTER = &H1000
Private Const BIF_BROWSEFORPRINTER = &H2000
Private Const HWND_BROADCAST = &HFFFF&
Private Const WM_WININICHANGE = &H1A

Public Sub SetDefaultPrinter(objPrn As Printer)

    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 Sub
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
Public Sub ResetDefaultPrinter(szBuf As String)

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

End Sub
'Dialoge Folder
Public Function BrowseFolder(f As Form, szDialogTitle As String) As String

    Dim x As Long, BI As BROWSEINFO, dwIList As Long, szPath As String, wPos As Integer
    
    BI.hOwner = f.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
'Dialoge Printer
Public Function DialogConnectToPrinter(f As Form) As Boolean

    Dim x As Long
    DialogConnectToPrinter = True
    x = ConnectToPrinterDlg(f.hwnd, 0)
    
End Function
'Convert Byte Into String
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
'Dialoge Color Chooser
Public Function DialogColor(f As Form, c As Control) As Boolean

    Dim x As Long, CS As COLORSTRUC, CustColor(16) As Long
    
    CS.lStructSize = Len(CS)
    CS.hwnd = f.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
'Dialoge File Browser
Public Function DialogFile(f As Form, szDialogTitle As String, szFilename As String, szFilter As String, szDefDir As String, szDefExt As String, Optional wMode As Integer = 2) As String

    Dim x As Long, OFN As OPENFILENAME, szFile As String, szFileTitle As String
    
    OFN.lStructSize = Len(OFN)
    OFN.hwnd = f.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 (.)
        '// SendMsg "File Name is " & szFileTitle & Chr$(13) & Chr$(10) & "Full path and file is " & szFile, , "Open"
        
        '// DialogFile = szFile & "|" & szFileTitle
        DialogFile = szFile
    
    Else
    
        DialogFile = ""
        
    End If
    
End Function
'Dialoge Font Chooser
Public Function DialogFont(f As Form, c As Control) As Boolean

    Dim LF As LOGFONT, FS As FONTSTRUC
    Dim lLogFontAddress As Long, lMemHandle As Long
    
    If c.FontBold Then LF.lfWeight = FW_BOLD
    If c.FontItalic = True Then LF.lfItalic = 1
    If c.FontUnderline = True Then LF.lfUnderline = 1
    If c.FontStrikethru = True Then LF.lfStrikeOut = 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.FontSize * 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.FontBold = True
        Else
            c.FontBold = False
        End If
                        
        If LF.lfItalic = 1 Then
            c.FontItalic = True
        Else
            c.FontItalic = False
        End If
            
        If LF.lfUnderline = 1 Then
            c.FontUnderline = True
        Else
            c.FontUnderline = False
        End If
        
        If LF.lfStrikeOut = 1 Then
            c.FontStrikethru = True
        Else
            c.FontStrikethru = False
        End If
            
        c.FontName = ByteToString(LF.lfFaceName())
        c.FontSize = CLng(FS.iPointSize / 10)
        
        DialogFont = True
            
    Else
    
        DialogFont = False
            
    End If
    
End Function
'Dialoge Print
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)
        
        If PD.Flags And PD_PRINTTOFILE Then DialogPrint.ToFile = True Else DialogPrint.ToFile = False
        
        If PD.Flags And PD_PAGENUMS Then
            DialogPrint.Range = ppRangePages
            DialogPrint.FromPage = PD.nFromPage
            DialogPrint.ToPage = PD.nToPage
        ElseIf PD.Flags And PD_SELECTION Then
            DialogPrint.Range = ppRangeSelection
            DialogPrint.FromPage = 0
            DialogPrint.ToPage = 0
        Else
            DialogPrint.Range = ppRangeAll
            DialogPrint.FromPage = 0
            DialogPrint.ToPage = 0
        End If
        
        If PD.nCopies = 1 Then
            DialogPrint.Copies = DM.dmCopies
        End If
        
    End If
    
End Function
'Dialoge Print Setup
Public Function DialogPrintSetup(f As Form)

    Dim x As Long, PD As PRINTDLGSTRUC

    PD.lStructSize = Len(PD)
    PD.hwnd = f.hwnd
    PD.Flags = PD_PRINTSETUP
    x = PrintDlg(PD)
    
End Function