求救：CHOOSEFONT怎么得到字体、字形、SIZE、效果、字符集的值？

Question

以下代码如果步行0自己改改吧！！！！！！Public Sub Action(mAction As Integer)
Dim OFN As OPENFILENAME, CC As CHOOSECOLOR, CF As ChooseFont, LF As LOGFONT
Dim PD As PrintDlg, DM As DEVMODE, DN As DEVNAMES
    Dim CustomColors() As Byte, TempByteArray() As Byte
    Dim sFile As String, zTemp As String, strSetting As String, tBuf As String * 80
    Dim i As Integer, iDelim As Integer
    Dim Temp As Variant
    Dim x As Long, ByteArrayLimit As Long, OldhDC As Long, FontToUse As Long
    Dim lpDevMode As Long, lpDevName As Long
    Dim objPrinter As Printer, NewPrinterName 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
                Next
                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
                    'MsgBox "ERROR"
                    Exit Sub
                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)
                                                     ' vbUnicode 根据系统的缺省码页将字符串转成 Unicode
                .flags = mFlags
                .RGBResult = mRGBResult
                RetValue = ChooseColorAPI(CC)
                If RetValue = 0 Then
                    'Err.Raise (RetValue)
                Else
                    CustomColors = StrConv(.lpCustColors, vbFromUnicode)
                                                         'vbFromUnicode 将字符串由 Unicode 转成系统的缺省码页
                    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)
                Next
                .lfHeight = mFontSize * 1.334 '* 1.333
                .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)
                'Debug.Print "OK"
                Exit Sub
            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
        '————————————————————————————————————————————————

Answer 1

'续    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
                    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
    End Select
ExitSub:
    Exit Sub
ErrorHandler:
    MsgBox Err.Description, vbExclamation, "Printer Error"
    Resume ExitSub
End Sub