Example of using PowerPoint VBA graphics drawing library
by world coordinates (using GDI32 instructions version)
Basic Drawing Functions - Rectangles, Ellipses, Line Styles
Ex.1 Draw some boxes while changing colors
Sub ColorBox()
Dim c, myBoxSize, myInterval
Dim x1, y1, x2, y2
monhdc = GetForegroundWindow()
myhdc = GetDC(monhdc)
If myhdc = 0 Then Exit Sub
InitializeGraphics ' Declaration of using graphics library
myBoxSize = 24
myInterval = myBoxSize + 6
x1 = 10
y1 = 10
For c = 0 To 14
DrawRectangle x1, y1, x1 + myBoxSize, y1 + myBoxSize, QBColor(c) ' Draw a box
x1 = x1 + myInterval
Next c
x1 = 10
y1 = 60
For c = 0 To 14
DrawRectangleFill x1, y1, x1 + myBoxSize, y1 + myBoxSize, QBColor(c) ' Draw a filled box
x1 = x1 + myInterval
Next c
x1 = 10
y1 = 100
For c = 0 To 14
' Draw a box with different fill color and line color
DrawRectangleFill x1, y1, x1 + myBoxSize, y1 + myBoxSize, QBColor(c), QBColor(c + 1)
x1 = x1 + myInterval
Next c
End Sub
Ex.2 Draw some circles while changing colors
Sub ColorCircle()
Dim c, r, d
Dim x, y
monhdc = GetForegroundWindow()
myhdc = GetDC(monhdc)
If myhdc = 0 Then Exit Sub
r = 20
d = 50
InitializeGraphics ' Declaration of using graphics library
c = 0 ' Initialize color number
For y = 30 To 100 Step d
For x = 40 To 400 Step d
DrawOval x, y, r, r, QBColor(c) ' Draw a circle
c = c + 1
Next x
Next y
c = 0
For y = 140 To 210 Step d
For x = 40 To 400 Step d
DrawOvalFill x, y, r, r, QBColor(c) ' Draw a filled circle
c = c + 1
Next x
Next y
End Sub
Ex.3 Draw an ellipse
Sub DrawOvalTest()
monhdc = GetForegroundWindow()
myhdc = GetDC(monhdc)
If myhdc = 0 Then Exit Sub
InitializeGraphics ' Declaration of using graphics library
' Draw Oval
DrawOval 100, 80, 70, 30, vbGreen
' Draw Circle
DrawOval 200, 80, 30, 30, vbBlack
' Specification of radius ratio of oval and line color by default
DrawOval 260, 80, 50
' Specification of line and fill color by QBColor function
DrawOvalFill 360, 80, 40, , QBColor(9), QBColor(12)
End Sub
Ex.4 Change the line width and type
Sub LineStyleTest()
Dim c, y
Const x1 = 30
Const x2 = 330
Const d = 20
monhdc = GetForegroundWindow()
myhdc = GetDC(monhdc)
If myhdc = 0 Then Exit Sub
InitializeGraphics ' Declaration of using graphics library
c = QBColor(0)
y = 30
gLineWidth = 3 ' Line Width 3 pixel
DrawLine x1, y, x2, y, c ' Draw a Line
y = y + d
gLineWidth = 10 ' Line Width 10 pixel
DrawLine x1, y, x2, y, c ' Draw a Line
y = y + d
gLineWidth = 1 ' Line Width 1 pixel
DrawLine x1, y, x2, y, c ' Draw a Line
y = y + d
SetLineStyle PS_DASH
DrawLine x1, y, x2, y, c
y = y + d
SetLineStyle PS_DOT
DrawLine x1, y, x2, y, c
y = y + d
SetLineStyle PS_DASHDOT
DrawLine x1, y, x2, y, c
y = y + d
SetLineStyle PS_DASHDOTDOT
DrawLine x1, y, x2, y, c
End Sub
Sub ColorBox() Dim c, myBoxSize, myInterval Dim x1, y1, x2, y2 monhdc = GetForegroundWindow() myhdc = GetDC(monhdc) If myhdc = 0 Then Exit Sub InitializeGraphics ' Declaration of using graphics library myBoxSize = 24 myInterval = myBoxSize + 6 x1 = 10 y1 = 10 For c = 0 To 14 DrawRectangle x1, y1, x1 + myBoxSize, y1 + myBoxSize, QBColor(c) ' Draw a box x1 = x1 + myInterval Next c x1 = 10 y1 = 60 For c = 0 To 14 DrawRectangleFill x1, y1, x1 + myBoxSize, y1 + myBoxSize, QBColor(c) ' Draw a filled box x1 = x1 + myInterval Next c x1 = 10 y1 = 100 For c = 0 To 14 ' Draw a box with different fill color and line color DrawRectangleFill x1, y1, x1 + myBoxSize, y1 + myBoxSize, QBColor(c), QBColor(c + 1) x1 = x1 + myInterval Next c End Sub
Sub ColorCircle() Dim c, r, d Dim x, y monhdc = GetForegroundWindow() myhdc = GetDC(monhdc) If myhdc = 0 Then Exit Sub r = 20 d = 50 InitializeGraphics ' Declaration of using graphics library c = 0 ' Initialize color number For y = 30 To 100 Step d For x = 40 To 400 Step d DrawOval x, y, r, r, QBColor(c) ' Draw a circle c = c + 1 Next x Next y c = 0 For y = 140 To 210 Step d For x = 40 To 400 Step d DrawOvalFill x, y, r, r, QBColor(c) ' Draw a filled circle c = c + 1 Next x Next y End Sub
Ex.3 Draw an ellipse
Sub DrawOvalTest()
monhdc = GetForegroundWindow()
myhdc = GetDC(monhdc)
If myhdc = 0 Then Exit Sub
InitializeGraphics ' Declaration of using graphics library
' Draw Oval
DrawOval 100, 80, 70, 30, vbGreen
' Draw Circle
DrawOval 200, 80, 30, 30, vbBlack
' Specification of radius ratio of oval and line color by default
DrawOval 260, 80, 50
' Specification of line and fill color by QBColor function
DrawOvalFill 360, 80, 40, , QBColor(9), QBColor(12)
End Sub
Ex.4 Change the line width and type
Sub LineStyleTest()
Dim c, y
Const x1 = 30
Const x2 = 330
Const d = 20
monhdc = GetForegroundWindow()
myhdc = GetDC(monhdc)
If myhdc = 0 Then Exit Sub
InitializeGraphics ' Declaration of using graphics library
c = QBColor(0)
y = 30
gLineWidth = 3 ' Line Width 3 pixel
DrawLine x1, y, x2, y, c ' Draw a Line
y = y + d
gLineWidth = 10 ' Line Width 10 pixel
DrawLine x1, y, x2, y, c ' Draw a Line
y = y + d
gLineWidth = 1 ' Line Width 1 pixel
DrawLine x1, y, x2, y, c ' Draw a Line
y = y + d
SetLineStyle PS_DASH
DrawLine x1, y, x2, y, c
y = y + d
SetLineStyle PS_DOT
DrawLine x1, y, x2, y, c
y = y + d
SetLineStyle PS_DASHDOT
DrawLine x1, y, x2, y, c
y = y + d
SetLineStyle PS_DASHDOTDOT
DrawLine x1, y, x2, y, c
End Sub
Sub DrawOvalTest() monhdc = GetForegroundWindow() myhdc = GetDC(monhdc) If myhdc = 0 Then Exit Sub InitializeGraphics ' Declaration of using graphics library ' Draw Oval DrawOval 100, 80, 70, 30, vbGreen ' Draw Circle DrawOval 200, 80, 30, 30, vbBlack ' Specification of radius ratio of oval and line color by default DrawOval 260, 80, 50 ' Specification of line and fill color by QBColor function DrawOvalFill 360, 80, 40, , QBColor(9), QBColor(12) End Sub
Sub LineStyleTest() Dim c, y Const x1 = 30 Const x2 = 330 Const d = 20 monhdc = GetForegroundWindow() myhdc = GetDC(monhdc) If myhdc = 0 Then Exit Sub InitializeGraphics ' Declaration of using graphics library c = QBColor(0) y = 30 gLineWidth = 3 ' Line Width 3 pixel DrawLine x1, y, x2, y, c ' Draw a Line y = y + d gLineWidth = 10 ' Line Width 10 pixel DrawLine x1, y, x2, y, c ' Draw a Line y = y + d gLineWidth = 1 ' Line Width 1 pixel DrawLine x1, y, x2, y, c ' Draw a Line y = y + d SetLineStyle PS_DASH DrawLine x1, y, x2, y, c y = y + d SetLineStyle PS_DOT DrawLine x1, y, x2, y, c y = y + d SetLineStyle PS_DASHDOT DrawLine x1, y, x2, y, c y = y + d SetLineStyle PS_DASHDOTDOT DrawLine x1, y, x2, y, c End Sub