GDIPlus Rotate, Reflect and Skew (16K)
28 Mar 2003
First Posted
GDI+ Type Library (GDIPlus.TLB)
vbAccelerator - Contents of code file: frmGDIPlusTransform.frm
VERSION 5.00
Begin VB.Form frmGDIPlusTransform
Caption = "GDIPlus Rotate, Reflect and Skew Demonstration"
ClientHeight = 8430
ClientLeft = 60
ClientTop = 450
ClientWidth = 8535
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Icon = "frmGDIPlusTransform.frx":0000
LinkTopic = "Form1"
ScaleHeight = 8430
ScaleWidth = 8535
StartUpPosition = 3 'Windows Default
Begin VB.PictureBox picTools
Align = 1 'Align Top
BorderStyle = 0 'None
Height = 495
Left = 0
ScaleHeight = 495
ScaleWidth = 8535
TabIndex = 26
Top = 0
Width = 8535
Begin VB.TextBox txtFilename
Height = 375
Left = 840
TabIndex = 28
Top = 60
Width = 3615
End
Begin VB.CommandButton cmdOpen
Caption = "&Open..."
Height = 375
Left = 4500
TabIndex = 27
Top = 60
Width = 1035
End
Begin VB.Label lblFilename
Caption = "&Filename:"
Height = 315
Left = 60
TabIndex = 29
Top = 120
Width = 735
End
End
Begin VB.PictureBox picModify
Align = 4 'Align Right
BorderStyle = 0 'None
Height = 7935
Left = 5880
ScaleHeight = 7935
ScaleWidth = 2655
TabIndex = 0
Top = 495
Width = 2655
Begin VB.CheckBox chkUseAutoredraw
Caption = "Autoredraw"
Height = 195
Left = 60
TabIndex = 37
Top = 7620
Width = 2535
End
Begin VB.Frame fraTranslate
Caption = "&Translate"
Height = 975
Left = 0
TabIndex = 32
Top = 0
Width = 2595
Begin VB.HScrollBar hscTranslateY
Height = 255
LargeChange = 32
Left = 660
Max = 800
TabIndex = 34
Top = 600
Value = 400
Width = 1875
End
Begin VB.HScrollBar hscTranslateX
Height = 255
LargeChange = 32
Left = 660
Max = 800
TabIndex = 33
Top = 240
Value = 400
Width = 1875
End
Begin VB.Label lblTranslateY
Caption = "Y:"
Height = 255
Left = 120
TabIndex = 36
Top = 600
Width = 375
End
Begin VB.Label lblTranslateX
Caption = "X:"
Height = 255
Left = 120
TabIndex = 35
Top = 240
Width = 375
End
End
Begin VB.Frame fraSkew
Caption = "&Free Skew"
Height = 3975
Left = 0
TabIndex = 10
Top = 3540
Width = 2595
Begin VB.PictureBox picBtnBackgroundFixer
BorderStyle = 0 'None
Height = 435
Left = 660
ScaleHeight = 435
ScaleWidth = 1875
TabIndex = 30
Top = 3480
Width = 1875
Begin VB.CommandButton cmdSet
Caption = "&Set"
Height = 435
Left = 0
TabIndex = 31
Top = 0
Width = 1095
End
End
Begin VB.TextBox txtTopLeftX
Height = 315
Left = 660
TabIndex = 16
Text = "0"
Top = 600
Width = 1875
End
Begin VB.TextBox txtTopLeftY
Height = 315
Left = 660
TabIndex = 15
Text = "0"
Top = 960
Width = 1875
End
Begin VB.TextBox txtTopRightX
Height = 315
Left = 660
TabIndex = 14
Text = "0"
Top = 1680
Width = 1875
End
Begin VB.TextBox txtTopRightY
Height = 315
Left = 660
TabIndex = 13
Text = "0"
Top = 2040
Width = 1875
End
Begin VB.TextBox txtBottomLeftX
Height = 315
Left = 660
TabIndex = 12
Text = "0"
Top = 2760
Width = 1875
End
Begin VB.TextBox txtBottomLeftY
Height = 315
Left = 660
TabIndex = 11
Text = "0"
Top = 3120
Width = 1875
End
Begin VB.Label lblTopLeft
Caption = "&Top Left Corner:"
Height = 255
Left = 120
TabIndex = 25
Top = 360
Width = 2355
End
Begin VB.Label lblTopLeftY
Caption = "Y:"
Height = 255
Left = 120
TabIndex = 24
Top = 1020
Width = 375
End
Begin VB.Label lblTopLeftX
Caption = "X:"
Height = 255
Left = 120
TabIndex = 23
Top = 660
Width = 375
End
Begin VB.Label Label3
Caption = "Top &Right Corner"
Height = 255
Left = 120
TabIndex = 22
Top = 1440
Width = 2355
End
Begin VB.Label lblTopRightY
Caption = "Y:"
Height = 255
Left = 120
TabIndex = 21
Top = 2100
Width = 375
End
Begin VB.Label lblTopRightX
Caption = "X:"
Height = 255
Left = 120
TabIndex = 20
Top = 1740
Width = 375
End
Begin VB.Label Label6
Caption = "&Bottom Left Corner"
Height = 255
Left = 120
TabIndex = 19
Top = 2520
Width = 2355
End
Begin VB.Label lblBottomLeftY
Caption = "Y:"
Height = 255
Left = 120
TabIndex = 18
Top = 3180
Width = 375
End
Begin VB.Label lblBottomLeftX
Caption = "X:"
Height = 255
Left = 120
TabIndex = 17
Top = 2820
Width = 375
End
End
Begin VB.Frame fraStretch
Caption = "&Stretch"
Height = 1395
Left = 0
TabIndex = 4
Top = 1080
Width = 2595
Begin VB.CheckBox chkKeepProportions
Caption = "&Keep Proportions"
Height = 255
Left = 660
TabIndex = 7
Top = 1020
Value = 1 'Checked
Width = 1935
End
Begin VB.HScrollBar hscX
Height = 255
LargeChange = 10
Left = 660
Max = 200
TabIndex = 6
Top = 300
Value = 100
Width = 1875
End
Begin VB.HScrollBar hscY
Height = 255
LargeChange = 10
Left = 660
Max = 200
TabIndex = 5
Top = 660
Value = 100
Width = 1875
End
Begin VB.Label lblXStretch
Caption = "X:"
Height = 255
Left = 120
TabIndex = 9
Top = 300
Width = 375
End
Begin VB.Label lblYStretch
Caption = "Y:"
Height = 255
Left = 120
TabIndex = 8
Top = 660
Width = 375
End
End
Begin VB.Frame fraRotate
Caption = "&Rotate"
Height = 855
Left = 0
TabIndex = 1
Top = 2580
Width = 2595
Begin VB.HScrollBar hscAngle
Height = 255
LargeChange = 30
Left = 660
Max = 360
TabIndex = 2
Top = 300
Width = 1875
End
Begin VB.Label lblAngle
Caption = "Angle:"
Height = 255
Left = 120
TabIndex = 3
Top = 300
Width = 495
End
End
End
End
Attribute VB_Name = "frmGDIPlusTransform"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private m_img As GDIPImage
Private m_bNoRefresh As Boolean
Private m_destPoints() As POINTL
Private Const DEGTORAD = 0.0349
Private Sub refreshView()
If (chkUseAutoredraw.Value = Checked) Then
Me.Cls
Form_Paint
Me.Refresh
Else
Me.Refresh
End If
End Sub
Private Function setPoint(txtThis As TextBox, ByRef pt As Long) As Long
Dim lErr As Long
On Error Resume Next
pt = txtThis.Text
lErr = Err.Number
If Not (lErr = 0) Then
txtThis.ForeColor = vbRed
setPoint = lErr
Else
txtThis.ForeColor = vbWindowText
End If
End Function
Private Sub setPoints()
If (m_bNoRefresh) Then
Exit Sub
End If
Dim pTmp() As POINTL
Dim lErr As Long
ReDim pTmp(0 To 2) As POINTL
lErr = lErr Or setPoint(txtTopLeftX, pTmp(0).x)
lErr = lErr Or setPoint(txtTopLeftY, pTmp(0).y)
lErr = lErr Or setPoint(txtTopRightX, pTmp(1).x)
lErr = lErr Or setPoint(txtTopRightY, pTmp(1).y)
lErr = lErr Or setPoint(txtBottomLeftX, pTmp(2).x)
lErr = lErr Or setPoint(txtBottomLeftY, pTmp(2).y)
If (lErr = 0) Then
Dim fScaleX As Single
Dim fScaleY As Single
Dim i As Long
Dim xOffset As Long
Dim yOffset As Long
Dim fSinAngle As Single
Dim fCosAngle As Single
Dim fx As Single
fSinAngle = Sin(hscAngle.Value * DEGTORAD)
fCosAngle = Cos(hscAngle.Value * DEGTORAD)
xOffset = 4
yOffset = (picTools.Top + picTools.Height) \ Screen.TwipsPerPixelY + 4
fScaleX = 10 ^ ((hscX.Value - 100) / 100#)
fScaleY = 10 ^ ((hscY.Value - 100) / 100#)
For i = 0 To 2
' Get set points:
LSet m_destPoints(i) = pTmp(i)
' Scale:
m_destPoints(i).x = fScaleX * m_destPoints(i).x
m_destPoints(i).y = fScaleY * m_destPoints(i).y
' Apply the rotation matrix:
fx = m_destPoints(i).x * fCosAngle + m_destPoints(i).y * fSinAngle
m_destPoints(i).y = -m_destPoints(i).x * fSinAngle + m_destPoints(i).y
* fCosAngle
m_destPoints(i).x = fx
' Translate according to top-left of view area:
m_destPoints(i).x = m_destPoints(i).x + xOffset + hscTranslateX.Value
- 400
m_destPoints(i).y = m_destPoints(i).y + yOffset + hscTranslateY.Value
- 400
Next i
End If
refreshView
End Sub
Private Sub resetControls()
m_bNoRefresh = True
hscX.Value = 100
hscY.Value = 100
hscAngle.Value = 0
txtTopLeftX.Text = "0"
txtTopLeftY.Text = "0"
txtTopRightX.Text = "0"
txtTopRightY.Text = "0"
txtBottomLeftX.Text = "0"
txtBottomLeftY.Text = "0"
m_bNoRefresh = False
enableTools False
End Sub
Private Sub enableTools(ByVal bState)
Dim ctl As Control
On Error Resume Next
For Each ctl In Me.Controls
enableControlWithContainer ctl, picModify, bState
Next
End Sub
Private Sub enableControlWithContainer(ctl As Control, ctlContainer As Control,
ByVal bState As Boolean)
Dim ctlCont As Control
Set ctlCont = ctl.Container
Do While Not (ctlCont Is Nothing)
If (ctlCont Is ctlContainer) Then
ctl.Enabled = bState
Exit Do
End If
Set ctlCont = ctlCont.Container
Loop
End Sub
Private Sub chkUseAutoredraw_Click()
Me.AutoRedraw = True
End Sub
Private Sub cmdOpen_Click()
Dim g As New GCommonDialog
Dim sFile As String
If (g.VBGetOpenFileName(sFile, _
Filter:="Image Files
(*.JPG;*.PNG;*.TIF;*.GIF;*.BMP)|*.JPG;*.PNG;*.TIF;*.GIF;*.BMP|JPEG Files
(*.JPG)|*.JPG|PNG Files (*.PNG)|*.PNG|TIFF Files (*.TIF)|*.TIF|GIF Files
(*.GIF)|*.GIF|Bitmaps (*.BMP)|*.BMP|All Files (*.*)|*.*", _
DefaultExt:="JPG", _
Owner:=Me.hwnd)) Then
txtFilename.Text = sFile
resetControls
On Error GoTo errorHandler
If (m_img Is Nothing) Then
Set m_img = New GDIPImage
End If
m_img.FromFile sFile
txtTopRightX.Text = m_img.Width
txtBottomLeftY.Text = m_img.Height
cmdSet_Click
enableTools True
End If
Exit Sub
errorHandler:
MsgBox "An error occurred trying to show the information for this file: " &
Err.Description, vbInformation
Set m_img = Nothing
Exit Sub
End Sub
Private Sub cmdSet_Click()
setPoints
End Sub
Private Sub Form_Load()
If Not (GDIPlusCreate()) Then
MsgBox "GDI+ Initialisation Failed.", vbExclamation
Dim ctl As Control
For Each ctl In Me.Controls
On Error Resume Next
ctl.Enabled = False
Next
Else
ReDim m_destPoints(0 To 2) As POINTL
enableTools False
End If
End Sub
Private Sub Form_Paint()
'
If Not m_img Is Nothing Then
Dim gfx As New GDIPGraphics
gfx.FromHDC Me.hdc
gfx.InterpolationMode = InterpolationModeBicubic
gfx.SmoothingMode = SmoothingModeHighQuality
gfx.DrawImageAffineL m_img, m_destPoints, 3
gfx.Dispose
End If
'
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
If Not m_img Is Nothing Then
m_img.Dispose
Set m_img = Nothing
End If
GDIPlusDispose
End Sub
Private Sub Form_Resize()
If (chkUseAutoredraw.Value = Checked) Then
refreshView
End If
End Sub
Private Sub hscAngle_Change()
setPoints
End Sub
Private Sub hscAngle_Scroll()
hscAngle_Change
End Sub
Private Sub hscTranslateX_Change()
setPoints
End Sub
Private Sub hscTranslateX_Scroll()
hscTranslateX_Change
End Sub
Private Sub hscTranslateY_Change()
setPoints
End Sub
Private Sub hscTranslateY_Scroll()
hscTranslateY_Change
End Sub
Private Sub hscX_Change()
If (chkKeepProportions.Value = Checked) Then
hscY.Value = hscX.Value
End If
setPoints
End Sub
Private Sub hscX_Scroll()
hscX_Change
End Sub
Private Sub hscY_Change()
If (chkKeepProportions.Value = Checked) Then
hscX.Value = hscY.Value
End If
setPoints
End Sub
Private Sub hscY_Scroll()
hscY_Change
End Sub
Private Sub picTools_Resize()
On Error Resume Next
Dim lSize As Long
lSize = picTools.ScaleWidth - txtFilename.Left - cmdOpen.Width - 4 *
Screen.TwipsPerPixelX
txtFilename.Width = lSize
cmdOpen.Left = txtFilename.Left + txtFilename.Width + 2 *
Screen.TwipsPerPixelX
End Sub
Private Sub txtBottomLeftX_Change()
Dim lJunk As Long
setPoint txtBottomLeftX, lJunk
End Sub
Private Sub txtBottomLeftY_Change()
Dim lJunk As Long
setPoint txtBottomLeftY, lJunk
End Sub
Private Sub txtTopLeftX_Change()
Dim lJunk As Long
setPoint txtTopLeftX, lJunk
End Sub
Private Sub txtTopLeftY_Change()
Dim lJunk As Long
setPoint txtTopLeftY, lJunk
End Sub
Private Sub txtTopRightX_Change()
Dim lJunk As Long
setPoint txtTopRightX, lJunk
End Sub
Private Sub txtTopRightY_Change()
Dim lJunk As Long
setPoint txtTopRightY, lJunk
End Sub
