Attribute VB_Name = "modAPIDraw" Option Explicit ' VB API-Draw library version 1.5b ' Written by Mike D Sutton of EDais ' ' E-Mail: EDais@mvps.org ' WWW: Http://mvps.org/EDais/ ' ' Written: 26/12/2000 ' Last edited: 17/08/2003 ' 'About: ' A library of useful functions to deal with drawing on DC's ' 'Version history: ' Version 1.5b (17/08/2003): ' Entire library now system colour aware, PutNewSysBrush() really only included for ' backwards compatibility, but it may be marginally faster since it uses a stock ' object rather than creating a new solid brush from a system colour each time ' Text drawing now working properly ' ' NewCircPoint() - Same as old CircPoint() method, but now exposed as a point constructor ' EvalCol() - Evaluates any Long colour value into it's RGB form (System colour aware) ' ' Version 1.5 (13/10/2002): ' API declares now all private to allow development in unison with existing GDI code ' Internal point type changed from PointAPI to PointAPID for above reason, ' the new point constructor still has the same name for backward compatibility ' Cleaned up a lot of the code and everything now declared explicity ByRef or ByVal ' ' DrawDCArc() - Draws an arc on a DC with custom pen ' DrawDCArcS() - Draws a simple arc on a DC (Uses current DC pen and brush styles) ' DrawDCPie() - Draws a pie segment on a DC with custom pen and brushes ' DrawDCPieS() - Draws a simple pie segment on a DC (Uses current DC pen and brush styles) ' DrawDCText() - Draws text on a DC with custom font, style, fill and outline ' DrawDCTextS() - Draws simple text on a DC (Uses current DC font and pen/brush styles) ' ' Version 1.2 (27/02/2001): ' Converted all sytle parameters from constants to enumerators (Saves having to look up the constants) ' PutSimpleBrush() - Creates a new brush of the desired colour and selects it into a DC ' DrawDCRoundRect() - Draws a rounded rectangle on a DC with custom pen and brushes ' DrawDCRoundRectS() - Draws a simple rounded rectangle on a DC (Uses current DC pen and brush styles) ' DrawDCPolyLine() - Draws a polygon line on a DC with custom pen style ' DrawDCPolyLineS() - Draws a simple polygon line on a DC (Uses current DC pen style) ' ' Version 1.1 (03/01/2001): ' Re-wrote Current Draw*() functions ' PutNewBrush() - Creates a new brush and selects it into a DC ' PutNewSysBrush() - Creates a new brush from the system colours and selects it into a DC ' PutNewPen() - Creates a new pen and selects it into a DC ' RestoreBrush() - Resores the original brush to a DC ' RestorePen() - Resores the original pen to a DC ' DrawDCEllipse() - Draws an ellipse on a DC with custom pen and brushes ' DrawDCEllipseS() - Draws a simple ellipse on a DC (Uses current DC pen and brush styles) ' DrawDCRect() - Draws a rectangle on a DC with custom pen and brushes ' DrawDCRectS() - Draws a simple rectangle on a DC (Uses current DC pen and brush styles) ' DrawDCStar() - Draws a star on a DC with custom pen and brushes ' DrawDCStarS() - Draws a simple star on a DC (Uses current DC pen and brush styles) ' ' Version 1.0 (26/12/2000): ' NewPointAPI() - PointAPI constructor ' DrawDCPolygon() - Draws a polygon on a DC with custom pen and brush sytles ' DrawDCPolygonS() - Draws a simple polygon on a DC (Uses current DC pen and brush styles) ' DrawDCLine() - Draws a line on a DC with custom pen style ' DrawDCLineS() - Draws a simple line on a DC (Uses current DC pen style) ' 'You use this code at your own risk, I don't accept any ' responsibility for anything nasty it may do to your machine! ' 'Please don't rip my work off... I'm distributing this library ' free of charge because I think it can help other developers, ' this doesn't give you the right to take credit for it. By ' all means use it, yes, but please don't claim it's your own ' work or charge for it. If you do create anything interesting ' with it then feel free to send me it, if I receive any nice ' source code I'll post it on the site (With your permission) ' and of course you'll get full credit for it. ' 'Visit my site for any updates to this an more strange graphics ' related VB code, comments and suggestions always welcome! Private Declare Function CreateBrushIndirect Lib "GDI32.dll" (ByRef lpLogBrush As LogBrush) As Long Private Declare Function CreatePen Lib "GDI32.dll" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long Private Declare Function GetSysColorBrush Lib "User32.dll" (ByVal nIndex As Long) As Long Private Declare Function GetSysColor Lib "User32.dll" (ByVal nIndex As Long) As Long Private Declare Function CreateSolidBrush Lib "GDI32.dll" (ByVal crColor As Long) As Long Private Declare Function SelectObject Lib "GDI32.dll" (ByVal hDC As Long, ByVal hObject As Long) As Long Private Declare Function DeleteObject Lib "GDI32.dll" (ByVal hObject As Long) As Long Private Declare Function Polygon Lib "GDI32.dll" (ByVal hDC As Long, ByRef lpPoint As PointAPID, ByVal nCount As Long) As Long Private Declare Function MoveToEx Lib "GDI32.dll" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByRef lpPoint As Any) As Long Private Declare Function LineTo Lib "GDI32.dll" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long) As Long Private Declare Function Ellipse Lib "GDI32.dll" (ByVal hDC As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long Private Declare Function Rectangle Lib "GDI32.dll" (ByVal hDC As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long Private Declare Function RoundRect Lib "GDI32.dll" (ByVal hDC As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long Private Declare Function Polyline Lib "GDI32.dll" (ByVal hDC As Long, ByRef lpPoint As PointAPID, ByVal nCount As Long) As Long Private Declare Function Arc Lib "GDI32.dll" (ByVal hDC As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long, ByVal X4 As Long, ByVal Y4 As Long) As Long Private Declare Function Pie Lib "GDI32.dll" (ByVal hDC As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long, ByVal X4 As Long, ByVal Y4 As Long) As Long Private Declare Function SetArcDirection Lib "GDI32.dll" (ByVal hDC As Long, ByVal ArcDirection As Long) As Long Private Declare Function DrawText Lib "User32.dll" Alias "DrawTextA" (ByVal hDC As Long, ByVal lpStr As String, ByVal nCount As Long, ByRef lpRect As RectAPI, ByVal wFormat As Long) As Long Private Declare Function CreateFontIndirect Lib "GDI32.dll" Alias "CreateFontIndirectA" (ByRef lpLogFont As LogFont) As Long Private Declare Function MulDiv Lib "Kernel32.dll" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long Private Declare Function GetDeviceCaps Lib "GDI32.dll" (ByVal hDC As Long, ByVal nIndex As Long) As Long Private Declare Function SetTextColor Lib "GDI32.dll" (ByVal hDC As Long, ByVal crColor As Long) As Long Private Declare Function BeginPath Lib "GDI32.dll" (ByVal hDC As Long) As Long Private Declare Function EndPath Lib "GDI32.dll" (ByVal hDC As Long) As Long Private Declare Function StrokePath Lib "GDI32.dll" (ByVal hDC As Long) As Long Private Declare Function StrokeAndFillPath Lib "GDI32.dll" (ByVal hDC As Long) As Long Private Declare Function FillPath Lib "GDI32.dll" (ByVal hDC As Long) As Long Private Declare Function AbortPath Lib "GDI32.dll" (ByVal hDC As Long) As Long Private Const LF_FACESIZE As Long = 32 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(1 To LF_FACESIZE) As Byte End Type Private Type LogBrush lbStyle As Long lbColor As Long lbHatch As Long End Type Private Type RectAPI Left As Long Top As Long Right As Long Bottom As Long End Type Public Type PointAPID X As Long Y As Long End Type ' Font information Public Type typFontInf fiFontName As String fiSize As Long fiStringRot As Single fiCharRot As Single fiWeight As enDTWeight fiItalic As Boolean fiUnderline As Boolean fiStrikeOut As Boolean fiCharSet As enDTCharset fiPrecis As enDTPrecis fiClipPrecis As enDTClipPrecis fiQuality As enDTQuality fiPitch As enDTPitch fiFontFamily As enDTFontFamily End Type ' Text information Public Type typTextInf tiHAlign As enDTHAlign tiVAlign As enDTVAlign tiPrefix As enDTPrefix tiEllipsis As enDTEllipsis tiOutline As enDTOutline tiWordWrap As Boolean tiClipped As Boolean End Type ' System colours Public Enum enSysColour sclScrollBar = &H0 sclBackground = &H1 sclActiveCaption = &H2 sclInactiveCaption = &H3 sclMenu = &H4 sclWindow = &H5 sclWindowFrame = &H6 sclMenuText = &H7 sclWindowText = &H8 sclCaptionText = &H9 sclActiveBorder = &HA sclInactiveBorder = &HB sclAppWorkspace = &HC sclHighlight = &HD sclHighlightText = &HE sclBtnFace = &HF sclBtnShadow = &H10 sclGrayText = &H11 sclBtnText = &H12 sclInactiveCaptionText = &H13 sclBtnHighlight = &H14 End Enum ' Brush Styles Public Enum enDrawBS bsSolid = &H0 bsNull = &H1 bsHatched = &H2 bsPattern = &H3 End Enum ' Hatch Styles Public Enum enDrawHS hsHorizontal = &H0 ' ----- hsVertical = &H1 ' ||||| hsFDiagonal = &H2 ' \\\\\ hsBDiagonal = &H3 ' ///// hsCross = &H4 ' +++++ hsDiagCross = &H5 ' xxxxx hsSolid = &H8 End Enum ' Pen Styles Public Enum enDrawPS psSolid = &H0 psDash = &H1 ' ------- psDot = &H2 ' ....... psDashDot = &H3 ' _._._._ psDashDotDot = &H4 ' _.._.._ psNull = &H5 End Enum ' Text output align Public Enum enDTHAlign dthaLeft = &H0 dthaCenter = &H1 dthaRight = &H2 End Enum Public Enum enDTVAlign dtvaTop = &H0 dtvaVCenter = &H1 dtvaBottom = &H2 End Enum ' Interpretation of ampersand symbol within string Public Enum enDTPrefix dtpShowPrefix = &H0 ' Interprets and displays prefix dtpNoPrefix = &H1 ' Doesn't look for ampersands dtpHidePrefix = &H2 ' Interprets but doesn't display prefix dtpPrefixOnly = &H3 ' Only shows prefix End Enum ' Text ellipsis functionality Public Enum enDTEllipsis dtaNoEllipsis = &H0 ' C:\PathA\PathB\PathC\ dtePathEllipsis = &H1 ' C:\PathA\...\File.xyz dteEndEllipsis = &H2 ' C:\PathA\PathB\Pat... dteWordEllipsis = &H3 ' C:\PathA\PathB\... (Not quite, but you get the picture..) End Enum ' Ouline options Public Enum enDTOutline dtoJustFill = &H0 ' Only the fill is drawn dtoJustOutline = &H1 ' Only the outline is drawn dtoOutlineAndFill = &H2 ' Outline is drawn, then the fill over the top dtoFillAndOutline = &H3 ' Fill is drawn, then the outline over the top End Enum ' Font weight Public Enum enDTWeight dtwDontCare = &H0 dtwThin = &H1 dtwExtraLight = &H2 dtwLight = &H3 dtwNormal = &H4 dtwMedium = &H5 dtwSemiBold = &H6 dtwBold = &H7 dtwExtraBold = &H8 dtwHeavy = &H9 End Enum ' Font character set Public Enum enDTCharset dtcANSI = &H0 dtcDefault = &H1 dtcSymbol = &H2 dtcShiftJIS = &H3 dtcGB2312 = &H4 dtcHangeul = &H5 dtcChineseBig5 = &H6 dtcOEM = &H7 End Enum Public Enum enDTPrecis dtpDefault = &H0 dtpStroke = &H3 dtpTt = &H4 dtpDevice = &H5 dtpRaster = &H6 dtpTtOnly = &H7 dtpOutline = &H8 End Enum Public Enum enDTClipPrecis dtcpDefault = &H0 dtcpStroke = &H1 dtcpEmbedded = &H2 dtcpLHAngles = &H3 End Enum Public Enum enDTQuality dtqDefault = &H0 dtqDraft = &H1 dtqProof = &H2 dtqNonAntialiased = &H3 dtqAntialiased = &H4 dtqClearType = &H5 End Enum Public Enum enDTPitch dtpiDefault = &H0 dtpiFixed = &H1 dtpiVariable = &H2 End Enum Public Enum enDTFontFamily dtffDontCare = &H0 ' Don't care or don't know. dtffROMAN = &H1 ' Variable stroke width, serifed. dtffSWISS = &H2 ' Variable stroke width, sans-serifed. dtffMODERN = &H3 ' Constant stroke width, serifed or sans-serifed. dtffSCRIPT = &H4 ' Cursive, etc. dtffDECORATIVE = &H5 ' Old English, etc. End Enum ' Circle drawing constants Private Const Pi As Double = 3.14159265358979 Private Const TwoPi As Double = Pi * 2 ' Arc() and Pie() API constants Private Const AD_COUNTERCLOCKWISE As Long = 1 Private Const AD_CLOCKWISE As Long = 2 ' DrawText() API constants Private Const DT_TOP As Long = &H0 Private Const DT_LEFT As Long = &H0 Private Const DT_CENTER As Long = &H1 Private Const DT_RIGHT As Long = &H2 Private Const DT_VCENTER As Long = &H4 Private Const DT_BOTTOM As Long = &H8 Private Const DT_WORDBREAK As Long = &H10 Private Const DT_SINGLELINE As Long = &H20 Private Const DT_NOCLIP As Long = &H100 Private Const DT_NOPREFIX As Long = &H800 Private Const DT_PATH_ELLIPSIS As Long = &H4000& Private Const DT_END_ELLIPSIS As Long = &H8000& Private Const DT_WORD_ELLIPSIS As Long = &H40000 Private Const DT_HIDEPREFIX As Long = &H100000 Private Const DT_PREFIXONLY As Long = &H200000 ' CreateFont() constants Private Const ANSI_CHARSET As Long = 0 Private Const DEFAULT_CHARSET As Long = 1 Private Const SYMBOL_CHARSET As Long = 2 Private Const SHIFTJIS_CHARSET As Long = 128 Private Const GB2312_CHARSET As Long = 134 Private Const HANGEUL_CHARSET As Long = 129 Private Const CHINESEBIG5_CHARSET As Long = 136 Private Const OEM_CHARSET As Long = 255 Private Const CLIP_DEFAULT_PRECIS As Long = 0 Private Const CLIP_STROKE_PRECIS As Long = 2 Private Const CLIP_EMBEDDED As Long = 128 Private Const CLIP_LH_ANGLES As Long = 16 Private Const FF_DONTCARE As Long = 0 Private Const FF_ROMAN As Long = 16 Private Const FF_SWISS As Long = 32 Private Const FF_MODERN As Long = 48 Private Const FF_SCRIPT As Long = 64 Private Const FF_DECORATIVE As Long = 80 ' GetDeviceCaps() API constants Private Const LOGPIXELSY As Long = 90 ' Logical pixels/inch in Y ' Constructors Public Function NewPointAPI(ByVal inX As Long, ByVal inY As Long) As PointAPID With NewPointAPI ' PointAPI constructor .X = inX .Y = inY End With End Function Public Function NewCircPoint(ByRef inCent As PointAPID, ByVal inRad As Single, ByVal inDist As Integer) As PointAPID With NewCircPoint ' Returns a point on the specified circle .X = (Cos(inRad) * inDist) + inCent.X .Y = (Sin(inRad) * inDist) + inCent.Y End With End Function Public Function NewFontInf(ByRef inFontName As String, ByVal inSize As Long, _ Optional ByVal inStringRot As Single = 0, _ Optional ByVal inCharRot As Single = 0, _ Optional ByVal inWeight As enDTWeight = dtwDontCare, _ Optional ByVal inItalic As Boolean = False, _ Optional ByVal inUnderline As Boolean = False, _ Optional ByVal inStrikeOut As Boolean = False, _ Optional ByVal inCharSet As enDTCharset = dtcDefault, _ Optional ByVal inPrecis As enDTPrecis = dtpDefault, _ Optional ByVal inClipPrecis As enDTClipPrecis = dtcpDefault, _ Optional ByVal inQuality As enDTQuality = dtqDefault, _ Optional ByVal inPitch As enDTPitch = dtpiDefault, _ Optional ByVal inFontFamily As enDTFontFamily = dtffDontCare) As typFontInf With NewFontInf ' Font info type constructor .fiFontName = inFontName .fiSize = inSize .fiStringRot = inStringRot .fiCharRot = inCharRot .fiWeight = inWeight .fiItalic = inItalic .fiUnderline = inUnderline .fiStrikeOut = inStrikeOut .fiCharSet = inCharSet .fiPrecis = inPrecis .fiClipPrecis = inClipPrecis .fiQuality = inQuality .fiPitch = inPitch .fiFontFamily = inFontFamily End With End Function Public Function NewTextInf(Optional ByVal inHAlign As enDTHAlign = dthaLeft, _ Optional ByVal inVAlign As enDTVAlign = dtvaTop, _ Optional ByVal inPrefix As enDTPrefix = dtpShowPrefix, _ Optional ByVal inEllipsis As enDTEllipsis = dtaNoEllipsis, _ Optional ByVal inOutline As enDTOutline = dtoJustFill, _ Optional ByVal inWordWrap As Boolean = True, _ Optional ByVal inClipped As Boolean = True) As typTextInf With NewTextInf ' Text info constructor .tiHAlign = inHAlign .tiVAlign = inVAlign .tiPrefix = inPrefix .tiEllipsis = inEllipsis .tiOutline = inOutline .tiWordWrap = inWordWrap .tiClipped = inClipped End With End Function ' API drawing object routines Public Function PutNewBrush(ByVal TargDC As Long, ByVal bCol As Long, _ ByVal bHatch As enDrawHS, ByVal bStyle As enDrawBS, ByRef hOldBrush As Long) As Long Dim PolyBrush As LogBrush With PolyBrush ' Fill the brush attributes .lbColor = EvalCol(bCol) .lbHatch = bHatch .lbStyle = bStyle End With PutNewBrush = CreateBrushIndirect(PolyBrush) ' Create new brush hOldBrush = SelectObject(TargDC, PutNewBrush) ' Select the brush into the DC End Function Public Function PutNewSysBrush(ByVal TargDC As Long, ByVal ColIndex As enSysColour, ByRef hOldBrush As Long) As Long PutNewSysBrush = GetSysColorBrush(CLng(ColIndex)) ' Create system colour brush hOldBrush = SelectObject(TargDC, PutNewSysBrush) ' Select the brush into the DC End Function Public Function PutSimpleBrush(ByVal TargDC As Long, ByVal bCol As Long, ByRef hOldBrush As Long) As Long PutSimpleBrush = CreateSolidBrush(EvalCol(bCol)) ' Create new, solid brush hOldBrush = SelectObject(TargDC, PutSimpleBrush) ' Select the brush into the DC End Function Public Function PutNewPen(ByVal TargDC As Long, ByVal pStyle As enDrawPS, _ ByVal pWidth As Long, ByVal pCol As Long, ByRef hOldPen As Long) As Long PutNewPen = CreatePen(pStyle, pWidth, EvalCol(pCol)) ' Create new pen hOldPen = SelectObject(TargDC, PutNewPen) ' Select the pen into the DC End Function Public Sub RestoreBrush(ByVal TargDC As Long, ByVal hBrush As Long, ByVal hOldBrush As Long) Call SelectObject(TargDC, hOldBrush) ' Restore the original brush Call DeleteObject(hBrush) ' Delete the brush End Sub Public Sub RestorePen(ByVal TargDC As Long, ByVal hPen As Long, ByVal hOldPen As Long) Call SelectObject(TargDC, hOldPen) ' Restore the original pen Call DeleteObject(hPen) ' Delete the pen End Sub ' Drawing routines Public Function DrawDCPolygon(ByVal TargDC As Long, ByRef inPts() As PointAPID, _ Optional ByVal bCol As Long = vbWhite, _ Optional ByVal bHatch As enDrawHS = hsSolid, _ Optional ByVal bStyle As enDrawBS = bsSolid, _ Optional ByVal pStyle As enDrawPS = psSolid, _ Optional ByVal pWidth As Long = 1, _ Optional ByVal pCol As Long = vbBlack) As Long Dim hBrush As Long, hOldBrush As Long ' Draw a polygon + custom pen & brush Dim hPen As Long, hOldPen As Long hBrush = PutNewBrush(TargDC, bCol, bHatch, bStyle, hOldBrush) hPen = PutNewPen(TargDC, pStyle, pWidth, pCol, hOldPen) DrawDCPolygon = DrawDCPolygonS(TargDC, inPts()) ' Draw the polygon Call RestoreBrush(TargDC, hBrush, hOldBrush) Call RestorePen(TargDC, hPen, hOldPen) End Function Public Function DrawDCPolygonS(ByVal TargDC As Long, ByRef inPts() As PointAPID) As Long DrawDCPolygonS = Polygon(TargDC, inPts(0), UBound(inPts()) + 1) ' Draw the polygon End Function Public Function DrawDCLine(ByVal TargDC As Long, _ ByRef inStart As PointAPID, ByRef inEnd As PointAPID, _ Optional ByVal pStyle As enDrawPS = psSolid, _ Optional ByVal pWidth As Long = 1, _ Optional ByVal pCol As Long = vbBlack) As Long Dim hPen As Long, hOldPen As Long ' Draw a line + custom pen hPen = PutNewPen(TargDC, pStyle, pWidth, pCol, hOldPen) DrawDCLine = DrawDCLineS(TargDC, inStart, inEnd) ' Draw the line Call RestorePen(TargDC, hPen, hOldPen) End Function Public Function DrawDCLineS(ByVal TargDC As Long, ByRef inStart As PointAPID, ByRef inEnd As PointAPID) As Long Call MoveToEx(TargDC, inStart.X, inStart.Y, ByVal 0&) ' Move the start point DrawDCLineS = LineTo(TargDC, inEnd.X, inEnd.Y) ' Draw the line End Function Public Function DrawDCEllipse(ByVal TargDC As Long, _ ByRef inStart As PointAPID, ByRef inEnd As PointAPID, _ Optional ByVal bCol As Long = vbWhite, _ Optional ByVal bHatch As enDrawHS = hsSolid, _ Optional ByVal bStyle As enDrawBS = bsSolid, _ Optional ByVal pStyle As enDrawPS = psSolid, _ Optional ByVal pWidth As Long = 1, _ Optional ByVal pCol As Long = vbBlack) As Long Dim hBrush As Long, hOldBrush As Long ' Draw an ellipse + custom pen & brush Dim hPen As Long, hOldPen As Long hBrush = PutNewBrush(TargDC, bCol, bHatch, bStyle, hOldBrush) hPen = PutNewPen(TargDC, pStyle, pWidth, pCol, hOldPen) DrawDCEllipse = DrawDCEllipseS(TargDC, inStart, inEnd) ' Draw the ellipse Call RestoreBrush(TargDC, hBrush, hOldBrush) Call RestorePen(TargDC, hPen, hOldPen) End Function Public Function DrawDCEllipseS(ByVal TargDC As Long, ByRef inStart As PointAPID, ByRef inEnd As PointAPID) As Long DrawDCEllipseS = Ellipse(TargDC, inStart.X, inStart.Y, inEnd.X, inEnd.Y) ' Draw the ellipse End Function Public Function DrawDCRect(ByVal TargDC As Long, _ ByRef inStart As PointAPID, ByRef inEnd As PointAPID, _ Optional ByVal bCol As Long = vbWhite, _ Optional ByVal bHatch As enDrawHS = hsSolid, _ Optional ByVal bStyle As enDrawBS = bsSolid, _ Optional ByVal pStyle As enDrawPS = psSolid, _ Optional ByVal pWidth As Long = 1, _ Optional ByVal pCol As Long = vbBlack) As Long Dim hBrush As Long, hOldBrush As Long ' Draw a rectangle + custom pen & brush Dim hPen As Long, hOldPen As Long hBrush = PutNewBrush(TargDC, bCol, bHatch, bStyle, hOldBrush) hPen = PutNewPen(TargDC, pStyle, pWidth, pCol, hOldPen) DrawDCRect = DrawDCRectS(TargDC, inStart, inEnd) ' Draw the rectangle Call RestoreBrush(TargDC, hBrush, hOldBrush) Call RestorePen(TargDC, hPen, hOldPen) End Function Public Function DrawDCRectS(ByVal TargDC As Long, ByRef inStart As PointAPID, ByRef inEnd As PointAPID) As Long DrawDCRectS = Rectangle(TargDC, inStart.X, inStart.Y, inEnd.X, inEnd.Y) ' Draw the rectangle End Function Public Function DrawDCStar(ByVal TargDC As Long, ByRef inCent As PointAPID, _ ByRef inNumPts As Integer, ByVal inRadA As Integer, ByVal inRadB As Integer, _ Optional ByVal RotOffset As Integer = 0, _ Optional ByVal bCol As Long = vbWhite, _ Optional ByVal bHatch As enDrawHS = hsSolid, _ Optional ByVal bStyle As enDrawBS = bsSolid, _ Optional ByVal pStyle As enDrawPS = psSolid, _ Optional ByVal pWidth As Long = 1, _ Optional ByVal pCol As Long = vbBlack) As Long Dim hBrush As Long, hOldBrush As Long ' Draw a star + custom pen & brush Dim hPen As Long, hOldPen As Long hBrush = PutNewBrush(TargDC, bCol, bHatch, bStyle, hOldBrush) hPen = PutNewPen(TargDC, pStyle, pWidth, pCol, hOldPen) DrawDCStar = DrawDCStarS(TargDC, inCent, inNumPts, inRadA, inRadB, RotOffset) ' Draw the star Call RestoreBrush(TargDC, hBrush, hOldBrush) Call RestorePen(TargDC, hPen, hOldPen) End Function Public Function DrawDCStarS(ByVal TargDC As Long, ByRef inCent As PointAPID, _ ByVal inNumPts As Integer, ByVal inRadA As Integer, ByVal inRadB As Integer, _ Optional ByVal RotOffset As Integer = 0) As Long Dim StarPts() As PointAPID Dim MakePts As Integer Dim RadOffset As Single ReDim StarPts((inNumPts * 2) - 1) As PointAPID RadOffset = (RotOffset / 360) * TwoPi ' Make the star points For MakePts = 0 To inNumPts - 1 StarPts(MakePts * 2) = NewCircPoint(inCent, ((MakePts / inNumPts) * TwoPi) + RadOffset, inRadA) StarPts((MakePts * 2) + 1) = NewCircPoint(inCent, (((MakePts + 0.5) / inNumPts) * TwoPi) + RadOffset, inRadB) Next MakePts ' Draw the star DrawDCStarS = DrawDCPolygonS(TargDC, StarPts()) End Function Public Function DrawDCRoundRect(ByVal TargDC As Long, ByRef inStart As PointAPID, _ ByRef inEnd As PointAPID, ByRef inFillet As PointAPID, _ Optional ByVal bCol As Long = vbWhite, _ Optional ByVal bHatch As enDrawHS = hsSolid, _ Optional ByVal bStyle As enDrawBS = bsSolid, _ Optional ByVal pStyle As enDrawPS = psSolid, _ Optional ByVal pWidth As Long = 1, _ Optional ByVal pCol As Long = vbBlack) As Long Dim hBrush As Long, hOldBrush As Long ' Draw a rounded rectangle + custom pen & brush Dim hPen As Long, hOldPen As Long hBrush = PutNewBrush(TargDC, bCol, bHatch, bStyle, hOldBrush) hPen = PutNewPen(TargDC, pStyle, pWidth, pCol, hOldPen) DrawDCRoundRect = DrawDCRoundRectS(TargDC, inStart, inEnd, inFillet) ' Draw the rounded rectangle Call RestoreBrush(TargDC, hBrush, hOldBrush) Call RestorePen(TargDC, hPen, hOldPen) End Function Public Function DrawDCRoundRectS(ByVal TargDC As Long, ByRef inStart As PointAPID, _ ByRef inEnd As PointAPID, ByRef inFillet As PointAPID) As Long DrawDCRoundRectS = RoundRect(TargDC, inStart.X, inStart.Y, _ inEnd.X, inEnd.Y, inFillet.X, inFillet.Y) ' Draw the rounded rectangle End Function Public Function DrawDCPolyLine(ByVal TargDC As Long, ByRef inPts() As PointAPID, _ Optional ByVal pStyle As enDrawPS = psSolid, _ Optional ByVal pWidth As Long = 1, _ Optional ByVal pCol As Long = vbBlack) As Long Dim hPen As Long, hOldPen As Long ' Draw a polygon line + custom pen hPen = PutNewPen(TargDC, pStyle, pWidth, pCol, hOldPen) DrawDCPolyLine = DrawDCPolyLineS(TargDC, inPts()) ' Draw the polygon line Call RestorePen(TargDC, hPen, hOldPen) End Function Public Function DrawDCPolyLineS(ByVal TargDC As Long, ByRef inPts() As PointAPID) As Long DrawDCPolyLineS = Polyline(TargDC, inPts(0), UBound(inPts()) + 1) ' Draw the polygon line End Function Public Function DrawDCArc(ByVal TargDC As Long, ByRef inRectFrom As PointAPID, _ ByRef inRectTo As PointAPID, ByRef inArcFrom As PointAPID, ByRef inArcTo As PointAPID, _ Optional ByVal inClockwise As Boolean = False, _ Optional ByVal pStyle As enDrawPS = psSolid, _ Optional ByVal pWidth As Long = 1, _ Optional ByVal pCol As Long = vbBlack) As Long Dim hPen As Long, hOldPen As Long ' Draw an arc + custom pen hPen = PutNewPen(TargDC, pStyle, pWidth, pCol, hOldPen) DrawDCArc = DrawDCArcS(TargDC, inRectFrom, inRectTo, inArcFrom, inArcTo, inClockwise) ' Draw the arc Call RestorePen(TargDC, hPen, hOldPen) End Function Public Function DrawDCArcS(ByVal TargDC As Long, ByRef inRectFrom As PointAPID, ByRef inRectTo As PointAPID, _ ByRef inArcFrom As PointAPID, ByRef inArcTo As PointAPID, _ Optional ByVal inClockwise As Boolean = False) As Long Dim OldAD As Long OldAD = SetArcDirection(TargDC, IIf(inClockwise, AD_CLOCKWISE, AD_COUNTERCLOCKWISE)) ' Set arc direction DrawDCArcS = Arc(TargDC, inRectFrom.X, inRectFrom.Y, inRectTo.X, inRectTo.Y, _ inArcFrom.X, inArcFrom.Y, inArcTo.X, inArcTo.Y) ' Draw the arc Call SetArcDirection(TargDC, OldAD) End Function Public Function DrawDCPie(ByVal TargDC As Long, ByRef inRectFrom As PointAPID, _ ByRef inRectTo As PointAPID, ByRef inArcFrom As PointAPID, ByRef inArcTo As PointAPID, _ Optional ByVal inClockwise As Boolean = False, _ Optional ByVal bCol As Long = vbWhite, _ Optional ByVal bHatch As enDrawHS = hsSolid, _ Optional ByVal bStyle As enDrawBS = bsSolid, _ Optional ByVal pStyle As enDrawPS = psSolid, _ Optional ByVal pWidth As Long = 1, _ Optional ByVal pCol As Long = vbBlack) As Long Dim hBrush As Long, hOldBrush As Long ' Draw a pie segment + custom pen & brush Dim hPen As Long, hOldPen As Long hBrush = PutNewBrush(TargDC, bCol, bHatch, bStyle, hOldBrush) hPen = PutNewPen(TargDC, pStyle, pWidth, pCol, hOldPen) DrawDCPie = DrawDCPieS(TargDC, inRectFrom, inRectTo, inArcFrom, inArcTo, inClockwise) ' Draw the pie segment Call RestoreBrush(TargDC, hBrush, hOldBrush) Call RestorePen(TargDC, hPen, hOldPen) End Function Public Function DrawDCPieS(ByVal TargDC As Long, ByRef inRectFrom As PointAPID, _ ByRef inRectTo As PointAPID, ByRef inArcFrom As PointAPID, ByRef inArcTo As PointAPID, _ Optional ByVal inClockwise As Boolean = False) As Long Dim OldAD As Long OldAD = SetArcDirection(TargDC, IIf(inClockwise, AD_CLOCKWISE, AD_COUNTERCLOCKWISE)) ' Set arc direction DrawDCPieS = Pie(TargDC, inRectFrom.X, inRectFrom.Y, inRectTo.X, inRectTo.Y, _ inArcFrom.X, inArcFrom.Y, inArcTo.X, inArcTo.Y) ' Draw the pie segment Call SetArcDirection(TargDC, OldAD) End Function Public Function DrawDCText(ByVal TargDC As Long, ByRef inRectFrom As PointAPID, ByRef inRectTo As PointAPID, _ ByRef inText As String, ByRef inFont As typFontInf, inTextInfo As typTextInf, _ Optional ByVal bCol As Long = vbWhite, _ Optional ByVal bHatch As enDrawHS = hsSolid, _ Optional ByVal bStyle As enDrawBS = bsSolid, _ Optional ByVal pStyle As enDrawPS = psSolid, _ Optional ByVal pWidth As Long = 1, _ Optional ByVal pCol As Long = vbBlack) As Long Dim hFont As Long, OldFont As Long ' Draw a string + custom font, outline, pen & brush Dim hBrush As Long, hOldBrush As Long Dim hPen As Long, hOldPen As Long Dim FontDesc As LogFont Dim OldCol As Long Dim TempArr() As Byte Dim CopyChar As Long If (pStyle = psNull) Then ' Can't be outlined If (inTextInfo.tiOutline = dtoJustOutline) Then Exit Function ' Drawing nothing! inTextInfo.tiOutline = dtoJustFill ' Only fill End If If (bStyle = bsNull) Then ' Can't be filled If (inTextInfo.tiOutline = dtoJustFill) Then Exit Function ' Drawing nothing! inTextInfo.tiOutline = dtoJustOutline ' Only outline End If With inFont ' Create API logical font structure FontDesc.lfHeight = -MulDiv(.fiSize, GetDeviceCaps(TargDC, LOGPIXELSY), 72) FontDesc.lfWidth = 0 ' Auto-size based on height FontDesc.lfEscapement = -CLng(.fiStringRot * 10) FontDesc.lfOrientation = -CLng(.fiCharRot * 10) FontDesc.lfWeight = .fiWeight * 100 FontDesc.lfItalic = .fiItalic FontDesc.lfUnderline = .fiUnderline FontDesc.lfStrikeOut = .fiStrikeOut Select Case .fiCharSet Case dtcANSI: FontDesc.lfCharSet = ANSI_CHARSET Case dtcDefault: FontDesc.lfCharSet = DEFAULT_CHARSET Case dtcSymbol: FontDesc.lfCharSet = SYMBOL_CHARSET Case dtcShiftJIS: FontDesc.lfCharSet = SHIFTJIS_CHARSET Case dtcGB2312: FontDesc.lfCharSet = GB2312_CHARSET Case dtcHangeul: FontDesc.lfCharSet = HANGEUL_CHARSET Case dtcChineseBig5: FontDesc.lfCharSet = CHINESEBIG5_CHARSET Case dtcOEM: FontDesc.lfCharSet = OEM_CHARSET End Select Select Case .fiPrecis Case dtcpDefault: FontDesc.lfOutPrecision = CLIP_DEFAULT_PRECIS Case dtcpStroke: FontDesc.lfOutPrecision = CLIP_STROKE_PRECIS Case dtcpEmbedded: FontDesc.lfOutPrecision = CLIP_EMBEDDED Case dtcpLHAngles: FontDesc.lfOutPrecision = CLIP_LH_ANGLES End Select FontDesc.lfClipPrecision = .fiClipPrecis FontDesc.lfQuality = .fiQuality Select Case .fiFontFamily Case dtffDontCare: FontDesc.lfPitchAndFamily = FF_DONTCARE Case dtffROMAN: FontDesc.lfPitchAndFamily = FF_ROMAN Case dtffSWISS: FontDesc.lfPitchAndFamily = FF_SWISS Case dtffMODERN: FontDesc.lfPitchAndFamily = FF_MODERN Case dtffSCRIPT: FontDesc.lfPitchAndFamily = FF_SCRIPT Case dtffDECORATIVE: FontDesc.lfPitchAndFamily = FF_DECORATIVE End Select ' Shift family 2 places left and concatenate pitch FontDesc.lfPitchAndFamily = (FontDesc.lfPitchAndFamily * &H4) Or .fiPitch If (Len(.fiFontName)) Then TempArr() = StrConv(.fiFontName, vbFromUnicode) For CopyChar = 1 To IIf(Len(.fiFontName) < LF_FACESIZE, Len(.fiFontName), LF_FACESIZE) FontDesc.lfFaceName(CopyChar) = TempArr(CopyChar - 1) Next CopyChar End If End With hFont = CreateFontIndirect(FontDesc) OldFont = SelectObject(TargDC, hFont) ' Only create GDI Pen and Brush objects if text can't be simply drawn If (inTextInfo.tiOutline <> dtoJustFill) Then hBrush = PutNewBrush(TargDC, bCol, bHatch, bStyle, hOldBrush) hPen = PutNewPen(TargDC, pStyle, pWidth, pCol, hOldPen) Else OldCol = SetTextColor(TargDC, EvalCol(bCol)) End If DrawDCText = DrawDCTextS(TargDC, inRectFrom, inRectTo, inText, inTextInfo) If (inTextInfo.tiOutline <> dtoJustFill) Then Call RestoreBrush(TargDC, hBrush, hOldBrush) Call RestorePen(TargDC, hPen, hOldPen) Else Call SetTextColor(TargDC, OldCol) End If Call DeleteObject(SelectObject(TargDC, OldFont)) End Function Public Function DrawDCTextS(ByVal TargDC As Long, ByRef inRectFrom As PointAPID, _ ByRef inRectTo As PointAPID, ByRef inText As String, inTextInfo As typTextInf) As Long Dim DrawArea As RectAPI Dim GenFlags As Long Dim OldCol As Long Dim NoPath As Boolean Static InternalCall As Boolean DrawArea.Left = inRectFrom.X DrawArea.Top = inRectFrom.Y DrawArea.Right = inRectTo.X DrawArea.Bottom = inRectTo.Y ' Generate DrawText() flags GenFlags = IIf(inTextInfo.tiWordWrap, DT_WORDBREAK, DT_SINGLELINE) If (Not inTextInfo.tiClipped) Then GenFlags = GenFlags Or DT_NOCLIP Select Case inTextInfo.tiHAlign Case dthaLeft: GenFlags = GenFlags Or DT_LEFT Case dthaCenter: GenFlags = GenFlags Or DT_CENTER Case dthaRight: GenFlags = GenFlags Or DT_RIGHT End Select Select Case inTextInfo.tiVAlign Case dtvaTop: GenFlags = GenFlags Or DT_TOP Case dtvaVCenter: GenFlags = GenFlags Or DT_VCENTER Case dtvaBottom: GenFlags = GenFlags Or DT_BOTTOM End Select Select Case inTextInfo.tiPrefix Case dtpNoPrefix: GenFlags = GenFlags Or DT_NOPREFIX Case dtpHidePrefix: GenFlags = GenFlags Or DT_HIDEPREFIX Case dtpPrefixOnly: GenFlags = GenFlags Or DT_PREFIXONLY End Select Select Case inTextInfo.tiEllipsis Case dtePathEllipsis: GenFlags = GenFlags Or DT_PATH_ELLIPSIS Case dteEndEllipsis: GenFlags = GenFlags Or DT_END_ELLIPSIS Case dteWordEllipsis: GenFlags = GenFlags Or DT_WORD_ELLIPSIS End Select NoPath = (inTextInfo.tiOutline = dtoJustFill) And (Not InternalCall) If (Not NoPath) Then Call BeginPath(TargDC) DrawDCTextS = DrawText(TargDC, inText, Len(inText), DrawArea, GenFlags) If (DrawDCTextS) Then If (Not NoPath) Then Call EndPath(TargDC) Select Case inTextInfo.tiOutline Case dtoJustFill Call FillPath(TargDC) Case dtoJustOutline Call StrokePath(TargDC) Case dtoOutlineAndFill Call StrokePath(TargDC) InternalCall = True ' Unfortunately, GDI destroys the first path after it's been stroked, inTextInfo.tiOutline = dtoJustFill ' so we must call ourself again to draw the fill Call DrawDCTextS(TargDC, inRectFrom, inRectTo, inText, inTextInfo) inTextInfo.tiOutline = dtoOutlineAndFill InternalCall = False Case dtoFillAndOutline Call StrokeAndFillPath(TargDC) End Select End If Else ' Clean up path If (Not NoPath) Then Call AbortPath(TargDC) End If End Function Private Function EvalCol(ByVal inCol As Long) As Long If ((inCol And &HFFFFFF00) = &H80000000) Then EvalCol = GetSysColor(inCol And &HFF) Else EvalCol = inCol End Function