commdlgs.bas

文件传送

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()
'//


'// 用法示例:
'// 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)
'//


'// 用法示例:
'// 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)
'//

'// 用法示例:
'// 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
'//
'// 用法示例:
'// DialogConnectToPrinter
'//

Public Function DialogConnectToPrinter() As Boolean

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


'数组转string
'效果并不好.因为它是一个字节一个字节的读进数组里,而非用copymemory整块复制进去,所以速度很慢
'如果要用数组转成string变量可以参照我的文章:
'http://digest.tencent.com/cgi-bin/wenji_content?id=161832
'以及string变量转数组的:
'http://digest.tencent.com/cgi-bin/wenji_content?id=168362


'//
'// 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)
'//
'// 用法示例:
'// 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



'打开/保存文件对话框
'通过设置 wMode这个变量为1或是为0即可设置为打开/保存对话框
'//
'// DialogFile Function
'//
'// Description:
'// Displays the File Open/Save As common dialog boxes.
'//
'// Syntax:
'// StrVar = DialogFile(hWnd, IntVar, StrVar, StrVar, StrVar, StrVar, StrVar)
'//
'// 用法示例:
'// szFilename = DialogFile(Me.hWnd, 1, "Open", "MyFileName.doc", "Documents" & Chr(0) & "*.doc" & Chr(0) & "All files" & Chr(0) & "*.*", App.Path, "doc")
'//
'// 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.


'hwnd不必管它,写Me.hwnd即可
'szDialogTitle为对话框标题
'szFilename为显示在对话框里的默认打开/保存文件名
'szFilter为文件扩展名
'szDefDir为默认的查找文件的路径
'szDefExt为当保存的文件无指定扩展名时.默认的扩展名


Public Function DialogFile(hwnd As Long, wMode As Integer, szDialogTitle As String, szFilename As String, szFilter As String, szDefDir As String, szDefExt 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_PATHMUSTEXIST  'Or OFN_OVERWRITEPROMPT
        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
    
    Else
    
        DialogFile = ""
        
    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)
'//
'// 用法示例:
'// 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


'打印
'//
'// 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)
'//
'// 用法示例:
'// 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)
'//
'// 用法示例:
'// 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