不用Common Dialog控件实现公共对话框

模块

Option Explicit

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 ChooseColorAPI Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As CHOOSECOLOR) As Long

Declare Function ChooseFont Lib "comdlg32.dll" Alias "ChooseFontA" (pChoosefont As ChooseFont) As Long

Declare Function PrintDlg Lib "comdlg32.dll" Alias "PrintDlgA" (pPrintdlg As PrintDlg) As Long

' GDI functions

Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long

Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long

Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long

Declare Function GetTextFace Lib "gdi32" Alias "GetTextFaceA" (ByVal hDC As Long, ByVal nCount As Long, ByVal lpFacename As String) As Long

' user32 functions

Declare Function GetActiveWindow Lib "user32" () As Long

Declare Function WinHelp Lib "user32" Alias "WinHelpA" (ByVal hwnd As Long, ByVal lpHelpFile As String, ByVal wCommand As Long, ByVal dwData As Long) As Long

' kernel32 functions

Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (p1 As Any, p2 As Any) As Long

Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long

Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long

Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long

Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long

Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)

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

Type CHOOSECOLOR

lStructSize As Long

hwndOwner As Long

hInstance As Long

RGBResult As Long

lpCustColors As String

flags As Long

lCustData As Long

lpfnHook As Long

lpTemplateName As String

End Type

Const LF_FACESIZE = 32

Type LOGFONT

lfHeight As Long

lfWidth As Long

lfEscapement As Long

lfOrientation As Long

lfWeight As Long

lfItalic As Byte

lfUnderline As Byte

lfStrikeOut As Byte

lfCharSet As Byte

lfOutPrecision As Byte

lfClipPrecision As Byte

lfQuality As Byte

lfPitchAndFamily As Byte

lfFaceName(LF_FACESIZE) As Byte

End Type

Type ChooseFont

lStructSize As Long

hwndOwner As Long ' caller's window handle

hDC As Long ' printer DC/IC or NULL

lpLogFont As Long ' ptr. to a LOGFONT struct

iPointSize As Long ' 10 * size in points of selected font

flags As Long ' enum. type flags

rgbColors As Long ' returned text color

lCustData As Long ' data passed to hook fn.

lpfnHook As Long ' ptr. to hook function

lpTemplateName As String ' custom template name

hInstance As Long ' instance handle of.EXE that contains cust. dlg. template

lpszStyle As String ' return the style field here must be LF_FACESIZE or bigger

nFontType As Integer ' same value reported to the EnumFonts call back with the extra FONTTYPE_ bits added

MISSING_ALIGNMENT As Integer

nSizeMin As Long ' minimum pt size allowed &

nSizeMax As Long ' max pt size allowed if CF_LIMITSIZE is used

End Type

Type PrintDlg

lStructSize As Long

hwndOwner As Long

hDevMode As Long

hDevNames As Long

hDC As Long

flags As Long

nFromPage As Integer

nToPage As Integer

nMinPage As Integer

nMaxPage As Integer

nCopies As Integer

hInstance As Long

lCustData As Long

lpfnPrintHook As Long

lpfnSetupHook As Long

lpPrintTemplateName As String

lpSetupTemplateName As String

hPrintTemplate As Long

hSetupTemplate As Long

End Type

Public Const CCHDEVICENAME = 32

Public Const CCHFORMNAME = 32

Type DEVMODE

dmDeviceName As String * CCHDEVICENAME

dmSpecVersion As Integer

dmDriverVersion As Integer

dmSize As Integer

dmDriverExtra As Integer

dmFields As Long

dmOrientation As Integer

dmPaperSize As Integer

dmPaperLength As Integer

dmPaperWidth As Integer

dmScale As Integer

dmCopies As Integer

dmDefaultSource As Integer

dmPrintQuality As Integer

dmColor As Integer

dmDuplex As Integer

dmYResolution As Integer

dmTTOption As Integer

dmCollate As Integer

dmFormName As String * CCHFORMNAME

dmUnusedPadding As Integer

dmBitsPerPel As Integer

dmPelsWidth As Long

dmPelsHeight As Long

dmDisplayFlags As Long

dmDisplayFrequency As Long

End Type

Type DEVNAMES

wDriverOffset As Integer

wDeviceOffset As Integer

wOutputOffset As Integer

wDefault As Integer

extra As String * 100

End Type

' file constants

Public Const cdlOFNAllowMultiselect = &H200

Public Const cdlOFNCreatePrompt = &H2000

Public Const cdlOFNExplorer = &H80000

Public Const cdlOFNExtensionDifferent = &H400

Public Const cdlOFNFileMustExist = &H1000

Public Const cdlOFNHelpButton = &H10

Public Const cdlOFNHideReadOnly = 4

Public Const cdlOFNLongNames = &H200000

Public Const cdlOFNNoChangeDir = 8

Public Const cdlOFNNoDereferenceLinks = &H100000

Public Const cdlOFNNoLongNames = &H40000

Public Const cdlOFNNoReadOnlyReturn = &H8000

Public Const cdlOFNNoValidate = &H100

Public Const cdlOFNOverwritePrompt = 2

Public Const cdlOFNPathMustExist = &H800

Public Const cdlOFNReadOnly = 1

Public Const cdlOFNShareAware = &H4000

' color constants

Public Const cdlCCFullOpen = 2

Public Const cdlCCHelpButton = 8

Public Const cdlCCPreventFullOpen = 4

Public Const cdlCCRGBInit = 1

' printer constants

Public Const cdlPDAllPages = 0

Public Const cdlPDCollate = &H10

Public Const cdlPDDisablePrintToFile = &H80000

Public Const cdlPDHelpButton = &H800

Public Const cdlPDHidePrintToFile = &H100000

Public Const cdlPDNoPageNums = 8

Public Const cdlPDNoSelection = 4

Public Const cdlPDNoWarning = &H80

Public Const cdlPDPageNums = 2

Public Const cdlPDPrintSetup = &H40

Public Const cdlPDPrintToFile = &H20

Public Const cdlPDReturnDC = &H100

Public Const cdlPDReturnDefault = &H400

Public Const cdlPDReturnIC = &H200

Public Const cdlPDSelection = 1

Public Const cdlPDUseDevModeCopies = &H40000

' font constants

Public Const cdlCFANSIOnly = &H400

Public Const cdlCFApply = &H200

Public Const cdlCFBoth = 3

Public Const cdlCFEffects = &H100

Public Const cdlCFFixedPitchOnly = &H4000

Public Const cdlCFForceFontExist = &H10000

Public Const cdlCFHelpButton = 4

Public Const cdlCFLimitSize = &H2000

Public Const cdlCFNoFaceSel = &H80000

Public Const cdlCFNoSimulations = &H1000

Public Const cdlCFNoSizeSel = &H200000

Public Const cdlCFNoStyleSel = &H100000

Public Const cdlCFNoVectorFonts = &H800

Public Const cdlCFPrinterFonts = &H2

Public Const cdlCFScalableOnly = &H20000

Public Const cdlCFScreenFonts = 1

Public Const cdlCFTTOnly = &H40000

Public Const cdlCFWYSIWYG = &H8000

' help constants

Public Const cdlHelpCommandHelp = &H102&

Public Const cdlHelpContents = &H3&

Public Const cdlHelpContext = &H1

Public Const cdlHelpContextPOPUP = &H8&

Public Const cdlHelpForceFile = &H9&

Public Const cdlHelpHelpOnHelp = &H4

Public Const cdlHelpIndex = &H3

Public Const cdlHelpKey = &H101

Public Const cdlHelpPartialKey = &H105&

Public Const cdlHelpQuit = &H2

Public Const cdlHelpSetContents = &H5&

Public Const cdlHelpSetIndex = &H5

' common dialog action types

Public Const ShowOpen = 1

Public Const ShowSave = 2

Public Const ShowColor = 3

Public Const ShowFont = 4

Public Const ShowPrinter = 5

Public Const ShowHelp = 6

' extra help constants

Public Const HELP_MULTIKEY = &H201&

Public Const HELP_SETWINPOS = &H203&

Public Const HELPMSGSTRING = "commdlg_help"

Public RetValue As Long

' extra font constant

Public Const CF_INITTOLOGFONTSTRUCT = &H40&

Public Const SCREEN_FONTTYPE = &H2000

Public Const BOLD_FONTTYPE = &H100

Public WYSIWYG As Variant

Public Const FW_BOLD = 700

' extra printer constants

Public Const DM_DUPLEX = &H1000&

Public Const DM_ORIENTATION = &H1&

' memory management constants

Public Const GMEM_MOVEABLE = &H2

Public Const GMEM_ZEROINIT = &H40

类模块

Option Explicit

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 Long

Private mHelpFile As String

Private mHelpCommand As Long

Private mHelpKey As String

Private mRGBResult As Long

Private mItalic As Boolean

Private mUnderline As Boolean

Private mStrikethru As Boolean

Private mFontName As String

Private mFontSize As Long

Private mBold As Boolean

Public Property Get Bold() As Boolean

Bold = mBold

End Property

Public Property Let Bold(bBold As Boolean)

mBold = bBold

End Property

Public Property Get DefaultExt() As String

DefaultExt = mDefaultExt

End Property

Public Property Let DefaultExt(sDefExt As String)

mDefaultExt = DefaultExt

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 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 flags() As Long

flags = mFlags

End Property

Public Property Let flags(lFlags As Long)

mFlags = lFlags

End Property

Public Property Get FontName() As String

FontName = mFontName

End Property

Public Property Let FontName(sName As String)

mFontName = sName

End Property

Public Property Get FontSize() As Long

FontSize = mFontSize

End Property

Public Property Let FontSize(lSize As Long)

mFontSize = lSize

End Property

Public Property Get HelpCommand() As Long

HelpCommand = mHelpCommand

End Property

Public Property Let HelpCommand(lCommand As Long)

mHelpCommand = lCommand

End Property

Public Property Get HelpFile() As String

HelpFile = mHelpFile

End Property

Public Property Let HelpFile(sFile As String)

mHelpFile = sFile

End Property

Public Property Get HelpKey() As String

HelpKey = mHelpKey

End Property

Public Property Let HelpKey(sKey As String)

mHelpKey = sKey

End Property

Public Property Get InitDir() As String

InitDir = mInitDir

End Property

Public Property Let InitDir(sDir As String)

mInitDir = sDir

End Property

Public Sub Action(mAction As Integer)

Dim OFN As OPENFILENAME

Dim CC As CHOOSECOLOR

Dim CF As ChooseFont

Dim LF As LOGFONT

Dim PD As PrintDlg

Dim DM As DEVMODE

Dim DN As DEVNAMES

Dim CustomColors() As Byte

Dim sFile As String

Dim iDelim As Integer

Dim zTemp As String

Dim Temp As Variant

Dim i As Integer

Dim TempByteArray() As Byte

Dim ByteArrayLimit As Long

Dim OldhDC As Long

Dim FontToUse As Long

Dim tbuf As String * 80

Dim X As Long

Dim lpDevMode As Long, lpDevName As Long

Dim objPrinter As Printer, NewPrinterName As String

Dim strSetting As String

Select Case mAction

Case ShowOpen, ShowSave, ShowHelp

With OFN

.lStructSize = Len(OFN)

If mhOwner = 0 Then

mhOwner = GetActiveWindow()

End If

.hwndOwner = mhOwner

.flags = mFlags

.lpstrDefExt = mDefaultExt

' set the initial directory, otherwise uses current

Temp = mInitDir

.lpstrInitialDir = Temp

' retrieve the default file name

' first check for wild cards

Temp = mFileName

.lpstrFile = Temp & String$(255 - Len(Temp), 0)

.nMaxFile = 255

.lpstrFileTitle = String$(255, 0)

.nMaxFileTitle = 255

' file type filter

' we need to replace pipes with nulls

zTemp = mFilter

For i = 1 To Len(zTemp)

If Mid(zTemp, i, 1) = "|" Then

Mid(zTemp, i, 1) = vbNullChar

End If

zTemp = zTemp & String$(2, 0)

.lpstrFilter = zTemp

.nFilterIndex = mFilterIndex

.lpstrTitle = mDialogTitle

.hInstance = App.hInstance

Select Case mAction

Case ShowOpen, ShowColor

' open file

RetValue = GetOpenFileName(OFN)

Case ShowSave

'save file

RetValue = GetSaveFileName(OFN)

Case ShowHelp

' winhelp

RetValue = WinHelp(mhOwner, mHelpFile, mHelpCommand, mHelpKey)

End Select

If RetValue > 0 Then

iDelim = InStr(.lpstrFileTitle, vbNullChar)

If iDelim > 0 Then

mFileTitle = Left$(.lpstrFileTitle, iDelim - 1)

End If

iDelim = InStr(.lpstrFile, vbNullChar)

If iDelim > 0 Then

mFileName = Left$(.lpstrFile, iDelim - 1)

End If

Else

mFileTitle = ""

'Err.Raise 0

End If

End With

Case ShowColor

ReDim CustomColors(0 To 16 * 4 - 1) As Byte

For i = LBound(CustomColors) To UBound(CustomColors)

CustomColors(i) = 255 ' white

Next i

With CC

.lStructSize = Len(CC)

If mhOwner = 0 Then

mhOwner = GetActiveWindow()

End If

.hwndOwner = mhOwner

.hInstance = App.hInstance

.lpCustColors = StrConv(CustomColors, vbUnicode)

.flags = mFlags

.RGBResult = mRGBResult

RetValue = ChooseColorAPI(CC)

If RetValue = 0 Then

mRGBResult = -1

'Err.Raise (RetValue)

Else

CustomColors = StrConv(.lpCustColors, vbFromUnicode)

mRGBResult = .RGBResult

End If

End With

Case ShowFont

With LF

TempByteArray = StrConv(mFontName & vbNullChar, vbFromUnicode)

ByteArrayLimit = UBound(TempByteArray)

For X = 0 To ByteArrayLimit

.lfFaceName(X) = TempByteArray(X)

.lfHeight = mFontSize * 1.3

.lfItalic = mItalic * -1

.lfUnderline = mUnderline * -1

.lfStrikeOut = mStrikethru * -1

If mBold = True Then

.lfWeight = FW_BOLD

End If

End With

With CF

.lStructSize = Len(CF)

If mhOwner = 0 Then

mhOwner = GetActiveWindow()

End If

.hwndOwner = mhOwner

.hDC = GetDC(mhOwner)

.lpLogFont = lstrcpy(LF, LF)

If Not mFlags Then

.flags = cdlCFScreenFonts Or cdlCFEffects

Else

.flags = cdlCFWYSIWYG Or cdlCFEffects

End If

.flags = .flags Or CF_INITTOLOGFONTSTRUCT

.rgbColors = mRGBResult

.lCustData = 0

.lpfnHook = 0

.lpTemplateName = 0

.hInstance = 0

.lpszStyle = 0

.nFontType = SCREEN_FONTTYPE

.nSizeMin = 0

.nSizeMax = 0

.iPointSize = mFontSize * 10

End With

RetValue = ChooseFont(CF)

If RetValue = 0 Then

Err.Raise (RetValue)

Else

With LF

mItalic = .lfItalic * -1

mUnderline = .lfUnderline * -1

mStrikethru = .lfStrikeOut * -1

End With

With CF

mFontSize = .iPointSize 10

mRGBResult = .rgbColors

If .nFontType And BOLD_FONTTYPE Then

mBold = True

Else

mBold = False

End If

End With

FontToUse = CreateFontIndirect(LF)

If FontToUse = 0 Then Exit Sub

OldhDC = SelectObject(CF.hDC, FontToUse)

RetValue = GetTextFace(CF.hDC, 79, tbuf)

mFontName = Mid$(tbuf, 1, RetValue)

End If

Case ShowPrinter

' Use PrintDialog to get the handle to a memory

' block with a DevMode and DevName structures

With PD

.lStructSize = Len(PD)

If mhOwner = 0 Then

mhOwner = GetActiveWindow()

End If

.hwndOwner = mhOwner

.hDC = GetDC(mhOwner)

.flags = mFlags

End With

' Set the current orientation and duplex setting

On Error GoTo ErrorHandler

With DM

.dmDeviceName = Printer.DeviceName

.dmSize = Len(DM)

.dmFields = DM_ORIENTATION Or DM_DUPLEX

.dmOrientation = Printer.Orientation

On Error Resume Next

.dmDuplex = Printer.Duplex

On Error GoTo 0

End With

' Allocate memory for the initialization hDevMode structure

' and copy the settings gathered above into this memory

PD.hDevMode = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(DM))

lpDevMode = GlobalLock(PD.hDevMode)

If lpDevMode > 0 Then

CopyMemory ByVal lpDevMode, DM, Len(DM)

RetValue = GlobalUnlock(lpDevMode)

End If

' Set the current driver, device, and port name strings

With DN

.wDriverOffset = 8

.wDeviceOffset = .wDriverOffset + 1 + Len(Printer.DriverName)

.wOutputOffset = .wDeviceOffset + 1 + Len(Printer.Port)

.wDefault = 0

End With

With Printer

DN.extra = .DriverName & vbNullChar & .DeviceName & vbNullChar & .Port & vbNullChar

End With

' Allocate memory for the initial hDevName structure

' and copy the settings gathered above into this memory

PD.hDevNames = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(DN))

lpDevName = GlobalLock(PD.hDevNames)

If lpDevName > 0 Then

CopyMemory ByVal lpDevName, DN, Len(DN)

RetValue = GlobalUnlock(lpDevName)

End If

' Call the print dialog up and let the user make changes

RetValue = PrintDlg(PD)

If RetValue = 0 Then

Err.Raise (RetValue)

Else

' get the DC for user API operations

mhOwner = PD.hDC

' get the DevName structure.

lpDevName = GlobalLock(PD.hDevNames)

CopyMemory DN, ByVal lpDevName, 45

RetValue = GlobalUnlock(lpDevName)

GlobalFree PD.hDevNames

' Next get the DevMode structure and set the printer

' properties appropriately

lpDevMode = GlobalLock(PD.hDevMode)

CopyMemory DM, ByVal lpDevMode, Len(DM)

RetValue = GlobalUnlock(PD.hDevMode)

GlobalFree PD.hDevMode

NewPrinterName = UCase$(Left(DM.dmDeviceName, InStr(DM.dmDeviceName, vbNullChar) - 1))

If Printer.DeviceName <> NewPrinterName Then

For Each objPrinter In Printers

If UCase$(objPrinter.DeviceName) = NewPrinterName Then

Set Printer = objPrinter

End If

On Error Resume Next

' Set printer object properties according to selections made

' by user

With Printer

.Copies = DM.dmCopies

.Duplex = DM.dmDuplex

.Orientation = DM.dmOrientation

End With

On Error GoTo 0

End If

End Select

ExitSub:

Exit Sub

ErrorHandler:

MsgBox Err.Description, vbExclamation, "Printer Error"

Resume ExitSub

End Sub

Public Property Get Italic() As Boolean

Italic = mItalic

End Property

Public Property Let Italic(BItalic As Boolean)

mItalic = BItalic

End Property

Public Property Get Owner() As Long

Owner = mhOwner

End Property

Public Property Let Owner(lOwner As Long)

mhOwner = lOwner

End Property

Public Property Get RGBResult() As Long

RGBResult = mRGBResult

End Property

Public Property Let RGBResult(lValue As Long)

mRGBResult = lValue

End Property

Public Property Get StrikeThru() As Boolean

StrikeThru = mStrikethru

End Property

Public Property Let StrikeThru(bStrikethru As Boolean)

mStrikethru = bStrikethru

End Property

Public Property Get Underline() As Boolean

Underline = mUnderline

End Property

Public Property Let Underline(bUnderline As Boolean)

mUnderline = bUnderline

End Property

调用方法

Dim cdlg As New CommDlg

cdlg.DialogTitle = "open file"

cdlg.Filter = "all file(*.*)|*.*"

cdlg.flags = cdlOFNFileMustExist Or cdlOFNHideReadOnly

cdlg.Action ShowOpen

If cdlg.fileName <> "" Then

'do something

End If

posted on 2004-08-29 14:24 kempsun 阅读(876) 评论(0) 收藏举报

刷新页面返回顶部

kempsun' blog

不用Common Dialog控件实现公共对话框

导航

公告