Advanced Line Procedure With Many Options

Category:

Screen/Graphics

Type:

Snippets

Difficulty:

Advanced

Author:

Daniel Cohen Gindi

Version Compatibility: Visual Basic 5

More information:

This is an advanced Line procedure!, its allows you to many options that the VB not allowing you, and its difficult to do that with API functions!

It is best to set form's autoredraw property to true when using this. Because it supplies so many options, you should play with it a bit and learn how to use it for your purposes.

Instructions: Copy the declarations and code below and paste directly into your VB project.

Declarations:
Private Declare Function LineTo Lib "gdi32" _ (ByVal hDc As Long, ByVal X As Long, _ ByVal Y As Long) As Long Private Declare Function MoveToEx Lib "gdi32" _ (ByVal hDc As Long, ByVal X As Long, ByVal Y As Long, _ lpPoint As POINTAPI) 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 SelectObject Lib "gdi32" _ (ByVal hDc As Long, ByVal hObject As Long) As Long Private Declare Function CreateBrushIndirect Lib "gdi32" _ (lpLogBrush As LOGBRUSH) As Long Private Declare Function DeleteObject Lib "gdi32" _ (ByVal hObject As Long) As Long Private Declare Function RoundRect Lib "gdi32" _ (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 Type LOGBRUSH lbStyle As Long lbColor As Long lbHatch As Long End Type Private Type POINTAPI X As Long Y As Long End Type Public Enum BBF B = 1 BF = 2 End Enum Public Enum LFillStyle HS_None = 0 HS_HORIZONTAL = 1 HS_VERTICAL = 2 HS_UpwardDiagnoal = 3 HS_DownwardDiagnoal = 4 HS_CROSS = 5 HS_DiagnoalCross = 6 End Enum Private Const BS_HATCHED = 2 Private Const NULL_BRUSH = 5 Private Const NULL_PEN = 8

Code:

' Note that the hDc is a property of forms and controls,
' and the name of the procedure is "Lines (...)"
Public Sub Lines(ByVal hDc As Long, _
       ByVal X1 As Long, ByVal Y1 As Long, _
       ByVal X2 As Long, ByVal Y2 As Long, _
       Optional ByVal crColor As Long, _
       Optional ByVal dwStyle As BBF, _
       Optional ByVal RoundWidth As Long, _
       Optional ByVal RoundHeight As Long, _
       Optional ByVal dwFillColor, _
       Optional ByVal PenWidth As Long, _
       Optional ByVal dwFillStyle As LFillStyle, _
       Optional ByVal InitPrinter As Boolean = False)

Dim MTPnts As POINTAPI
Dim lBRSH As LOGBRUSH
Dim Pen As Long
Dim Brush As Long
Dim OldPen As Long
Dim OldBrush As Long

If InitPrinter = True Then
    Printer.PSet (-100, -100), RGB(255, 255, 255)
    hDc = Printer.hDc
End If

Pen = CreatePen(0, PenWidth, crColor)
OldPen = SelectObject(hDc, Pen)
Select Case dwStyle
Case 0
    MoveToEx hDc, X1 / 15, Y1 / 15, MTPnts
    LineTo hDc, X2 / 15, Y2 / 15
Case 1
    RoundRect hDc, X1 / 15, Y1 / 15, X2 / 15, Y2 / 15, _
       RoundWidth, RoundHeight
Case 2
    If Not IsMissing(dwFillColor) Then
        lBRSH.lbColor = dwFillColor
        If dwFillStyle > 0 And dwFillStyle < 7 Then
            lBRSH.lbStyle = BS_HATCHED
            lBRSH.lbHatch = dwFillStyle - 1
        End If
        Brush = CreateBrushIndirect(lBRSH)
        OldBrush = SelectObject(hDc, Brush)
    End If
    RoundRect hDc, X1 / 15, Y1 / 15, X2 / 15, Y2 / 15, _
       RoundWidth, RoundHeight
End Select

If OldPen <> 0 Then SelectObject hDc, OldPen
OldPen = DeleteObject(Pen)
If OldBrush <> 0 Then SelectObject hDc, OldBrush
OldBrush = DeleteObject(Brush)

End Sub