“如何将汉字的矢量路径取出来,我的目的是驱动机构按此路径移动,这样就可以做出一些意想不到的效果!比如说绣花!” 我提出否定意见,要绣花必然要获得汉字的笔画顺序,但是这在GB(包括GBK)字库中是没有的!也就是说,根本无法实现。 如果单纯是提取笔画的话,提出一种方案,先将汉字进行横纵双向扫描,初步分析出横竖笔画,然后在分析点、捺、撇之类的,具体代码正在思考中... -------------------------------------------------------------------- Made by Thirdapple's Studio
其实汉字字体中,如宋体是很单调的,没有什么笔锋的变化,你可以将汉字宋体的横折竖撇捺等保存起来,在一个汉字中比对,就可以分析出了。 -------------------------------------------------------------------- 另,还是推荐《人工智能》一书。 -------------------------------------------------------------------- Made by Thirdapple's Studio
两个类模块: 你看看代码!! Option Explicit' Logical Font Private Const LF_FACESIZE = 32 Private Const LF_FULLFACESIZE = 64Private Const CLIP_DEFAULT_PRECIS = 0 Private Const CLIP_CHARACTER_PRECIS = 1 Private Const CLIP_STROKE_PRECIS = 2 Private Const CLIP_MASK = &HF Private Const CLIP_LH_ANGLES = 16 Private Const CLIP_TT_ALWAYS = 32 Private Const CLIP_EMBEDDED = 128Private Const DEFAULT_QUALITY = 0 Private Const DRAFT_QUALITY = 1 Private Const PROOF_QUALITY = 2Private Const DEFAULT_PITCH = 0 Private Const FIXED_PITCH = 1 Private Const VARIABLE_PITCH = 2Private Const ANSI_CHARSET = 0 Private Const DEFAULT_CHARSET = 1 Private Const SYMBOL_CHARSET = 2 Private Const SHIFTJIS_CHARSET = 128 Private Const HANGEUL_CHARSET = 129 Private Const CHINESEBIG5_CHARSET = 136 Private Const OEM_CHARSET = 255' Font Families ' Private Const FF_DONTCARE = 0 ' Don't care or don't know. Private Const FF_ROMAN = 16 ' Variable stroke width, serifed.' Times Roman, Century Schoolbook, etc. Private Const FF_SWISS = 32 ' Variable stroke width, sans-serifed.' Helvetica, Swiss, etc. Private Const FF_MODERN = 48 ' Constant stroke width, serifed or sans-serifed.' Pica, Elite, Courier, etc. Private Const FF_SCRIPT = 64 ' Cursive, etc. Private Const FF_DECORATIVE = 80 ' Old English, etc.' Font Weights Private Const FW_DONTCARE = 0 Private Const FW_THIN = 100 Private Const FW_EXTRALIGHT = 200 Private Const FW_LIGHT = 300 Private Const FW_NORMAL = 400 Private Const FW_MEDIUM = 500 Private Const FW_SEMIBOLD = 600 Private Const FW_BOLD = 700 Private Const FW_EXTRABOLD = 800 Private Const FW_HEAVY = 900Private Const FW_ULTRALIGHT = FW_EXTRALIGHT Private Const FW_REGULAR = FW_NORMAL Private Const FW_DEMIBOLD = FW_SEMIBOLD Private Const FW_ULTRABOLD = FW_EXTRABOLD Private Const FW_BLACK = FW_HEAVYPrivate Const OUT_DEFAULT_PRECIS = 0 Private Const OUT_STRING_PRECIS = 1 Private Const OUT_CHARACTER_PRECIS = 2 Private Const OUT_STROKE_PRECIS = 3 Private Const OUT_TT_PRECIS = 4 Private Const OUT_DEVICE_PRECIS = 5 Private Const OUT_RASTER_PRECIS = 6 Private Const OUT_TT_ONLY_PRECIS = 7 Private Const OUT_OUTLINE_PRECIS = 8Private 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 As String * LF_FACESIZE End TypePrivate Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LogFont) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As LongPrivate Const LOGPIXELSY = 90 ' Logical pixels/inch in YPrivate Declare Function GetDesktopWindow Lib "user32" () 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 LongPrivate m_Font As StdFont Private m_hFont As Long Private m_Rotation As SinglePrivate Sub Class_Terminate() ' ' Clean-up created objects!!! ' If m_hFont Then Call DeleteObject(m_hFont) Set m_Font = Nothing End If End SubPublic Property Set LogFont(ByVal NewFont As IFont) If m_hFont Then Call DeleteObject(m_hFont) m_hFont = 0 End If
Set m_Font = Nothing If Not NewFont Is Nothing Then ' ' Stash a copy of the passed object, ' to avoid a new reference to it. ' NewFont.Clone m_Font m_hFont = CreateLogFont End If End PropertyPublic Property Get LogFont() As IFont Set LogFont = m_Font End PropertyPublic Property Let Rotation(ByVal NewVal As Single) If NewVal <> m_Rotation Then m_Rotation = NewVal If m_hFont Then Call DeleteObject(m_hFont) m_hFont = 0 End If If Not (m_Font Is Nothing) Then m_hFont = CreateLogFont End If End If End PropertyPublic Property Get Rotation() As Single Rotation = m_Rotation End PropertyPublic Property Get Handle() As Long Handle = m_hFont End PropertyPrivate Function CreateLogFont() As Long Dim lf As LogFont Dim hWnd As Long Dim hDC As Long
hWnd = GetDesktopWindow hDC = GetDC(hWnd)
With lf ' ' All but two properties are very straight-forward, ' even with rotation, and map directly. ' .lfHeight = -(m_Font.Size * GetDeviceCaps(hDC, LOGPIXELSY)) / 72 .lfWidth = 0 .lfEscapement = m_Rotation * 10 .lfOrientation = .lfEscapement .lfWeight = m_Font.Weight .lfItalic = m_Font.Italic .lfUnderline = m_Font.Underline .lfStrikeOut = m_Font.Strikethrough .lfClipPrecision = CLIP_DEFAULT_PRECIS .lfQuality = PROOF_QUALITY .lfPitchAndFamily = DEFAULT_PITCH Or FF_DONTCARE .lfFaceName = m_Font.Name & vbNullChar ' ' OEM fonts can't rotate, and we must force ' substitution with something ANSI. ' .lfCharSet = m_Font.Charset If .lfCharSet = OEM_CHARSET Then If (m_Rotation Mod 360) <> 0 Then .lfCharSet = ANSI_CHARSET End If End If ' ' Only TrueType fonts can rotate, so we must ' specify TT-only if angle is not zero. ' If (m_Rotation Mod 360) <> 0 Then .lfOutPrecision = OUT_TT_ONLY_PRECIS Else .lfOutPrecision = OUT_DEFAULT_PRECIS End If End With
CreateLogFont = CreateFontIndirect(lf) Call ReleaseDC(hWnd, hDC) End Function
类2 Option ExplicitPrivate Declare Function BeginPath Lib "gdi32" (ByVal hDC As Long) As Long Private Declare Function EndPath Lib "gdi32" (ByVal hDC As Long) As Long Private 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 StrokeAndFillPath Lib "gdi32" (ByVal hDC As Long) As Long Private Declare Function StrokePath Lib "gdi32" (ByVal hDC As Long) As Long Private Declare Function FillPath Lib "gdi32" (ByVal hDC As Long) As LongPrivate Declare Function GetBkMode Lib "gdi32" (ByVal hDC As Long) As Long Private Declare Function SetBkMode Lib "gdi32" (ByVal hDC As Long, ByVal nBkMode As Long) As LongPrivate Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPrivate Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long' Background Modes Private Const TRANSPARENT = 1 Private Const OPAQUE = 2 Private Const BKMODE_LAST = 2' Pen Styles Private Const PS_SOLID = 0 Private Const PS_DASH = 1 ' ------- Private Const PS_DOT = 2 ' ....... Private Const PS_DASHDOT = 3 ' _._._._ Private Const PS_DASHDOTDOT = 4 ' _.._.._ Private Const PS_NULL = 5 Private Const PS_INSIDEFRAME = 6 Private Const PS_USERSTYLE = 7 Private Const PS_ALTERNATE = 8 Private Const PS_STYLE_MASK = &HF' Member variables Private m_Angle As Single Private m_FillColor As OLE_COLOR Private m_Filled As Boolean Private m_Font As StdFont Private m_hDC As Long Private m_OutlineBehind As Boolean Private m_OutlineColor As OLE_COLOR Private m_Outlined As Boolean Private m_PenWidth As Long Private m_UseExistingObjs As Boolean' ************************************************************** ' Init/Term ' ************************************************************** Private Sub Class_Initialize() ' initialize props m_Filled = False m_FillColor = vbRed m_OutlineColor = vbBlack m_Outlined = True m_PenWidth = 1 m_UseExistingObjs = True End SubPrivate Sub Class_Terminate() ' End Sub' ************************************************************** ' Public Properties ' ************************************************************** Public Property Let Angle(ByVal NewVal As Single) m_Angle = NewVal End PropertyPublic Property Get Angle() As Single Angle = m_Angle End PropertyPublic Property Let FillColor(ByVal NewVal As OLE_COLOR) m_FillColor = NewVal End PropertyPublic Property Get FillColor() As OLE_COLOR FillColor = m_FillColor End PropertyPublic Property Let Filled(ByVal NewVal As Boolean) m_Filled = NewVal End PropertyPublic Property Get Filled() As Boolean Filled = m_Filled End PropertyPublic Property Set Font(ByVal NewFont As IFont) Set m_Font = Nothing If Not NewFont Is Nothing Then ' ' Stash a copy of the passed object, ' to avoid a new reference to it. ' NewFont.Clone m_Font End If End PropertyPublic Property Get Font() As IFont Set Font = m_Font End PropertyPublic Property Let hDC(ByVal NewVal As Long) m_hDC = NewVal End PropertyPublic Property Get hDC() As Long hDC = m_hDC End PropertyPublic Property Let OutlineBehind(ByVal NewVal As Boolean) m_OutlineBehind = NewVal End PropertyPublic Property Get OutlineBehind() As Boolean OutlineBehind = m_OutlineBehind End PropertyPublic Property Let OutlineColor(ByVal NewVal As OLE_COLOR) m_OutlineColor = NewVal End PropertyPublic Property Get OutlineColor() As OLE_COLOR OutlineColor = m_OutlineColor End PropertyPublic Property Let Outlined(ByVal NewVal As Boolean) m_Outlined = NewVal End PropertyPublic Property Get Outlined() As Boolean Outlined = m_Outlined End PropertyPublic Property Let PenWidth(ByVal NewVal As Long) m_PenWidth = NewVal End PropertyPublic Property Get PenWidth() As Long PenWidth = m_PenWidth End PropertyPublic Property Let UseExistingObjects(ByVal NewVal As Boolean) m_UseExistingObjs = NewVal End PropertyPublic Property Get UseExistingObjects() As Boolean UseExistingObjects = m_UseExistingObjs End Property' ************************************************************** ' Public Methods ' ************************************************************** Public Sub DrawText(ByVal Text As String, ByVal X As Long, ByVal Y As Long) Static oldAlign As Long Static oldBkMode As Long Static oldPen As Long Static oldBrush As Long Static oldFont As Long Static hPen As Long Static hBrush As Long Static nRet As Long
If m_hDC Then oldBkMode = SetBkMode(m_hDC, TRANSPARENT) If m_UseExistingObjs = False Then ' create and select new objects If m_Filled Then hBrush = CreateSolidBrush(CheckSysColor(m_FillColor)) oldBrush = SelectObject(m_hDC, hBrush) End If If m_Outlined Then hPen = CreatePen(PS_SOLID, m_PenWidth, CheckSysColor(m_OutlineColor)) oldPen = SelectObject(m_hDC, hPen) End If If Not (m_Font Is Nothing) Then Dim fnt As New CLogFont Set fnt.LogFont = m_Font fnt.Rotation = m_Angle oldFont = SelectObject(m_hDC, fnt.Handle) End If End If
' create the path within the DC Call BeginPath(m_hDC) Call TextOut(m_hDC, X, Y, Text, Len(Text)) Call EndPath(m_hDC)
If m_Outlined And m_Filled Then If m_OutlineBehind Then ' first draw the outline, then... Call StrokePath(m_hDC) ' recreate the path, then... Call BeginPath(m_hDC) Call TextOut(m_hDC, X, Y, Text, Len(Text)) Call EndPath(m_hDC) ' fill the path. Call FillPath(m_hDC) Else Call StrokeAndFillPath(m_hDC) End If ElseIf m_Filled Then Call FillPath(m_hDC) ElseIf m_Outlined Then Call StrokePath(m_hDC) End If
If m_UseExistingObjs = False Then ' restore old objects, and delete new If m_Filled Then Call SelectObject(m_hDC, oldBrush) Call DeleteObject(hBrush) End If If m_Outlined Then Call SelectObject(m_hDC, oldPen) Call DeleteObject(hPen) End If If Not (m_Font Is Nothing) Then Call SelectObject(m_hDC, oldFont) End If End If Call SetBkMode(m_hDC, oldBkMode) End If End Sub' ************************************************************** ' Private Methods ' ************************************************************** Private Function CheckSysColor(ByVal Color As Long) As Long Const HighBit = &H80000000 ' ' If high bit set, strip, and get system color. ' If Color And HighBit Then CheckSysColor = GetSysColor(Color And Not HighBit) Else CheckSysColor = Color End If End Function 一起用!
有一个个API上专用来取字符信息的: DWORD GetGlyphOutline( HDC hdc, // handle to device context UINT uChar, // character to query UINT uFormat, // format of data to return LPGLYPHMETRICS lpgm, // pointer to structure for metrics DWORD cbBuffer, // size of buffer for data LPVOID lpvBuffer, // pointer to buffer for data CONST MAT2 *lpmat2 // pointer to transformation matrix structure ); 你查查MSDN
Public Sub DrawText(ByVal Text As String, ByVal X As Long, ByVal Y As Long)中 Dim fnt As New CLogFont 要出错 用户定义类型未定义
to:caichunmao(转瞬之间) 第一个类模块取名称为“CLogFont” 第二个类模块取名称为“Class2” 然后我添加了一个form 代码如下: Dim newclogfont As New Class2Private Sub Command1_Click() Call newclogfont.DrawText("似", 100, 100) End Sub编译通过,但是逐步运行发现m_hDC=0 所以什么也没有得到。
Private Declare Function BeginPath Lib "gdi32" (ByVal hdc As Long) As Long Private 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 Long Private Declare Function EndPath Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function PathToRegion Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function GetRgnBox Lib "gdi32" (ByVal hRgn As Long, lpRect As RECT) As Long Private Declare Function CreateRectRgnIndirect Lib "gdi32" (lpRect As RECT) As Long Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long Private Declare Function ReleaseCapture Lib "user32" () As Long Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long Private 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 Long Private Type RECT Left As Long Top As Long Right As Long bottom As Long End Type Private Const WM_NCLBUTTONDOWN = &HA1 Private Const HTCAPTION = 2 Private Const RGN_AND = 1 Private Const RGN_OR = 2 Private Const RGN_XOR = 3 Private Const RGN_DIFF = 4 Private Const RGN_COPY = 5 Private Function GetTextRgn() As Long Dim hRgn1 As Long, hRgn2 As Long Dim rct As RECT BeginPath hdc 'BitBlt hdc ,0,10, 200,200, TextOut hdc, 0, 5, Chr$(74), 1 'Windows Flag 'Circle (2000, 2000), 1000 'Circle window 'Create any path you want in this section to create your irregular window. EndPath hdc hRgn1 = PathToRegion(hdc) GetRgnBox hRgn1, rct hRgn2 = CreateRectRgnIndirect(rct) CombineRgn hRgn2, hRgn2, hRgn1, 1 DeleteObject hRgn1 GetTextRgn = hRgn2 End Function Private Sub Form_DblClick() Unload Me End Sub Private Sub Form_Load() Dim hRgn As Long Me.Font.Name = "Wingdings" Me.Font.Size = 200hRgn = GetTextRgn() SetWindowRgn hwnd, hRgn, 1 End Sub Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) ReleaseCapture SendMessage hwnd, WM_NCLBUTTONDOWN, HTCAPTION, ByVal 0& End Sub
http://www.csdn.net/Dev/Format/#文本及字体
我提出否定意见,要绣花必然要获得汉字的笔画顺序,但是这在GB(包括GBK)字库中是没有的!也就是说,根本无法实现。
如果单纯是提取笔画的话,提出一种方案,先将汉字进行横纵双向扫描,初步分析出横竖笔画,然后在分析点、捺、撇之类的,具体代码正在思考中...
--------------------------------------------------------------------
Made by Thirdapple's Studio
--------------------------------------------------------------------
另,还是推荐《人工智能》一书。
--------------------------------------------------------------------
Made by Thirdapple's Studio
你看看代码!!
Option Explicit' Logical Font
Private Const LF_FACESIZE = 32
Private Const LF_FULLFACESIZE = 64Private Const CLIP_DEFAULT_PRECIS = 0
Private Const CLIP_CHARACTER_PRECIS = 1
Private Const CLIP_STROKE_PRECIS = 2
Private Const CLIP_MASK = &HF
Private Const CLIP_LH_ANGLES = 16
Private Const CLIP_TT_ALWAYS = 32
Private Const CLIP_EMBEDDED = 128Private Const DEFAULT_QUALITY = 0
Private Const DRAFT_QUALITY = 1
Private Const PROOF_QUALITY = 2Private Const DEFAULT_PITCH = 0
Private Const FIXED_PITCH = 1
Private Const VARIABLE_PITCH = 2Private Const ANSI_CHARSET = 0
Private Const DEFAULT_CHARSET = 1
Private Const SYMBOL_CHARSET = 2
Private Const SHIFTJIS_CHARSET = 128
Private Const HANGEUL_CHARSET = 129
Private Const CHINESEBIG5_CHARSET = 136
Private Const OEM_CHARSET = 255' Font Families
'
Private Const FF_DONTCARE = 0 ' Don't care or don't know.
Private Const FF_ROMAN = 16 ' Variable stroke width, serifed.' Times Roman, Century Schoolbook, etc.
Private Const FF_SWISS = 32 ' Variable stroke width, sans-serifed.' Helvetica, Swiss, etc.
Private Const FF_MODERN = 48 ' Constant stroke width, serifed or sans-serifed.' Pica, Elite, Courier, etc.
Private Const FF_SCRIPT = 64 ' Cursive, etc.
Private Const FF_DECORATIVE = 80 ' Old English, etc.' Font Weights
Private Const FW_DONTCARE = 0
Private Const FW_THIN = 100
Private Const FW_EXTRALIGHT = 200
Private Const FW_LIGHT = 300
Private Const FW_NORMAL = 400
Private Const FW_MEDIUM = 500
Private Const FW_SEMIBOLD = 600
Private Const FW_BOLD = 700
Private Const FW_EXTRABOLD = 800
Private Const FW_HEAVY = 900Private Const FW_ULTRALIGHT = FW_EXTRALIGHT
Private Const FW_REGULAR = FW_NORMAL
Private Const FW_DEMIBOLD = FW_SEMIBOLD
Private Const FW_ULTRABOLD = FW_EXTRABOLD
Private Const FW_BLACK = FW_HEAVYPrivate Const OUT_DEFAULT_PRECIS = 0
Private Const OUT_STRING_PRECIS = 1
Private Const OUT_CHARACTER_PRECIS = 2
Private Const OUT_STROKE_PRECIS = 3
Private Const OUT_TT_PRECIS = 4
Private Const OUT_DEVICE_PRECIS = 5
Private Const OUT_RASTER_PRECIS = 6
Private Const OUT_TT_ONLY_PRECIS = 7
Private Const OUT_OUTLINE_PRECIS = 8Private 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 As String * LF_FACESIZE
End TypePrivate Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LogFont) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As LongPrivate Const LOGPIXELSY = 90 ' Logical pixels/inch in YPrivate Declare Function GetDesktopWindow Lib "user32" () 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 LongPrivate m_Font As StdFont
Private m_hFont As Long
Private m_Rotation As SinglePrivate Sub Class_Terminate()
'
' Clean-up created objects!!!
'
If m_hFont Then
Call DeleteObject(m_hFont)
Set m_Font = Nothing
End If
End SubPublic Property Set LogFont(ByVal NewFont As IFont)
If m_hFont Then
Call DeleteObject(m_hFont)
m_hFont = 0
End If
Set m_Font = Nothing
If Not NewFont Is Nothing Then
'
' Stash a copy of the passed object,
' to avoid a new reference to it.
'
NewFont.Clone m_Font
m_hFont = CreateLogFont
End If
End PropertyPublic Property Get LogFont() As IFont
Set LogFont = m_Font
End PropertyPublic Property Let Rotation(ByVal NewVal As Single)
If NewVal <> m_Rotation Then
m_Rotation = NewVal
If m_hFont Then
Call DeleteObject(m_hFont)
m_hFont = 0
End If
If Not (m_Font Is Nothing) Then
m_hFont = CreateLogFont
End If
End If
End PropertyPublic Property Get Rotation() As Single
Rotation = m_Rotation
End PropertyPublic Property Get Handle() As Long
Handle = m_hFont
End PropertyPrivate Function CreateLogFont() As Long
Dim lf As LogFont
Dim hWnd As Long
Dim hDC As Long
hWnd = GetDesktopWindow
hDC = GetDC(hWnd)
With lf
'
' All but two properties are very straight-forward,
' even with rotation, and map directly.
'
.lfHeight = -(m_Font.Size * GetDeviceCaps(hDC, LOGPIXELSY)) / 72
.lfWidth = 0
.lfEscapement = m_Rotation * 10
.lfOrientation = .lfEscapement
.lfWeight = m_Font.Weight
.lfItalic = m_Font.Italic
.lfUnderline = m_Font.Underline
.lfStrikeOut = m_Font.Strikethrough
.lfClipPrecision = CLIP_DEFAULT_PRECIS
.lfQuality = PROOF_QUALITY
.lfPitchAndFamily = DEFAULT_PITCH Or FF_DONTCARE
.lfFaceName = m_Font.Name & vbNullChar
'
' OEM fonts can't rotate, and we must force
' substitution with something ANSI.
'
.lfCharSet = m_Font.Charset
If .lfCharSet = OEM_CHARSET Then
If (m_Rotation Mod 360) <> 0 Then
.lfCharSet = ANSI_CHARSET
End If
End If
'
' Only TrueType fonts can rotate, so we must
' specify TT-only if angle is not zero.
'
If (m_Rotation Mod 360) <> 0 Then
.lfOutPrecision = OUT_TT_ONLY_PRECIS
Else
.lfOutPrecision = OUT_DEFAULT_PRECIS
End If
End With
CreateLogFont = CreateFontIndirect(lf)
Call ReleaseDC(hWnd, hDC)
End Function
类2
Option ExplicitPrivate Declare Function BeginPath Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function EndPath Lib "gdi32" (ByVal hDC As Long) As Long
Private 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 StrokeAndFillPath Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function StrokePath Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function FillPath Lib "gdi32" (ByVal hDC As Long) As LongPrivate Declare Function GetBkMode Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hDC As Long, ByVal nBkMode As Long) As LongPrivate Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPrivate Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long' Background Modes
Private Const TRANSPARENT = 1
Private Const OPAQUE = 2
Private Const BKMODE_LAST = 2' Pen Styles
Private Const PS_SOLID = 0
Private Const PS_DASH = 1 ' -------
Private Const PS_DOT = 2 ' .......
Private Const PS_DASHDOT = 3 ' _._._._
Private Const PS_DASHDOTDOT = 4 ' _.._.._
Private Const PS_NULL = 5
Private Const PS_INSIDEFRAME = 6
Private Const PS_USERSTYLE = 7
Private Const PS_ALTERNATE = 8
Private Const PS_STYLE_MASK = &HF' Member variables
Private m_Angle As Single
Private m_FillColor As OLE_COLOR
Private m_Filled As Boolean
Private m_Font As StdFont
Private m_hDC As Long
Private m_OutlineBehind As Boolean
Private m_OutlineColor As OLE_COLOR
Private m_Outlined As Boolean
Private m_PenWidth As Long
Private m_UseExistingObjs As Boolean' **************************************************************
' Init/Term
' **************************************************************
Private Sub Class_Initialize()
' initialize props
m_Filled = False
m_FillColor = vbRed
m_OutlineColor = vbBlack
m_Outlined = True
m_PenWidth = 1
m_UseExistingObjs = True
End SubPrivate Sub Class_Terminate()
'
End Sub' **************************************************************
' Public Properties
' **************************************************************
Public Property Let Angle(ByVal NewVal As Single)
m_Angle = NewVal
End PropertyPublic Property Get Angle() As Single
Angle = m_Angle
End PropertyPublic Property Let FillColor(ByVal NewVal As OLE_COLOR)
m_FillColor = NewVal
End PropertyPublic Property Get FillColor() As OLE_COLOR
FillColor = m_FillColor
End PropertyPublic Property Let Filled(ByVal NewVal As Boolean)
m_Filled = NewVal
End PropertyPublic Property Get Filled() As Boolean
Filled = m_Filled
End PropertyPublic Property Set Font(ByVal NewFont As IFont)
Set m_Font = Nothing
If Not NewFont Is Nothing Then
'
' Stash a copy of the passed object,
' to avoid a new reference to it.
'
NewFont.Clone m_Font
End If
End PropertyPublic Property Get Font() As IFont
Set Font = m_Font
End PropertyPublic Property Let hDC(ByVal NewVal As Long)
m_hDC = NewVal
End PropertyPublic Property Get hDC() As Long
hDC = m_hDC
End PropertyPublic Property Let OutlineBehind(ByVal NewVal As Boolean)
m_OutlineBehind = NewVal
End PropertyPublic Property Get OutlineBehind() As Boolean
OutlineBehind = m_OutlineBehind
End PropertyPublic Property Let OutlineColor(ByVal NewVal As OLE_COLOR)
m_OutlineColor = NewVal
End PropertyPublic Property Get OutlineColor() As OLE_COLOR
OutlineColor = m_OutlineColor
End PropertyPublic Property Let Outlined(ByVal NewVal As Boolean)
m_Outlined = NewVal
End PropertyPublic Property Get Outlined() As Boolean
Outlined = m_Outlined
End PropertyPublic Property Let PenWidth(ByVal NewVal As Long)
m_PenWidth = NewVal
End PropertyPublic Property Get PenWidth() As Long
PenWidth = m_PenWidth
End PropertyPublic Property Let UseExistingObjects(ByVal NewVal As Boolean)
m_UseExistingObjs = NewVal
End PropertyPublic Property Get UseExistingObjects() As Boolean
UseExistingObjects = m_UseExistingObjs
End Property' **************************************************************
' Public Methods
' **************************************************************
Public Sub DrawText(ByVal Text As String, ByVal X As Long, ByVal Y As Long)
Static oldAlign As Long
Static oldBkMode As Long
Static oldPen As Long
Static oldBrush As Long
Static oldFont As Long
Static hPen As Long
Static hBrush As Long
Static nRet As Long
If m_hDC Then
oldBkMode = SetBkMode(m_hDC, TRANSPARENT)
If m_UseExistingObjs = False Then
' create and select new objects
If m_Filled Then
hBrush = CreateSolidBrush(CheckSysColor(m_FillColor))
oldBrush = SelectObject(m_hDC, hBrush)
End If
If m_Outlined Then
hPen = CreatePen(PS_SOLID, m_PenWidth, CheckSysColor(m_OutlineColor))
oldPen = SelectObject(m_hDC, hPen)
End If
If Not (m_Font Is Nothing) Then
Dim fnt As New CLogFont
Set fnt.LogFont = m_Font
fnt.Rotation = m_Angle
oldFont = SelectObject(m_hDC, fnt.Handle)
End If
End If
' create the path within the DC
Call BeginPath(m_hDC)
Call TextOut(m_hDC, X, Y, Text, Len(Text))
Call EndPath(m_hDC)
If m_Outlined And m_Filled Then
If m_OutlineBehind Then
' first draw the outline, then...
Call StrokePath(m_hDC)
' recreate the path, then...
Call BeginPath(m_hDC)
Call TextOut(m_hDC, X, Y, Text, Len(Text))
Call EndPath(m_hDC)
' fill the path.
Call FillPath(m_hDC)
Else
Call StrokeAndFillPath(m_hDC)
End If
ElseIf m_Filled Then
Call FillPath(m_hDC)
ElseIf m_Outlined Then
Call StrokePath(m_hDC)
End If
If m_UseExistingObjs = False Then
' restore old objects, and delete new
If m_Filled Then
Call SelectObject(m_hDC, oldBrush)
Call DeleteObject(hBrush)
End If
If m_Outlined Then
Call SelectObject(m_hDC, oldPen)
Call DeleteObject(hPen)
End If
If Not (m_Font Is Nothing) Then
Call SelectObject(m_hDC, oldFont)
End If
End If
Call SetBkMode(m_hDC, oldBkMode)
End If
End Sub' **************************************************************
' Private Methods
' **************************************************************
Private Function CheckSysColor(ByVal Color As Long) As Long
Const HighBit = &H80000000
'
' If high bit set, strip, and get system color.
'
If Color And HighBit Then
CheckSysColor = GetSysColor(Color And Not HighBit)
Else
CheckSysColor = Color
End If
End Function
一起用!
DWORD GetGlyphOutline(
HDC hdc, // handle to device context
UINT uChar, // character to query
UINT uFormat, // format of data to return
LPGLYPHMETRICS lpgm, // pointer to structure for metrics
DWORD cbBuffer, // size of buffer for data
LPVOID lpvBuffer, // pointer to buffer for data
CONST MAT2 *lpmat2 // pointer to transformation matrix structure
);
你查查MSDN
Dim fnt As New CLogFont
要出错
用户定义类型未定义
第一个类模块取名称为“CLogFont”
第二个类模块取名称为“Class2”
然后我添加了一个form
代码如下:
Dim newclogfont As New Class2Private Sub Command1_Click()
Call newclogfont.DrawText("似", 100, 100)
End Sub编译通过,但是逐步运行发现m_hDC=0
所以什么也没有得到。
Private 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 Long
Private Declare Function EndPath Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function PathToRegion Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetRgnBox Lib "gdi32" (ByVal hRgn As Long, lpRect As RECT) As Long
Private Declare Function CreateRectRgnIndirect Lib "gdi32" (lpRect As RECT) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private 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 Long
Private Type RECT
Left As Long
Top As Long
Right As Long
bottom As Long
End Type
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const HTCAPTION = 2
Private Const RGN_AND = 1
Private Const RGN_OR = 2
Private Const RGN_XOR = 3
Private Const RGN_DIFF = 4
Private Const RGN_COPY = 5
Private Function GetTextRgn() As Long
Dim hRgn1 As Long, hRgn2 As Long
Dim rct As RECT
BeginPath hdc
'BitBlt hdc ,0,10, 200,200,
TextOut hdc, 0, 5, Chr$(74), 1 'Windows Flag
'Circle (2000, 2000), 1000 'Circle window
'Create any path you want in this section to create your irregular window.
EndPath hdc
hRgn1 = PathToRegion(hdc)
GetRgnBox hRgn1, rct
hRgn2 = CreateRectRgnIndirect(rct)
CombineRgn hRgn2, hRgn2, hRgn1, 1
DeleteObject hRgn1
GetTextRgn = hRgn2
End Function
Private Sub Form_DblClick()
Unload Me
End Sub
Private Sub Form_Load()
Dim hRgn As Long
Me.Font.Name = "Wingdings"
Me.Font.Size = 200hRgn = GetTextRgn()
SetWindowRgn hwnd, hRgn, 1
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
ReleaseCapture
SendMessage hwnd, WM_NCLBUTTONDOWN, HTCAPTION, ByVal 0&
End Sub
图3-1 16×16点阵字形
图3-1所示为16×16的点阵字形,以{0,1,2,3,4,5,6,7,8, 9,A,B,C,D,E,F表示点阵的纵坐标和横坐标,则OOH至FFH就 可表示点阵中每个象素的位置。点阵中的每一线段均以两个端点 表示,则两个字节即可表示一条线段。如果以前面一个字节表示 起点坐标,后面一个字节表示终点坐标,则两个字节表示的线段是 有向的,即向量。图3-1所示的“山”字可用下列数据来表示:
(15,1E);(80,8D);(F5,FE);(1D,FD) 这样,这个“山”字的字形用8个字节即可表达。凡是采用这 样的骨架向量法来压缩字形信息的,压缩信息的字节数一定是笔 段数的2倍,而记录一个16×16的点阵需要32个字节,所以对笔 画数少于16画的汉字字形信息均可有不同程度的压缩。而且字 形点阵越大,压缩信率越高。然而这样的骨架向量法仅仅适用于 低质量的简易线条字形,随着大规模、超大规模集成电路的发展, 半导体存储器的容量越来越大而成本越来越低,在半导体存储器 组成的字库里直接存入低质量简易字模的点阵信息,这早已成了 一件并不费力而且经济代价又很低的事情,所以对低质量简易字 模的字形信息进行压缩已经没有什么意义了。
若是采用骨架向量法对高质量精密字模的字形信息进行压 缩,就必须在骨架向量的基础上再附加上“轮廓复原”技术。可以 设想一下以字形骨架上的每一点为圆心,以该点到笔画轮廓曲线 上的最短距离为半径所画的圆的包络线来取代轮廓曲线。这样只 要给骨架上的每一个点配上一个数值,表示从该点到轮廓的最短 距离,那么重建轮廓并不困难。可是,采用这种做法,字形信息的 压缩倍率未必能令人满意。假若在骨架向量的基础上,不附加任 何轮廓信息,而是在文字复原时按某种规则自动生成到轮廓的距 离信息,这样就可以按照要求从线条字形衍生出各种字体的字形 轮廓。采用这种方法,将使字形信息的压缩能够达到极高的倍率, 不过,字形复原时所谓“某种规则”实质上就是汉字笔画轮廓的粗 细、宽窄变化规律。找出这种规律,并用尽可能简单的数学语言对 之进行描述,显然这是一个可以做但不容易做的研究课题。
由线条字形衍生出印刷字体字形轮廓后,对轮廓的填满(亦称 “涂黑”)则与“轮廓向量法”相似。
2.用GetGlyphOutline获得字的轮廓数据(Bezier二次曲线,构成一个或多个多边形).
3.用行扫描法(间隔与绣花线粗一致)获取各轮廓多边形内的扫描线段.
4.轮廓多边形顶点坐标及其内的扫描线端点坐标,即为该字的矢量数据.
turetype是轮廓矢量字库
其实我这就是要取出骨架矢量字的矢量信息。
TureType字和Type 1字体均属于曲线轮廓字,分别用B样条或Bezier曲线表示轮廓.
无论曲线轮廓字还是折线轮廓矢量字,从字库中只能得到字笔划的轮廓数据(曲线的或折线的),轮廓内的填充(实心,空心或纹理)是在程序中实现的。
不知“骨架矢量字的矢量信息”为何意?是指轮廓还是轮廓内数据,或是笔划的中轴线?
TureType字和Type 1 字体均属于曲线轮廓字,分别用B样条和Bezier曲线表示轮廓.
无论曲线轮廓字还是折线轮廓矢量字,从字库中只能得到字笔划的轮廓数据(曲线的或折线的),轮廓内的填充(实心,空心或纹理)是在程序中实现的。
不知“骨架矢量字的矢量信息”为何意?是指轮廓还是轮廓内数据,或是笔划的中轴线?
确实如你所说是那三种字库
骨架适量字是另一种字库,属于其他字库范围
所以我将两种轮廓字归为一种
其实在AutoCad中,有很多种字库,其中有单笔画字库(即在此所谓的轮廓矢量字),它的结构是很简单的。可是事实上我不知道该怎么获得他的矢量信息.
最后谢谢你
确实如你所说是那三种字库
骨架适量字是另一种字库,属于其他字库范围
所以我将两种轮廓字归为一种
其实在AutoCad中,有很多种字库,其中有单笔画字库(即在此所谓的轮廓矢量字),它的结构是很简单的。可是事实上我不知道该怎么获得他的矢量信息.
最后谢谢你
2.若上法有困难,可改用xqr于2002-7-9 12:02:25 发表意见中的1,2,3点试一下(仅输出笔划轮廓).但必须采用幼圆体(汉字)和MS LineDraw体(西文),因为这两种字体的笔划极细,输出的笔划轮廓近似为笔划中轴线.
1.曾见过有直接读取矢量(粗笔划的或单线笔划的)字库然后跟踪并获得矢量数据(粗笔划的轮廓或单线笔划的轴线段)的方法.这可能在前几年的有关文字处理的书刊上能找到.针对你的应用,当然应对单线笔画的矢量字库操作.
2.若上法有困难,可改用xqr于2002-7-9 12:02:25 发表意见中的1,2点试一下(仅输出笔划轮廓).但必须采用幼圆体(汉字)和MS LineDraw体(西文),因为这两种字体的笔划极细,输出的笔划轮廓近似为笔划中轴线.
矢量字库在我国大概1994年前后才较普遍使用(过去主要用点阵字库), 而应用Win3.x后,则一般采用TrueType字库.由此推测有关矢量字处理的文章,可能在1994-1996年间发表有专著,也有载入期刊(可查"中国计算机用户","电脑报"等杂志的合订本).