Текст Класса:

Private Type BROWSEINFO ' Folder Dialog

hOwner As Long

pidlRoot As Long

pszDisplayName As String

lpszTitle As String

ulFlags As Long

lpfn As Long

lParam As Long

IImage As Long

End Type

Private Type OPENFILENAME 'Open & Save Dialog

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

Private Type CHOOSECOLOR 'Color Dialog

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 'Font Dialog

Private Type LOGFONT 'Font Dialog

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 ChooseFont 'Font Dialog

lStructSize As Long

hwndOwner As Long

hdc As Long

lpLogFont As Long

IPointSize As Long

flags As Long

rgbColors As Long

lCustData As Long

lpfnHook As Long

lpTemplateName As String

hInstance As Long

lpszStyle As String

nFontType As Integer

MISSING_ALIGNMENT As Integer

nSizeMin As Long

nSizeMax As Long

End Type

' extra font constant

Const CF_INITTOLOGFONTSTRUCT = &H40&

Const SCREEN_FONTTYPE = &H2000

Const BOLD_FONTTYPE = &H100

Const FW_BOLD = 700

Private Type PrintDlg 'PrintDialog

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

Const CCHDEVICENAME = 32 'PrintDialog

Const CCHFORMNAME = 32 'PrintDialog

Private Type DEVMODE 'PrintDialog

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

Private Type DEVNAMES 'PrintDialog

wDriverOffset As Integer

wDeviceOffset As Integer

wOutputOffset As Integer

wDefault As Integer

extra As String * 100

End Type

'extra printer constants - for Printer Dialog

Const DM_DUPLEX = &H1000&

Const DM_ORIENTATION = &H1&

' memory management constants - for Printer Dialog

Const GMEM_MOVEABLE = &H2

Const GMEM_ZEROINIT = &H40

' ------------- Dialog calling functions

' -------------- Standard

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

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

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

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

' ------------- Extended

Private Declare Function SHShutDownDialog Lib "shell32" Alias "#60" (ByVal YourGuess As Long) As Long

Private Declare Function SHRestartSystem Lib "shell32" Alias "#59" (ByVal hOwner As Long, ByVal sPrompt As String, ByVal uFlags As Long) As Long

Private Declare Function SHRunDialog Lib "shell32" Alias "#61" (ByVal hOwner As Long, ByVal hIcon As Long, ByVal sDir As Long, ByVal szTitle As String, ByVal szPrompt As String, ByVal uFlags As Long) As Long

Private Declare Function SHFormatDrive Lib "shell32" (ByVal hwndOwner As Long, ByVal iDrive As Long, ByVal iCapacity As Long, ByVal iFormatType As Long) As Long

Private Declare Function SHBrowseForFolder Lib "shell32" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Private Declare Function SHChangeIconDialog Lib "shell32" Alias "#62" (ByVal hOwner As Long, ByVal szFilename As String, ByVal Reserved As Long, lpIconIndex As Long) As Long

'Private Declare Function SHFindFiles Lib "Shell32" Alias "#90" (ByVal pidlRoot As Long, ByVal pidlSavedSearchas As Long) As Boolean

Private Declare Function SHObjectProperties Lib "shell32" Alias "#178" (ByVal hOwner As Long, ByVal uFlags As Long, ByVal sName As String, ByVal sParam As String) As Long

'Private Declare Function GetFileNameFromBrowse Lib "shell32" Alias "#63" (ByVal hWndOwner As Long, ByVal sFile As String, ByVal nMaxFile As Long, ByVal sInitDir As String, ByVal sDefExt As String, ByVal sFilter As String, ByVal sTitle As String) As Boolean

Private Declare Function SHAbout Lib "shell32" Alias "ShellAboutA" (ByVal hOwner As Long, ByVal sAppName As String, ByVal sPrompt As String, ByVal hIcon As Long) As Long

' -------------- Extra functions for FolderDialog

Private Declare Function SHSimpleIDListFromPath Lib "shell32" Alias "#162" (ByVal szPath As String) As Long

Private Declare Function SHGetPathFromIDList Lib "shell32" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long

Private Declare Function SHFree Lib "shell32" Alias "#196" ()

Private Declare Function ILFree Lib "shell32" Alias "#195" (ByVal pidlFree As Long)

Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal pv As Long)

' -------------- Extra functions for IconDialog

Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long

Private Declare Function CopyIcon Lib "user32" (ByVal hIcon As Long) As Long

Private Declare Function ExtractIconEx Lib "shell32" Alias "ExtractIconExA" (ByVal lpszFile As String, ByVal nIconIndex As Long, phiconLarge As Long, phiconSmall As Long, ByVal nIcons As Long) As Long

' GDI functions

' For Font Dialog

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

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

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

' For Font and Printer Dialog

Private Declare Function GetDC Lib "user32" (ByVal hOwner As Long) As Long

' user32 functions

'Private Declare Function GetActiveWindow Lib "user32" () As Long

' kernel32 functions

' For Font Dialog

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

' For Printer Dialog

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

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

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

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

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

' common dialog action types

'Const ShowOpen = 1

'Const ShowSave = 2

'Const ShowColor = 3

'Const ShowFont = 4

'Const ShowPrinter = 5

'Const ShowHelp = 6

' --------------- Enum Flags

Public Enum CdlgExt_Flags

' Open & Save Dialog

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

'Color Dialog

cdlCCFullOpen = &H2

cdlCCHelpButton = &H8

cdlCCPreventFullOpen = &H4

cdlCCRGBInit = &H1

' Printer Dialog

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

' Font Dialog

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

' Other Dialog

'Restart Dialog

Restart_Logoff = &H0

Restart_ShutDown = &H1

Restart_Reboot = &H2

Restart_Force = &H4

' Run Dialog

Run_NoBrowse = &H10

Run_NoDefault = &H20

Run_CalcDir = &H40

Run_NoLable = &H80

' Properties Dialog

ObjProp_Printer = &H100

ObjProp_File = &H200

ObjProp_System = &H400

ObjProp_RecBin = &H700

ObjProp_Screen = &H800

' Browse for Folder Dialog

Folder_COMPUTER = &H1000

Folder_PRINTER = &H2000

Folder_INCLUDEFILES = &H4001

End Enum

'Enum Help Commands

Public Enum CdlgExt_HelpCommand

HelpCommandHelp = &H102&

HelpContents = &H3&

HelpContext = &H1

HelpContextPOPUP = &H8&

HelpForceFile = &H9&

HelpHelpOnHelp = &H4

HelpIndex = &H3

HelpKeyHelp = &H101

HelpPartialKey = &H105&

HelpQuit = &H2

HelpSetContents = &H5&

HelpSetIndex = &H5

HelpMultiKey = &H201&

HelpSetWinPos = &H203&

End Enum

Private RetValue As Long 'General

Const MAX_PATH = 260 'General

Private OFN As OPENFILENAME ' Open & Save Dialog

'Внутренние переменные для свойств:

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 mHelpFile As String

Private mHelpCommand As CdlgExt_HelpCommand

Private mHelpKey As Long

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

Private mDialogPrompt As String

Private mFlags As CdlgExt_Flags

Private mCancelError As Boolean

Private mhIcon As Long

Private mAppName As String

' Let/Get Properties: General

Public Property Let CancelError(ByVal vData As Boolean)

mCancelError = vData

End Property

Public Property Get CancelError() As Boolean

CancelError = mCancelError

End Property

Public Property Get hOwner() As Long

hOwner = mhOwner

End Property

Public Property Let hOwner(ByVal New_hOwner As Long)

mhOwner = New_hOwner

End Property

Public Property Get flags() As CdlgExt_Flags

flags = mFlags

End Property

Public Property Let flags(ByVal New_Flags As CdlgExt_Flags)

mFlags = New_Flags

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 DialogPrompt() As String

DialogPrompt = mDialogPrompt

End Property

Public Property Let DialogPrompt(ByVal New_Prompt As String)

mDialogPrompt = New_Prompt

End Property

Public Property Get AppName() As String

AppName = mAppName

End Property

Public Property Let AppName(ByVal New_AppName As String)

mAppName = New_AppName

End Property

Public Property Let hIcon(ByVal vData As Long)

mhIcon = vData

End Property

Public Property Get hIcon() As Long

hIcon = mhIcon

End Property

' Font Properties

Public Property Get Bold() As Boolean

Bold = mBold

End Property

Public Property Let Bold(bBold As Boolean)

mBold = bBold

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 Italic() As Boolean

Italic = mItalic

End Property

Public Property Let Italic(BItalic As Boolean)

mItalic = BItalic

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

' Open , Save, Folder, Icon

Public Property Get DefaultExt() As String

DefaultExt = mDefaultExt

End Property

Public Property Let DefaultExt(sDefExt As String)

mDefaultExt = DefaultExt

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 InitDir() As String

InitDir = mInitDir

End Property

Public Property Let InitDir(sDir As String)

mInitDir = sDir

End Property

' Help Properties

Public Property Get HelpCommand() As CdlgExt_HelpCommand

HelpCommand = mHelpCommand

End Property

Public Property Let HelpCommand(lCommand As CdlgExt_HelpCommand)

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 Long

HelpKey = mHelpKey

End Property

Public Property Let HelpKey(sKey As Long)

mHelpKey = sKey

End Property

'Color Dialog

Public Property Get RGBResult() As Long

RGBResult = mRGBResult

End Property

Public Property Let RGBResult(lValue As Long)

mRGBResult = lValue

End Property

' ShutDown Dialog

Public Function ShowShutDown()

SHShutDownDialog mhOwner

End Function

' Restart Dialog

Public Function ShowRestart()

Dim uFlag As Long

uFlag = mFlags And (&H0 Or &H1 Or &H2 Or &H4)

SHRestartSystem mhOwner, mDialogPrompt, uFlag

End Function

' Run Dialog

Public Function ShowRun(Optional ByVal hIcon As Long)

Dim uFlag As Long

uFlag = mFlags And (&H10 Or &H20 Or &H40 Or &H80)

uFlag = uFlag / 16

SHRunDialog mhOwner, mhIcon, 0, mDialogTitle, mDialogPrompt, uFlag

End Function

' FormatFloppy Dialog

Public Function ShowFormat(Optional ByVal iDrive As Long, Optional ByVal iCapacity As Long, Optional ByVal iFormatType As Long) As Long

ShowFormat = SHFormatDrive(mhOwner, iDrive, iCapacity, iFormatType)

End Function

' SelectIcon Dialog

Public Function ShowIcon(Optional ByVal LargeIcon As Boolean)

Dim nIconIdx As Long, OldFileName As String

Dim hSmallIcon As Long, hLargeIcon As Long, NewIcon As Long

If Right(mFileName, 1) = "\" Then Exit Function

OldFileName = mFileName

mFileName = mFileName & String$(MAX_PATH - Len(mFileName), 0) 'FileName must be maximum lenth

If SHChangeIconDialog(0, mFileName, 0, nIconIdx) Then

If ExtractIconEx(mFileName, nIconIdx, hLargeIcon, hSmallIcon, 1) > 0 Then

NewIcon = IIf(LargeIcon, LargeIcon, hSmallIcon)

mhIcon = CopyIcon(NewIcon)

DestroyIcon hSmallIcon

DestroyIcon hLargeIcon

End If

End If

mFileName = OldFileName

End Function

'SelectFolder Dialog

Public Function ShowFolder(Optional ByVal TopFolder As String) As String

Dim bi As BROWSEINFO

Dim pidl As Long, path As String, pos As Integer, uFlag As Long

TopFolder = TopFolder & Chr$(0)

bi.hOwner = mhOwner

bi.pidlRoot = SHSimpleIDListFromPath(TopFolder) 'Translate String (Path) to pointer (pidl)

bi.lpszTitle = mDialogPrompt

uFlag = mFlags And (&H1000 Or &H2000 Or &H4001)

If uFlag < Folder_COMPUTER Then

bi.ulFlags = &H1

Else

bi.ulFlags = uFlag

End If

pidl = SHBrowseForFolder(bi) ' Get pidl for selected folder

path = String$(MAX_PATH, 0)

' translate pidl to Path

If SHGetPathFromIDList(ByVal pidl, ByVal path) Then

pos = InStr(path, Chr$(0))

InitDir = Left(path, pos - 1)

End If

Call CoTaskMemFree(pidl) ' Free Memory

End Function

' ObjectProp Dialog

Public Function ShowObjectProp(Optional ByVal sObjectName As String, Optional ByVal sTab As String)

Dim uFlag As Long, sObj As String

Dim pidl As Long, sPath As String

uFlag = mFlags And (&H100 Or &H200 Or &H400 Or &H700 Or &H800)

uFlag = uFlag / 256

Select Case uFlag

Case 1, 2

sObj = sObjectName 'File or Printer selected

Case 7

uFlag = 2

sObj = "c:\recycled"

Case 8

uFlag = 0 'Screen Selected

Call Shell("rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,0", vbNormalFocus)

Case Else ' In all other cases show system properties

uFlag = 2

sObj = ""

End Select

If uFlag > 0 Then SHObjectProperties mhOwner, uFlag, sObj, sTab

End Function

'About Dialog

Public Function ShowAbout()

If mAppName = "" Then mAppName = Chr$(0)

SHAbout mhOwner, mAppName, mDialogPrompt, mhIcon

End Function

' Standard Dialogs

Public Sub ShowOpen()

Dim iDelim As Integer

InitOFN

RetValue = GetOpenFileName(OFN)

If RetValue > 0 Then

iDelim = InStr(OFN.lpstrFileTitle, vbNullChar)

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

iDelim = InStr(OFN.lpstrFile, vbNullChar)

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

Else

If mCancelError Then Err.Raise 0

End If

End Sub

Public Sub ShowSave()

Dim iDelim As Integer

InitOFN

RetValue = GetSaveFileName(OFN)

If RetValue > 0 Then

iDelim = InStr(OFN.lpstrFileTitle, vbNullChar)

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

iDelim = InStr(OFN.lpstrFile, vbNullChar)

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

Else

If mCancelError Then Err.Raise 0

End If

End Sub

Private Sub InitOFN()

Dim sTemp As String, i As Integer

Dim uFlag As Long

uFlag = mFlags And (&H1 Or &H2 Or &H4 Or &H8 Or &H10 Or &H100 Or &H200 Or &H400 Or &H800 Or &H1000 Or &H2000 Or &H4000 Or &H8000 Or &H40000 Or &H80000 Or &H100000 Or &H200000)

With OFN

.lStructSize = Len(OFN)

.hwndOwner = mhOwner

.flags = uFlag

.lpstrDefExt = mDefaultExt

sTemp = mInitDir

If sTemp = "" Then sTemp = App.path

.lpstrInitialDir = sTemp

sTemp = mFileName

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

.nMaxFile = 255

.lpstrFileTitle = String$(255, 0)

.nMaxFileTitle = 255

sTemp = mFilter

For i = 1 To Len(sTemp)

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

Mid(sTemp, i, 1) = vbNullChar

End If

Next

sTemp = sTemp & String$(2, 0)

.lpstrFilter = sTemp

.nFilterIndex = mFilterIndex

.lpstrTitle = mDialogTitle

.hInstance = App.hInstance

End With

End Sub

Public Sub ShowHelp()

mHelpKey = &H101

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

End Sub

Public Sub ShowColor()

Dim CC As CHOOSECOLOR

Dim CustomColors() As Byte

Dim uFlag As Long

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

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

CustomColors(i) = 255 ' white

Next i

uFlag = mFlags And (&H1 Or &H2 Or &H4 Or &H8)

With CC

.lStructSize = Len(CC)

.hwndOwner = mhOwner

.hInstance = App.hInstance

.lpCustColors = StrConv(CustomColors, vbUnicode)

.flags = uFlag

.RGBResult = mRGBResult

RetValue = ChooseColorAPI(CC)

If RetValue = 0 Then

If mCancelError Then Err.Raise (RetValue)

Else

CustomColors = StrConv(.lpCustColors, vbFromUnicode)

mRGBResult = .RGBResult

End If

End With

End Sub

Public Sub ShowFont()

Dim CF As ChooseFont

Dim LF As LOGFONT

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 uFlag As Long

uFlag = mFlags And (&H1 Or &H2 Or &H3 Or &H4 Or &H100 Or &H200 Or &H400 Or &H800 Or &H1000 Or &H2000 Or &H4000 Or &H8000 Or &H10000 Or &H20000 Or &H40000 Or &H80000 Or &H100000 Or &H200000)

TempByteArray = StrConv(mFontName & vbNullChar, vbFromUnicode)

ByteArrayLimit = UBound(TempByteArray)

With LF

For X = 0 To ByteArrayLimit

.lfFaceName(X) = TempByteArray(X)

Next

.lfHeight = mFontSize * 1.3

.lfItalic = mItalic * -1

.lfUnderline = mUnderline * -1

.lfStrikeOut = mStrikethru * -1

If mBold Then .lfWeight = FW_BOLD

End With

With CF

.lStructSize = Len(CF)

.hwndOwner = mhOwner

.hdc = GetDC(mhOwner)

.lpLogFont = lstrcpy(LF, LF)

If Not uFlag Then

.flags = cdlCFScreenFonts

Else

.flags = uFlag Or cdlCFWYSIWYG

End If

.flags = .flags Or cdlCFEffects 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

If mCancelError 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

End Sub

Public Sub ShowPrinter()

Dim PD As PrintDlg

Dim DM As DEVMODE

Dim DN As DEVNAMES

Dim lpDevMode As Long, lpDevName As Long

Dim objPrinter As Printer, NewPrinterName As String

Dim strSetting As String

Dim uFlag As Long

uFlag = mFlags And (&H0 Or &H1 Or &H2 Or &H4 Or &H8 Or &H10 Or &H20 Or &H40 Or &H80 Or &H100 Or &H200 Or &H400 Or &H800 Or &H40000 Or &H80000 Or &H100000)

' Use PrintDialog to get the handle to a memory

' block with a DevMode and DevName structures

With PD

.lStructSize = Len(PD)

.hwndOwner = mhOwner

.hdc = GetDC(mhOwner)

.flags = uFlag

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

If mCancelError 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

Next

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

ExitSub:

Exit Sub

ErrorHandler:

MsgBox Err.Description, vbExclamation, "Printer Error"

Resume ExitSub

End Sub