home *** CD-ROM | disk | FTP | other *** search
/ Dan Appleman's Visual Bas…s Guide to the Win32 API / Dan.Applmans.Visual.Basic.5.0.Programmers.Guide.To.The.Win32.API.1997.Ziff-Davis.Press.CD / VB5PG32.mdf / vbpg32 / samples5 / ch08 / path.frm (.txt) < prev    next >
Encoding:
Visual Basic Form  |  1997-02-16  |  10.3 KB  |  266 lines
  1. VERSION 5.00
  2. Begin VB.Form frmPaths 
  3.    Caption         =   "Paths Example"
  4.    ClientHeight    =   5355
  5.    ClientLeft      =   1095
  6.    ClientTop       =   1515
  7.    ClientWidth     =   6465
  8.    ClipControls    =   0   'False
  9.    LinkTopic       =   "Form1"
  10.    PaletteMode     =   1  'UseZOrder
  11.    ScaleHeight     =   5355
  12.    ScaleWidth      =   6465
  13.    Begin VB.CommandButton cmdWhich 
  14.       Caption         =   "Stroke"
  15.       Height          =   435
  16.       Index           =   3
  17.       Left            =   180
  18.       TabIndex        =   6
  19.       Top             =   4740
  20.       Width           =   1155
  21.    End
  22.    Begin VB.CommandButton cmdExit 
  23.       Caption         =   "E&xit"
  24.       Height          =   435
  25.       Left            =   5100
  26.       TabIndex        =   5
  27.       Top             =   4200
  28.       Width           =   1155
  29.    End
  30.    Begin VB.CommandButton cmdWhich 
  31.       Caption         =   "Bitmap"
  32.       Height          =   435
  33.       Index           =   2
  34.       Left            =   2940
  35.       TabIndex        =   4
  36.       Top             =   4200
  37.       Width           =   1155
  38.    End
  39.    Begin VB.CommandButton cmdWhich 
  40.       Caption         =   "Color Circles"
  41.       Height          =   435
  42.       Index           =   1
  43.       Left            =   1560
  44.       TabIndex        =   3
  45.       Top             =   4200
  46.       Width           =   1155
  47.    End
  48.    Begin VB.CommandButton cmdWhich 
  49.       Caption         =   "Radial Lines"
  50.       Height          =   435
  51.       Index           =   0
  52.       Left            =   180
  53.       TabIndex        =   2
  54.       Top             =   4200
  55.       Width           =   1155
  56.    End
  57.    Begin VB.PictureBox Out 
  58.       ClipControls    =   0   'False
  59.       FillColor       =   &H000000FF&
  60.       BeginProperty Font 
  61.          Name            =   "Times New Roman"
  62.          Size            =   63.75
  63.          Charset         =   0
  64.          Weight          =   700
  65.          Underline       =   0   'False
  66.          Italic          =   0   'False
  67.          Strikethrough   =   0   'False
  68.       EndProperty
  69.       FontTransparent =   0   'False
  70.       ForeColor       =   &H00FF0000&
  71.       Height          =   3915
  72.       Left            =   180
  73.       ScaleHeight     =   259
  74.       ScaleMode       =   3  'Pixel
  75.       ScaleWidth      =   403
  76.       TabIndex        =   0
  77.       Top             =   120
  78.       Width           =   6075
  79.    End
  80.    Begin VB.PictureBox pctBmp 
  81.       AutoRedraw      =   -1  'True
  82.       AutoSize        =   -1  'True
  83.       Height          =   1830
  84.       Left            =   60
  85.       Picture         =   "path.frx":0000
  86.       ScaleHeight     =   120
  87.       ScaleMode       =   3  'Pixel
  88.       ScaleWidth      =   160
  89.       TabIndex        =   1
  90.       Top             =   60
  91.       Visible         =   0   'False
  92.       Width           =   2430
  93.    End
  94. Attribute VB_Name = "frmPaths"
  95. Attribute VB_GlobalNameSpace = False
  96. Attribute VB_Creatable = False
  97. Attribute VB_PredeclaredId = True
  98. Attribute VB_Exposed = False
  99. Option Explicit
  100. ' Copyright 
  101.  1997 by Desaware Inc. All Rights Reserved
  102. Public dl&, savedDC&, WhichDrawing%
  103. Private allCos!(90), allSin!(90)
  104. '**********************************
  105. '**  Type Definitions:
  106. #If Win32 Then
  107. Private Type RECT
  108.     left As Long
  109.     top As Long
  110.     right As Long
  111.     bottom As Long
  112. End Type
  113. Private Type POINTAPI
  114.     x As Long
  115.     y As Long
  116. End Type
  117. #End If 'WIN32 Types
  118. #If Win32 Then
  119. Private Const SRCPAINT& = &HEE0086
  120. Private Const SRCCOPY& = &HCC0020
  121. Private Const SRCAND& = &H8800C6
  122. Private Const SRCERASE& = &H440328
  123. Private Const SRCINVERT& = &H660046
  124. Private Const TRANSPARENT& = 1
  125. Private Const RGN_COPY& = 5
  126. Private Const RGN_AND& = 1
  127. Private Const RGN_DIFF& = 4
  128. Private Const RGN_XOR& = 3
  129. Private Const RGN_OR& = 2
  130. Private Const BLACK_BRUSH = 4
  131. Private Const BLACK_PEN = 7
  132. '  Pen Styles
  133. Private Const PS_SOLID = 0
  134. Private Const PS_DASH = 1                    '  -------
  135. Private Const PS_DOT = 2                     '  .......
  136. Private Const PS_DASHDOT = 3                 '  _._._._
  137. Private Const PS_DASHDOTDOT = 4              '  _.._.._
  138. Private Const PS_NULL = 5
  139. Private Const PS_INSIDEFRAME = 6
  140. Private Const PS_USERSTYLE = 7
  141. Private Const PS_ALTERNATE = 8
  142. Private Const PS_STYLE_MASK = &HF
  143. #End If 'WIN32
  144. '**********************************
  145. '**  Function Declarations:
  146. #If Win32 Then
  147. Private Declare Function SelectObject& Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long)
  148. Private Declare Function DeleteObject& Lib "gdi32" (ByVal hObject As Long)
  149. Private Declare Function CreatePen& Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long)
  150. Private Declare Function GetStockObject& Lib "gdi32" (ByVal nIndex As Long)
  151. 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)
  152. Private Declare Function Ellipse& Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long)
  153. Private Declare Function MoveToEx& Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, Prev As POINTAPI)
  154. Private Declare Function LineTo& Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long)
  155. Private Declare Function GetLastError& Lib "kernel32" ()
  156. Private Declare Function GetRgnBox& Lib "gdi32" (ByVal hdc As Long, bounds As RECT)
  157. Private Declare Function GetClipRgn& Lib "gdi32" (ByVal hdc As Long, ByVal hRegion As Long)
  158. Private Declare Function SaveDC& Lib "gdi32" (ByVal hdc As Long)
  159. Private Declare Function RestoreDC& Lib "gdi32" (ByVal hdc As Long, ByVal nSavedDC As Long)
  160. Private Declare Function DrawText& Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long)
  161. Private Declare Function BeginPath& Lib "gdi32" (ByVal hdc As Long)
  162. Private Declare Function EndPath& Lib "gdi32" (ByVal hdc As Long)
  163. Private Declare Function AbortPath& Lib "gdi32" (ByVal hdc As Long)
  164. Private Declare Function CloseFigure& Lib "gdi32" (ByVal hdc As Long)
  165. Private Declare Function StrokeAndFillPath& Lib "gdi32" (ByVal hdc As Long)
  166. Private Declare Function StrokePath& Lib "gdi32" (ByVal hdc As Long)
  167. Private Declare Function GetPath& Lib "gdi32" (ByVal hdc As Long, lpPoint As POINTAPI, lpTypes As Byte, ByVal nSize As Long)
  168. Private Declare Function FlattenPath& Lib "gdi32" (ByVal hdc As Long)
  169. Private Declare Function SelectClipPath& Lib "gdi32" (ByVal hdc As Long, ByVal iMode As Long)
  170. Private Declare Function PathToRegion& Lib "gdi32" (ByVal hdc As Long)
  171. Private Declare Function CreateRectRgn& Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long)
  172. Private Declare Function SelectClipRgn& Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long)
  173. Private Declare Function FillRgn& Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long, ByVal hBrush As Long)
  174. Private Declare Function BitBlt& Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, _
  175.     ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, _
  176.     ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long)
  177. #End If 'WIN32
  178. Private Sub cmdExit_Click()
  179.     Unload Me
  180. End Sub
  181. Private Sub cmdWhich_Click(Index As Integer)
  182.     WhichDrawing% = Index
  183.     Out.Refresh
  184. End Sub
  185. Private Sub Form_Load()
  186.     Dim i%
  187.     Screen.MousePointer = 11
  188.     For i% = 1 To 90
  189.         allCos!(i%) = Cos(CSng(i%) / 180! * 3.14159)
  190.         allSin!(i%) = Sin(CSng(i%) / 180! * 3.14159)
  191.     Next i%
  192.     Screen.MousePointer = 0
  193. End Sub
  194. Private Sub out_Paint()
  195.     Dim usepen&, oldpen&
  196.     Dim dl&
  197.     Dim myRect As RECT, radius&, i%, j%, myPoint As POINTAPI
  198.     savedDC& = SaveDC&(Out.hdc)
  199.     Select Case WhichDrawing%
  200.     Case 0 ' Lines ( black on gray)
  201.         dl& = BeginPath&(Out.hdc)
  202.            dl& = TextOut&(Out.hdc, 50&, 30&, "Radial", 6)
  203.            dl& = TextOut&(Out.hdc, 80&, 120&, "Lines", 5)
  204.         dl& = EndPath&(Out.hdc)
  205.         dl& = SelectClipPath&(Out.hdc, RGN_COPY)
  206.         radius& = 600
  207.         
  208.         ' Don't delete stock pens
  209.         usepen = GetStockObject(BLACK_PEN)
  210.         oldpen = SelectObject(Out.hdc, usepen)
  211.         For i% = 1 To 90
  212.              dl& = MoveToEx&(Out.hdc, Out.ScaleWidth, 0, myPoint)
  213.              dl& = LineTo&(Out.hdc, Out.ScaleWidth - allCos!(i%) * CSng(radius&), 0 + allSin!(i%) * CSng(radius&))
  214.         Next i%
  215.     Case 1 ' Color Circles:
  216.         dl& = BeginPath&(Out.hdc)
  217.             dl& = TextOut&(Out.hdc, 80&, 30&, "Color", 5)
  218.             dl& = TextOut&(Out.hdc, 50&, 120&, "Circles", 7)
  219.         dl& = EndPath&(Out.hdc)
  220.         dl& = SelectClipPath&(Out.hdc, RGN_COPY)
  221.         usepen = CreatePen(PS_SOLID, 1, QBColor(12))
  222.         oldpen = SelectObject(Out.hdc, usepen)
  223.         For i% = 0 To 40
  224.             dl& = Ellipse&(Out.hdc, i% * Out.ScaleWidth / 80, i% * Out.ScaleHeight / 80, Out.ScaleWidth - (i% * Out.ScaleWidth / 80), Out.ScaleHeight - (i% * Out.ScaleHeight / 80))
  225.         Next i%
  226.         ' Select out the pen before deleting
  227.         dl = SelectObject(Out.hdc, oldpen)
  228.         dl = DeleteObject(usepen)
  229.         
  230.     Case 2 ' Bitmap:
  231.         dl& = BeginPath&(Out.hdc)
  232.         dl& = TextOut&(Out.hdc, 80&, 30&, "Color", 5)
  233.         dl& = TextOut&(Out.hdc, 50&, 120&, "Bitmap", 6)
  234.         dl& = EndPath&(Out.hdc)
  235.         dl& = SelectClipPath&(Out.hdc, RGN_COPY)
  236.         TileBitmaps
  237.     Case 3
  238.         dl& = BeginPath&(Out.hdc)
  239.         dl& = TextOut&(Out.hdc, 50&, 30&, "Stroke", 6)
  240.         dl& = TextOut&(Out.hdc, 80&, 120&, "Path", 4)
  241.         dl& = EndPath&(Out.hdc)
  242.         StrokeThePath
  243.     End Select
  244.         
  245.     dl& = RestoreDC&(Out.hdc, savedDC&)
  246. End Sub
  247. ' Tile the bitmap onto the output picture
  248. Public Sub TileBitmaps()
  249.     Dim dl&, i%, j%
  250.     For i% = 0 To 5
  251.         For j% = 0 To 5
  252.             dl& = BitBlt&(Out.hdc, 0 + i% * 160, 0 + j% * 120, 160, 120, pctBmp.hdc, 0, 0, SRCCOPY)
  253.         Next j%
  254.     Next i%
  255. End Sub
  256. Public Sub StrokeThePath()
  257.     Dim dl&, usepen&, oldpen&
  258.     ' Create a green pen
  259.     usepen = CreatePen(PS_SOLID, 3, RGB(0, 255, 0))
  260.     oldpen = SelectObject(Out.hdc, usepen)
  261.     dl = StrokePath(Out.hdc)
  262.     ' Select out the pen before deleting
  263.     dl = SelectObject(Out.hdc, oldpen)
  264.     dl = DeleteObject(usepen)
  265. End Sub
  266.