Code:
'in form1
Private Sub Command1_Click()
Dim A As ClsComDlg
Set A = New ClsComDlg
A.ShowColorFlags = cdlCCFullOpen Or cdlCCRGBInit
A.Color = vbYellow
A.ShowColor (Me.hWnd)
Me.BackColor = A.Color
End SubCode:
Option Explicit
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As CHOOSECOLORS) As Long
Private Declare Function CommDlgExtendedError Lib "comdlg32.dll" () As Long
Private Declare Function GetShortPathName Lib "KERNEL32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
Private Declare Function ChooseFont Lib "comdlg32.dll" Alias "ChooseFontA" (pChoosefont As CHOOSEFONTS) As Long
Private Declare Function PrintDlg Lib "comdlg32.dll" Alias "PrintDlgA" (pPrintdlg As PRINTDLGS) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Const LF_FACESIZE = 32
Private Type OPENFILENAME
nStructSize As Long
hwndOwner As Long
hInstance As Long
sFilter As String
sCustomFilter As String
nCustFilterSize As Long
nFilterIndex As Long
sFile As String
nFileSize As Long
sFileTitle As String
nTitleSize As Long
sInitDir As String
sDlgTitle As String
Flags As Long
nFileOffset As Integer
nFileExt As Integer
sDefFileExt As String
nCustDataSize As Long
fnHook As Long
sTemplateName As String
End Type
Private Type CHOOSECOLORS
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
Private 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
Private Type CHOOSEFONTS
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. private 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
lpszStyle As String ' return the style field here
nFontType As Integer ' same value reported to the EnumFonts
MISSING_ALIGNMENT As Integer
nSizeMin As Long ' minimum pt size allowed &
nSizeMax As Long ' max pt size allowed if
End Type
Private Const CF_INITTOLOGFONTSTRUCT = &H40&
Private Type PRINTDLGS
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 Enum FileFlags
cdlOFNAllowMultiselect = &H200
cdlOFNCreatePrompt = &H2000
cdlOFNExplorer = &H80000
cdlOFNExtensionDifferent = &H400
cdlOFNFileMustExist = &H1000
cdlOFNHelpButton = &H10
cdlOFNHideReadOnly = &H4
cdlOFNLongNames = &H200000
cdlOFNNoChangeDir = &H8
cdlOFNNoDereferenceLinks = &H100000
cdlOFNNoLongNames = &H40000
cdlOFNNoReadOnlyReturn = &H8000
cdlOFNNoValidate = &H100
cdlOFNOverwritePrompt = &H2
cdlOFNPathMustExist = &H800
cdlOFNReadOnly = &H1
cdlOFNShareAware = &H4000
End Enum
Public Enum PrintFlags
cdlPDAllPages = &H0
cdlPDCollate = &H10
cdlPDDisablePrintToFile = &H80000
cdlPDHelpButton = &H800
cdlPDHidePrintToFile = &H100000
cdlPDNoPageNums = &H8
cdlPDNoSelection = &H4
cdlPDNoWarning = &H80
cdlPDPageNums = &H2
cdlPDPrintSetup = &H40
cdlPDPrintToFile = &H20
cdlPDReturnDC = &H100
cdlPDReturnDefault = &H400
cdlPDReturnIC = &H200
cdlPDSelection = &H1
cdlPDUseDevModeCopies = &H40000
End Enum
Public Enum ColorFlags
cdlCCFullOpen = &H2
cdlCCShowHelpButton = &H8
cdlCCPreventFullOpen = &H4
cdlCCRGBInit = &H1
End Enum
Public Enum FontFlags
cdlCFANSIOnly = &H400
cdlCFApply = &H200
cdlCFBoth = &H3
cdlCFEffects = &H100
cdlCFFixedPitchOnly = &H4000
cdlCFForceFontExist = &H10000
cdlCFHelpButton = &H4
cdlCFLimitSize = &H2000
cdlCFNoFaceSel = &H80000
cdlCFNoSimulations = &H1000
cdlCFNoSizeSel = &H200000
cdlCFNoStyleSel = &H100000
cdlCFNoVectorFonts = &H800
cdlCFPrinterFonts = &H2
cdlCFScalableOnly = &H20000
cdlCFScreenFonts = &H1
cdlCFTTOnly = &H40000
cdlCFWYSIWYG = &H8000
End Enum
Private FileDialog As OPENFILENAME
Private ColorDialog As CHOOSECOLORS
Private FontDialog As CHOOSEFONTS
Private PrintDialog As PRINTDLGS
Private bCanceled As Boolean
Private tFontName As String
Private tFontBold As Boolean
Private tFontItalic As Boolean
Private tFontUnderline As Boolean
Private tFontStrike As Boolean
Private tFontSize As Long
Private tFontCharSet As Byte
Private tFontColor As Long
Public Sub ShowOpen(ByVal hWnd As Long)
Dim ret As Long
If FileDialog.sDlgTitle = "" Then FileDialog.sDlgTitle = "打开"
FileDialog.nStructSize = Len(FileDialog)
FileDialog.hwndOwner = hWnd
FileDialog.sFileTitle = Space$(2048)
FileDialog.nTitleSize = Len(FileDialog.sFileTitle)
FileDialog.sFile = FileDialog.sFile & Space$(2047) & Chr$(0)
FileDialog.nFileSize = Len(FileDialog.sFile)
ret = GetOpenFileName(FileDialog)
If ret Then
bCanceled = False
Else
bCanceled = True
End If
End Sub
Public Sub ShowSave(ByVal hWnd As Long)
Dim ret As Long
If FileDialog.sDlgTitle = "" Then FileDialog.sDlgTitle = "另存为"
FileDialog.nStructSize = Len(FileDialog)
FileDialog.hwndOwner = hWnd
FileDialog.sFileTitle = Space$(2048)
FileDialog.nTitleSize = Len(FileDialog.sFileTitle)
FileDialog.sFile = Space$(2047) & Chr$(0)
FileDialog.nFileSize = Len(FileDialog.sFile)
' If FileDialog.Flags = 0 Then
' FileDialog.Flags = OFS_FILE_SAVE_FLAGS
' End If
ret = GetSaveFileName(FileDialog)
If ret Then
bCanceled = False
Else
bCanceled = True
End If
End Sub
Public Sub ShowColor(ByVal hWnd As Long)
Dim customcolors() As Byte ' dynamic (resizable) array
Dim i As Integer
Dim ret As Long
If ColorDialog.lpCustColors = "" Then
ReDim customcolors(0 To 16 * 4 - 1) As Byte 'resize the array
For i = LBound(customcolors) To UBound(customcolors)
customcolors(i) = 254 ' sets all custom colors to white
Next i
ColorDialog.lpCustColors = StrConv(customcolors, vbUnicode) ' convert array
End If
ColorDialog.hwndOwner = hWnd
ColorDialog.lStructSize = Len(ColorDialog)
' ColorDialog.Flags = COLOR_FLAGS
ret = ChooseColor(ColorDialog)
If ret Then
bCanceled = False
Else
bCanceled = True
End If
End Sub
Public Sub ShowFont(ByVal hWnd As Long) ', ByVal startingFontName As String)
Dim ret As Long
Dim lfLogFont As LOGFONT
Dim i As Integer
FontDialog.nSizeMax = 0
FontDialog.nSizeMin = 0
FontDialog.nFontType = Screen.FontCount
FontDialog.hwndOwner = hWnd
FontDialog.hDC = 0
FontDialog.lpfnHook = 0
FontDialog.lCustData = 0
FontDialog.lpLogFont = VarPtr(lfLogFont)
If FontDialog.iPointSize = 0 Then
FontDialog.iPointSize = 10 * 10
End If
FontDialog.lpTemplateName = Space$(2048)
FontDialog.rgbColors = RGB(0, 255, 255)
FontDialog.lStructSize = Len(FontDialog)
If FontDialog.Flags = 0 Then
FontDialog.Flags = FontFlags.cdlCFScreenFonts Or FontFlags.cdlCFEffects Or CF_INITTOLOGFONTSTRUCT
End If
For i = 0 To Len(tFontName) - 1
lfLogFont.lfFaceName(i) = Asc(Mid(tFontName, i + 1, 1))
Next
ret = ChooseFont(FontDialog)
If ret Then
bCanceled = False
tFontBold = IIf(lfLogFont.lfWeight > 400, True, False)
tFontItalic = lfLogFont.lfItalic
tFontStrike = lfLogFont.lfStrikeOut
tFontUnderline = lfLogFont.lfUnderline
tFontColor = FontDialog.rgbColors
tFontCharSet = lfLogFont.lfCharSet
tFontSize = FontDialog.iPointSize / 10
tFontName = ""
' For i = 0 To UBound(lfLogFont.lfFaceName)
' tFontName = tFontName + Chr(lfLogFont.lfFaceName(i))
' Next
tFontName = StrConv(lfLogFont.lfFaceName, vbUnicode)
tFontName = Mid(tFontName, 1, InStr(1, tFontName, Chr(0)) - 1)
Else
bCanceled = True
End If
End Sub
Public Sub ShowPrinter(ByVal hWnd As Long)
PrintDialog.hwndOwner = hWnd
PrintDialog.lStructSize = Len(PrintDialog)
Call PrintDlg(PrintDialog)
End Sub
Public Property Get FileName() As String
Dim s As String
Dim charAsc As Long
Dim i As Long
On Error GoTo ErrEnd
s = Trim(Left(FileDialog.sFile, Len(FileDialog.sFile) - 1))
If Len(s) = 0 Then Exit Property
i = 1
Do Until charAsc <> 0
charAsc = Asc(Mid(s, Len(s) - i, 1))
i = i + 1
Loop
s = Left(s, Len(s) - i + 1)
FileName = s
ErrEnd:
End Property
Public Property Get InitDir() As String
InitDir = FileDialog.sInitDir
End Property
Public Property Let InitDir(ByVal vNewValue As String)
FileDialog.sInitDir = vNewValue
End Property
Public Property Get Filter() As String
Filter = FileDialog.sFilter
End Property
Public Property Let Filter(ByVal vNewValue As String)
FileDialog.sFilter = Replace(vNewValue, "|", Chr(0))
End Property
Public Property Get ShowOpenFlags() As FileFlags
ShowOpenFlags = FileDialog.Flags
End Property
Public Property Let ShowOpenFlags(ByVal vNewValue As FileFlags)
FileDialog.Flags = vNewValue
End Property
Public Property Get ShowSaveFlags() As FileFlags
ShowSaveFlags = FileDialog.Flags
End Property
Public Property Let ShowSaveFlags(ByVal vNewValue As FileFlags)
FileDialog.Flags = vNewValue
End Property
Public Property Get ShowColorFlags() As ColorFlags
ShowColorFlags = ColorDialog.Flags
End Property
Public Property Let ShowColorFlags(ByVal vNewValue As ColorFlags)
ColorDialog.Flags = vNewValue
End Property
Public Property Get ShowPrintFlags() As PrintFlags
ShowPrintFlags = PrintDialog.Flags
End Property
Public Property Let ShowPrintFlags(ByVal vNewValue As PrintFlags)
PrintDialog.Flags = vNewValue
End Property
Public Property Get ShowFontFlags() As FontFlags
ShowFontFlags = FontDialog.Flags
End Property
Public Property Let ShowFontFlags(ByVal vNewValue As FontFlags)
FontDialog.Flags = vNewValue
End Property
Public Property Get DialogTitle() As String
DialogTitle = FileDialog.sDlgTitle
End Property
Public Property Let DialogTitle(ByVal vNewValue As String)
FileDialog.sDlgTitle = vNewValue
End Property
Public Property Get Cancel() As Boolean
Cancel = bCanceled
End Property
Public Property Get FontName() As String
FontName = tFontName
End Property
Public Property Let FontName(ByVal vNewValue As String)
tFontName = vNewValue
End Property
Public Property Get FontBold() As Boolean
FontBold = tFontBold
End Property
Public Property Get FontItalic() As Boolean
FontItalic = tFontItalic
End Property
Public Property Get FontCharSet() As Byte
FontCharSet = tFontCharSet
End Property
Public Property Get FontUnderline() As Boolean
FontUnderline = tFontUnderline
End Property
Public Property Get FontStrike() As Boolean
FontStrike = tFontStrike
End Property
Public Property Get FontSize() As Long
FontSize = tFontSize
End Property
Public Property Get FontColor() As Long
FontColor = tFontColor
End Property
Public Property Get Color() As Long
Color = ColorDialog.rgbResult
End Property
Public Property Let Color(ByVal vNewValue As Long) '
ColorDialog.rgbResult = vNewValue
End Property