怎么用CreateFont函数创建加粗的字体
在CreateFont函数里面没有加粗这个选项，而如果用Height，Width又改变了字的大小，怎么做？？
[解决办法]
Option Explicit'Example Name:Create Font'used with fnWeightConst FW_DONTCARE = 0Const FW_THIN = 100Const FW_EXTRALIGHT = 200Const FW_LIGHT = 300Const FW_NORMAL = 400Const FW_MEDIUM = 500Const FW_SEMIBOLD = 600Const FW_BOLD = 700Const FW_EXTRABOLD = 800Const FW_HEAVY = 900Const FW_BLACK = FW_HEAVYConst FW_DEMIBOLD = FW_SEMIBOLDConst FW_REGULAR = FW_NORMALConst FW_ULTRABOLD = FW_EXTRABOLDConst FW_ULTRALIGHT = FW_EXTRALIGHT'used with fdwCharSetConst ANSI_CHARSET = 0Const DEFAULT_CHARSET = 1Const SYMBOL_CHARSET = 2Const SHIFTJIS_CHARSET = 128Const HANGEUL_CHARSET = 129Const CHINESEBIG5_CHARSET = 136Const OEM_CHARSET = 255'used with fdwOutputPrecisionConst OUT_CHARACTER_PRECIS = 2Const OUT_DEFAULT_PRECIS = 0Const OUT_DEVICE_PRECIS = 5'used with fdwClipPrecisionConst CLIP_DEFAULT_PRECIS = 0Const CLIP_CHARACTER_PRECIS = 1Const CLIP_STROKE_PRECIS = 2'used with fdwQualityConst DEFAULT_QUALITY = 0Const DRAFT_QUALITY = 1Const PROOF_QUALITY = 2'used with fdwPitchAndFamilyConst DEFAULT_PITCH = 0Const FIXED_PITCH = 1Const VARIABLE_PITCH = 2'used with SetBkModeConst OPAQUE = 2Const TRANSPARENT = 1Const LOGPIXELSY = 90Const COLOR_WINDOW = 5Const Message = "Hello !"Private Type RECT Left As Long Top As Long Right As Long Bottom As LongEnd TypePrivate Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As LongPrivate Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As LongPrivate Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As LongPrivate Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As LongPrivate Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As LongPrivate Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As LongPrivate Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As LongPrivate Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As LongPrivate Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As LongPrivate Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal nHeight As Long, ByVal nWidth As Long, ByVal nEscapement As Long, ByVal nOrientation As Long, ByVal fnWeight As Long, ByVal fdwItalic As Boolean, ByVal fdwUnderline As Boolean, ByVal fdwStrikeOut As Boolean, ByVal fdwCharSet As Long, ByVal fdwOutputPrecision As Long, ByVal fdwClipPrecision As Long, ByVal fdwQuality As Long, ByVal fdwPitchAndFamily As Long, ByVal lpszFace As String) As LongPrivate Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As LongPrivate Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As LongPrivate Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As LongPrivate Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As LongPrivate Declare Function GetSysColorBrush Lib "user32" (ByVal nIndex As Long) As LongPrivate Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As LongPrivate Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As LongDim mDC As Long, mBitmap As LongPrivate Sub Form_Click() Unload MeEnd SubPrivate Sub Form_Load() 'KPD-Team 1999 'URL: http://www.allapi.net/ 'E-Mail: KPDTeam@Allapi.net Dim mRGN As Long, Cnt As Long, mBrush As Long, R As RECT 'Create a device context, compatible with the screen mDC = CreateCompatibleDC(GetDC(0)) 'Create a bitmap, compatible with the screen mBitmap = CreateCompatibleBitmap(GetDC(0), Me.Width / Screen.TwipsPerPixelX, Me.Height / Screen.TwipsPerPixelY) 'Select the bitmap nito the device context SelectObject mDC, mBitmap 'Set the bitmap's backmode to transparent SetBkMode mDC, TRANSPARENT 'Set the rectangles' values SetRect R, 0, 0, Me.Width / Screen.TwipsPerPixelX, Me.Height / Screen.TwipsPerPixelY 'Fill the rect with the default window-color FillRect mDC, R, GetSysColorBrush(COLOR_WINDOW) For Cnt = 0 To 350 Step 30 'Select the new font into the form's device context and delete the old font DeleteObject SelectObject(mDC, CreateMyFont(24, Cnt)) 'Print some text TextOut mDC, (Me.Width / Screen.TwipsPerPixelX) / 2, (Me.Height / Screen.TwipsPerPixelY) / 2, Message, Len(Message) Next Cnt 'Create an elliptical region mRGN = CreateEllipticRgn(0, 0, Me.Width / Screen.TwipsPerPixelX, Me.Height / Screen.TwipsPerPixelY) 'Set the window region SetWindowRgn Me.hWnd, mRGN, True 'delete our elliptical region DeleteObject mRGNEnd SubFunction CreateMyFont(nSize As Integer, nDegrees As Long) As Long 'Create a specified font CreateMyFont = CreateFont(-MulDiv(nSize, GetDeviceCaps(GetDC(0), LOGPIXELSY), 72), 0, nDegrees * 10, 0, FW_NORMAL, False, False, False, DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, PROOF_QUALITY, DEFAULT_PITCH, "Times New Roman")End FunctionPrivate Sub Form_Paint() 'Copy the picture to the form BitBlt Me.hdc, 0, 0, Me.Width / Screen.TwipsPerPixelX, Me.Height / Screen.TwipsPerPixelY, mDC, 0, 0, vbSrcCopyEnd SubPrivate Sub Form_Unload(Cancel As Integer) 'clean up DeleteDC mDC DeleteObject mBitmapEnd Sub
[解决办法]
上面这个例子中有一个函数：CreateMyFont，把其中的：
CreateMyFont = CreateFont(-MulDiv(nSize, GetDeviceCaps(GetDC(0), LOGPIXELSY), 72), 0, nDegrees * 10, 0, FW_NORMAL, False, False, False, DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, PROOF_QUALITY, DEFAULT_PITCH, "Times New Roman")
