www.pudn.com > PausVbMorpher.zip > FrmMain.frm
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "comdlg32.ocx"
Begin VB.Form FrmMesh
Caption = "VBMorpher:"
ClientHeight = 4110
ClientLeft = 165
ClientTop = 450
ClientWidth = 8805
LinkTopic = "Form1"
ScaleHeight = 4110
ScaleWidth = 8805
StartUpPosition = 2 'CenterScreen
Begin VB.TextBox TxtSave
Height = 1095
Left = 6720
MultiLine = -1 'True
TabIndex = 21
Top = 1920
Visible = 0 'False
Width = 495
End
Begin MSComDlg.CommonDialog CD
Left = 6720
Top = 3120
_ExtentX = 847
_ExtentY = 847
_Version = 393216
CancelError = -1 'True
End
Begin VB.PictureBox PicProgress
AutoRedraw = -1 'True
FillColor = &H00800080&
ForeColor = &H00800080&
Height = 255
Left = 6960
ScaleHeight = 195
ScaleWidth = 1155
TabIndex = 18
Top = 3600
Width = 1215
End
Begin VB.PictureBox PicBack
BackColor = &H00C00000&
Height = 3255
Left = 120
ScaleHeight = 213
ScaleMode = 3 'Pixel
ScaleWidth = 429
TabIndex = 1
Top = 600
Width = 6495
Begin VB.PictureBox P
Appearance = 0 'Flat
AutoRedraw = -1 'True
AutoSize = -1 'True
BackColor = &H00FF0000&
BorderStyle = 0 'None
ForeColor = &H80000008&
Height = 1800
Index = 2
Left = 240
LinkItem = "s"
ScaleHeight = 120
ScaleMode = 3 'Pixel
ScaleWidth = 168
TabIndex = 22
Top = 960
Visible = 0 'False
Width = 2520
End
Begin VB.PictureBox PicBlock
Height = 255
Left = 6000
ScaleHeight = 195
ScaleWidth = 195
TabIndex = 5
Top = 2880
Width = 255
End
Begin VB.VScrollBar VScroll1
Height = 2055
Left = 5880
TabIndex = 4
Top = 240
Width = 255
End
Begin VB.HScrollBar HScroll1
Height = 255
Left = 600
TabIndex = 3
Top = 2760
Width = 2655
End
Begin VB.PictureBox P
Appearance = 0 'Flat
AutoRedraw = -1 'True
AutoSize = -1 'True
BackColor = &H00000000&
BorderStyle = 0 'None
ForeColor = &H80000008&
Height = 1800
Index = 0
Left = 0
LinkItem = "s"
ScaleHeight = 120
ScaleMode = 3 'Pixel
ScaleWidth = 168
TabIndex = 2
Top = 0
Width = 2520
End
Begin VB.PictureBox P
Appearance = 0 'Flat
AutoRedraw = -1 'True
AutoSize = -1 'True
BackColor = &H00000000&
BorderStyle = 0 'None
ForeColor = &H80000008&
Height = 1800
Index = 1
Left = 2640
LinkItem = "s"
ScaleHeight = 120
ScaleMode = 3 'Pixel
ScaleWidth = 168
TabIndex = 19
Top = 0
Width = 2520
End
End
Begin VB.PictureBox PicTools
Height = 555
Left = 0
ScaleHeight = 33
ScaleMode = 3 'Pixel
ScaleWidth = 589
TabIndex = 0
Top = 0
Width = 8895
Begin VB.CommandButton CmdTools
Enabled = 0 'False
Height = 495
Index = 9
Left = 7770
Style = 1 'Graphical
TabIndex = 15
Top = 0
Width = 135
End
Begin VB.PictureBox PicColor
AutoRedraw = -1 'True
AutoSize = -1 'True
Height = 510
Index = 1
Left = 6120
Picture = "FrmMain.frx":0000
ScaleHeight = 450
ScaleWidth = 1605
TabIndex = 20
Top = 0
Width = 1665
End
Begin VB.PictureBox PicColor
AutoRedraw = -1 'True
AutoSize = -1 'True
Height = 510
Index = 0
Left = 6120
Picture = "FrmMain.frx":263A
ScaleHeight = 450
ScaleWidth = 1605
TabIndex = 17
Top = 0
Width = 1665
End
Begin VB.CommandButton CmdTools
BackColor = &H00FFFFFF&
Height = 495
Index = 0
Left = 0
Picture = "FrmMain.frx":4C74
Style = 1 'Graphical
TabIndex = 6
ToolTipText = "Open start image"
Top = 0
Width = 855
End
Begin VB.CommandButton CmdTools
BackColor = &H00FFFFFF&
Height = 495
Index = 1
Left = 840
Picture = "FrmMain.frx":57F6
Style = 1 'Graphical
TabIndex = 7
ToolTipText = "Open end image"
Top = 0
Width = 855
End
Begin VB.CommandButton CmdTools
BackColor = &H00FFFFFF&
Height = 495
Index = 2
Left = 1680
Picture = "FrmMain.frx":63F0
Style = 1 'Graphical
TabIndex = 8
ToolTipText = "Open"
Top = 0
Width = 855
End
Begin VB.CommandButton CmdTools
BackColor = &H00FFFFFF&
DisabledPicture = "FrmMain.frx":6AF2
Height = 495
Index = 3
Left = 2520
Picture = "FrmMain.frx":6F44
Style = 1 'Graphical
TabIndex = 9
ToolTipText = "Save"
Top = 0
Width = 855
End
Begin VB.CommandButton CmdTools
Enabled = 0 'False
Height = 495
Index = 4
Left = 3360
Style = 1 'Graphical
TabIndex = 10
Top = 0
Width = 135
End
Begin VB.CommandButton CmdTools
BackColor = &H00FFFFFF&
DisabledPicture = "FrmMain.frx":7396
Height = 495
Index = 5
Left = 3480
Picture = "FrmMain.frx":796C
Style = 1 'Graphical
TabIndex = 11
ToolTipText = "Options"
Top = 0
Width = 855
End
Begin VB.CommandButton CmdTools
BackColor = &H00FFFFFF&
DisabledPicture = "FrmMain.frx":7F86
Height = 495
Index = 6
Left = 4320
Picture = "FrmMain.frx":8AA8
Style = 1 'Graphical
TabIndex = 12
ToolTipText = "Morph!"
Top = 0
Width = 855
End
Begin VB.CommandButton CmdTools
BackColor = &H00FFFFFF&
Height = 495
Index = 7
Left = 5160
Picture = "FrmMain.frx":95CA
Style = 1 'Graphical
TabIndex = 13
ToolTipText = "Open morph viewer"
Top = 0
Width = 855
End
Begin VB.CommandButton CmdTools
Enabled = 0 'False
Height = 495
Index = 8
Left = 6000
Style = 1 'Graphical
TabIndex = 14
Top = 0
Width = 135
End
Begin VB.CommandButton CmdTools
BackColor = &H00FFFFFF&
Height = 495
Index = 10
Left = 7890
Picture = "FrmMain.frx":9D78
Style = 1 'Graphical
TabIndex = 16
ToolTipText = "Help"
Top = 0
Width = 855
End
End
End
Attribute VB_Name = "FrmMesh"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Public TotalFrames As Long 'Total number of frames -1
Public Ht 'number of horizontal triangle boxes
Public Vt 'number of vertical triangle boxes
Public CircleRad As Long 'the radius of the circle used to indicate the vertices of the triangle
Public MorphTitle As String 'the title of the morph
Public MorphDirectory As String 'the directory to save the morphed images
Public StartFile As String 'path name of the start file
Public EndFile As String 'path name of end file
Dim Found As Boolean 'has the user clicked on one of the vertices?
Dim DragX As Long 'the X vertex being dragged
Dim DragY As Long 'the y vertex being dragged
Dim OpenMorph As String 'the name of the currently opened morph file
Dim LineColor As Long 'the color of the sides of the triangles
Dim CircleColor As Long 'color of the circular points
Dim MorphFileChanged As Boolean 'has the current file been changed?
Private Sub LoadMorphs()
TotalFrames = 19
Ht = 5: Vt = 5
CircleRad = 5
MorphTitle = "Morph"
MorphDirectory = App.Path
OpenMorph = ""
LineColor = vbRed
CircleColor = vbGreen
MorphFileChanged = False
End Sub
Public Sub RefreshMesh()
P(0).Cls
P(1).Cls
DrawMesh P(0), sTM
DrawMesh P(1), eTM
End Sub
Private Sub CheckFilesValid(Restart As Boolean)
P(0).Cls
P(1).Cls
If StartFile <> "" And EndFile <> "" Then
If P(0).ScaleHeight <> P(1).ScaleHeight Or P(0).ScaleWidth <> P(1).ScaleWidth Then
MsgBox "The images are not of same size, so they can't be morphed, select files of the same diamensions", vbInformation Or vbOKOnly, "Same diamensions needed!"
MorphFileChanged = False
CmdTools(3).Enabled = False
CmdTools(5).Enabled = False
CmdTools(6).Enabled = False
PicColor(0).Visible = True
PicColor(1).Visible = False
Else
CmdTools(3).Enabled = True
CmdTools(5).Enabled = True
CmdTools(6).Enabled = True
PicColor(1).Visible = True
PicColor(0).Visible = False
P(2).Width = P(1).Width
P(2).Height = P(1).Height
If Restart Then
GenerateTriangles
MorphFileChanged = True
End If
RefreshMesh
Exit Sub
End If
End If
CmdTools(3).Enabled = False
CmdTools(5).Enabled = False
CmdTools(6).Enabled = False
PicColor(0).Visible = True
PicColor(1).Visible = False
MorphFileChanged = False
OpenMorph = ""
End Sub
Private Sub HandleScrollBars()
P(0).Move 0, 0
P(1).Move P(0).ScaleWidth + 10, 0
HScroll1.Move 0, PicBack.ScaleHeight - HScroll1.Height, PicBack.ScaleWidth - VScroll1.Width
VScroll1.Move PicBack.ScaleWidth - VScroll1.Width, 0, VScroll1.Width, PicBack.ScaleHeight - HScroll1.Height
PicBlock.Move HScroll1.Width, VScroll1.Height, VScroll1.Width, HScroll1.Height
If (P(0).ScaleWidth + 10 + P(1).ScaleWidth) > VScroll1.Left Then
HScroll1.Max = (P(0).ScaleWidth + 10 + P(1).ScaleWidth) - VScroll1.Left
HScroll1.Enabled = True
HScroll1 = 0
Else
HScroll1.Enabled = False
End If
If P(0).ScaleHeight > HScroll1.Top Or P(1).ScaleHeight > HScroll1.Top Then
If P(0).ScaleHeight > VScroll1.Top Then VScroll1.Max = P(0).ScaleHeight - HScroll1.Top Else VScroll1.Max = P(1).ScaleHeight - HScroll1.Top
VScroll1.Enabled = True
VScroll1 = 0
Else
VScroll1.Enabled = False
End If
End Sub
'this sub will convert the points into triangles
Private Sub MakeTriangleList(StartPoints() As PointSng, EndPoints() As PointSng, StartOutputList() As Triangle, EndOutputList() As Triangle)
I = 0
For Y = 1 To UBound(StartPoints, 2) - 1
For X = 1 To UBound(StartPoints, 1) - 1
StartOutputList(I).V(0).X = StartPoints(X, Y).X
StartOutputList(I).V(0).Y = StartPoints(X, Y).Y
StartOutputList(I).V(1).X = StartPoints(X, Y + 1).X
StartOutputList(I).V(1).Y = StartPoints(X, Y + 1).Y
StartOutputList(I).V(2).X = StartPoints(X + 1, Y + 1).X
StartOutputList(I).V(2).Y = StartPoints(X + 1, Y + 1).Y
StartOutputList(I + 1).V(0).X = StartPoints(X, Y).X
StartOutputList(I + 1).V(0).Y = StartPoints(X, Y).Y
StartOutputList(I + 1).V(1).X = StartPoints(X + 1, Y).X
StartOutputList(I + 1).V(1).Y = StartPoints(X + 1, Y).Y
StartOutputList(I + 1).V(2).X = StartPoints(X + 1, Y + 1).X
StartOutputList(I + 1).V(2).Y = StartPoints(X + 1, Y + 1).Y
I = I + 2
Next X
Next Y
I = 0
For Y = 1 To UBound(EndPoints, 2) - 1
For X = 1 To UBound(EndPoints, 1) - 1
EndOutputList(I).V(0).X = EndPoints(X, Y).X
EndOutputList(I).V(0).Y = EndPoints(X, Y).Y
EndOutputList(I).V(1).X = EndPoints(X, Y + 1).X
EndOutputList(I).V(1).Y = EndPoints(X, Y + 1).Y
EndOutputList(I).V(2).X = EndPoints(X + 1, Y + 1).X
EndOutputList(I).V(2).Y = EndPoints(X + 1, Y + 1).Y
EndOutputList(I + 1).V(0).X = EndPoints(X, Y).X
EndOutputList(I + 1).V(0).Y = EndPoints(X, Y).Y
EndOutputList(I + 1).V(1).X = EndPoints(X + 1, Y).X
EndOutputList(I + 1).V(1).Y = EndPoints(X + 1, Y).Y
EndOutputList(I + 1).V(2).X = EndPoints(X + 1, Y + 1).X
EndOutputList(I + 1).V(2).Y = EndPoints(X + 1, Y + 1).Y
I = I + 2
Next X
Next Y
End Sub
Private Sub DrawMesh(P As PictureBox, TM() As PointSng)
dx = (P.ScaleWidth - 1) / (UBound(TM, 1) + 1 - 2)
dy = (P.ScaleHeight - 1) / (UBound(TM, 2) + 1 - 2)
For Y = 1 To UBound(TM, 2) - 1
For X = 1 To UBound(TM, 1) - 1
P.Line (TM(X, Y).X, TM(X, Y).Y)-(TM(X, Y + 1).X, TM(X, Y + 1).Y), LineColor
P.Line (TM(X, Y + 1).X, TM(X, Y + 1).Y)-(TM(X + 1, Y + 1).X, TM(X + 1, Y + 1).Y), LineColor
P.Line (TM(X + 1, Y + 1).X, TM(X + 1, Y + 1).Y)-(TM(X + 1, Y).X, TM(X + 1, Y).Y), LineColor
P.Line (TM(X + 1, Y).X, TM(X + 1, Y).Y)-(TM(X, Y).X, TM(X, Y).Y), LineColor
P.Line (TM(X, Y).X, TM(X, Y).Y)-(TM(X + 1, Y + 1).X, TM(X + 1, Y + 1).Y), LineColor
Next X
Next Y
For Y = 1 To UBound(TM, 2)
For X = 1 To UBound(TM, 1)
P.Circle (TM(X, Y).X, TM(X, Y).Y), CircleRad, CircleColor
Next X
Next Y
End Sub
Private Sub CmdTools_Click(Index As Integer)
Select Case Index
Case 0
On Error GoTo ex
CD.DialogTitle = "Open start image"
CD.Filter = "All pictures(*.bmp, *.jpg)|*.bmp;*.jpg"
CD.FileName = ""
CD.ShowOpen
OpenMorph = ""
P(0).Picture = LoadPicture(CD.FileName)
StartFile = CD.FileName
HandleScrollBars
CheckFilesValid (True)
Case 1
On Error GoTo ex
CD.DialogTitle = "Open end image"
CD.Filter = "All pictures(*.bmp, *.jpg)|*.bmp;*.jpg"
CD.FileName = ""
CD.ShowOpen
OpenMorph = ""
P(1).Picture = LoadPicture(CD.FileName)
EndFile = CD.FileName
HandleScrollBars
CheckFilesValid (True)
Case 2
On Error GoTo ex
CD.DialogTitle = "Open morph"
CD.Filter = "Morph file(*.mrp)|*.mrp"
CD.FileName = ""
CD.ShowOpen
ret = ReadMorphFile(CD.FileName, P(0), P(1), sTM, eTM)
If ret = "ok" Then
HandleScrollBars
CheckFilesValid (False)
OpenMorph = CD.FileName
MorphFileChanged = False
Else
MsgBox ret, vbExclamation Or vbOKOnly, "Error in forph file"
StartFile = ""
EndFile = ""
HandleScrollBars
CheckFilesValid (True)
End If
Case 3
If OpenMorph = "" Then
On Error GoTo ex
CD.DialogTitle = "Save morph"
CD.Filter = "Morph file(*.mrp)|*.mrp"
CD.FileName = ""
CD.ShowSave
SaveMorph CD.FileName, StartFile, EndFile, sTM, eTM, TxtSave
OpenMorph = CD.FileName
MorphFileChanged = False
Else
SaveMorph OpenMorph, StartFile, EndFile, sTM, eTM, TxtSave
End If
Case 5
FrmOptions.Show 1
Case 6
MorphIt
Case 7
FrmViewer.Show 1
Case 10
FrmHelp.Show 1
End Select
ex:
Me.Caption = "VBMorpher: " & OpenMorph
End Sub
Public Sub GenerateTriangles()
'Generate the triangle mesh
'One set of triangles are not visible on either sides so add two to the number of horizontal and vertical triangles
ReDim sTM(Ht - 1 + 2, Vt - 1 + 2)
ReDim eTM(Ht - 1 + 2, Vt - 1 + 2)
dx = (P(0).ScaleWidth) / (UBound(sTM, 1) + 1 - 2)
dy = (P(0).ScaleHeight) / (UBound(sTM, 2) + 1 - 2)
For Y = -dy To P(0).ScaleHeight - 1 + dy Step dy
For X = -dx To P(0).ScaleWidth - 1 + dx Step dx
sTM(X / dx + 1, Y / dy + 1).X = X
sTM(X / dx + 1, Y / dy + 1).Y = Y
eTM(X / dx + 1, Y / dy + 1).X = X
eTM(X / dx + 1, Y / dy + 1).Y = Y
Next X
Next Y
'set the number of triangles
ReDim StartTriangles(Ht * Vt * 2 - 1)
ReDim EndTriangles(Ht * Vt * 2 - 1)
End Sub
Private Sub Form_Load()
LoadMorphs
CheckFilesValid (True)
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Cancel = False
If MorphFileChanged = True Then
ret = MsgBox("The current file has been changed. Do you want to save it?", vbQuestion Or vbYesNoCancel, "Save file")
If ret = vbYes Then CmdTools_Click 3
If ret = vbCancel Then Cancel = True
End If
End Sub
Private Sub Form_Resize()
On Error Resume Next
PicTools.Move 0, 0, ScaleWidth
PicBack.Move 0, PicTools.Height, ScaleWidth, ScaleHeight - PicTools.Height - PicProgress.ScaleHeight
PicProgress.Move 0, PicBack.Height + PicBack.Top, ScaleWidth
HandleScrollBars
End Sub
Private Sub HScroll1_Change()
P(0).Move -HScroll1.Value
P(1).Move P(0).Left + P(0).ScaleWidth + 10
End Sub
Private Sub HScroll1_Scroll()
HScroll1_Change
End Sub
Private Sub P_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 And CmdTools(6).Enabled Then
Found = False
For j = 1 To UBound(sTM, 2)
For I = 1 To UBound(sTM, 1)
If Index = 0 Then
If CheckCircleCollision(sTM(I, j).X, sTM(I, j).Y, CircleRad, X, Y) Then
MorphFileChanged = True
P(1).Circle (eTM(DragX, DragY).X, eTM(DragX, DragY).Y), CircleRad, CircleColor
Found = True
DragX = I
DragY = j
P(1).Circle (eTM(DragX, DragY).X, eTM(DragX, DragY).Y), CircleRad, LineColor
Exit Sub
End If
Else
If CheckCircleCollision(eTM(I, j).X, eTM(I, j).Y, CircleRad, X, Y) Then
MorphFileChanged = True
P(0).Circle (sTM(DragX, DragY).X, sTM(DragX, DragY).Y), CircleRad, CircleColor
Found = True
DragX = I
DragY = j
P(0).Circle (sTM(DragX, DragY).X, sTM(DragX, DragY).Y), CircleRad, LineColor
Exit Sub
End If
End If
Next I
Next j
End If
End Sub
Private Sub P_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then
If Found = True Then
If Index = 0 Then
If X >= 0 And X <= P(0).ScaleWidth Then sTM(DragX, DragY).X = X
If Y >= 0 And Y <= P(0).ScaleHeight Then sTM(DragX, DragY).Y = Y
P(0).Cls
DrawMesh P(0), sTM
Else
If X >= 0 And X <= P(1).ScaleWidth Then eTM(DragX, DragY).X = X
If Y >= 0 And Y <= P(1).ScaleHeight Then eTM(DragX, DragY).Y = Y
P(1).Cls
DrawMesh P(1), eTM
End If
End If
End If
End Sub
Private Sub P_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
Found = False
End Sub
Private Sub PicColor_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
If Index <> 1 Then Exit Sub
If Button = 1 Then LineColor = PicColor(1).Point(X, Y)
If Button = 2 Then CircleColor = PicColor(1).Point(X, Y)
RefreshMesh
End Sub
Private Sub PicColor_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
If Index <> 1 Then Exit Sub
If Button = 1 Then LineColor = PicColor(1).Point(X, Y)
If Button = 2 Then CircleColor = PicColor(1).Point(X, Y)
RefreshMesh
End Sub
Private Sub VScroll1_Change()
P(0).Move 0, -VScroll1.Value
P(1).Top = P(0).Top
End Sub
Private Sub VScroll1_Scroll()
VScroll1_Change
End Sub
Private Sub MorphIt()
Dim I As Long
If Right(MorphDirectory, 1) = "\" Then MorphDirectory = Mid(MorphDirectory, 2, Len(MorphDirectory) - 1)
MorphPath = MorphDirectory & "\" & MorphTitle & "\"
If Dir(MorphPath, vbDirectory) = "" Then
MkDir (MorphPath)
Else
If Dir(MorphPath & "*.bmp") <> "" Then Kill (MorphPath & "*.bmp")
End If
Screen.MousePointer = vbHourglass
MakeTriangleList sTM, eTM, StartTriangles, EndTriangles
P(0).Cls
P(1).Cls
P(0).Visible = False
P(1).Visible = False
HScroll1.Visible = False
VScroll1.Visible = False
P(2).Move 0, 0
P(2).Visible = True
P(2).Cls
PicBlock.Visible = False
PicBack.Refresh
progressStep = PicProgress.ScaleWidth / (TotalFrames + 1)
For I = 0 To TotalFrames
P(2).Cls
WrapPic StartTriangles, EndTriangles, I, TotalFrames, P(0), P(1), P(2)
P(2).Refresh
PicProgress.Line (0, 0)-(progressStep * (I + 1), PicProgress.ScaleHeight), , BF
SavePicture FrmMesh.P(2).Image, MorphPath & I & ".bmp"
PicProgress.Refresh
Next I
PicProgress.Cls
P(0).Visible = True
P(1).Visible = True
HScroll1.Visible = True
VScroll1.Visible = True
P(2).Move 0, 0
P(2).Visible = False
PicBlock.Visible = True
Screen.MousePointer = vbArrow
RefreshMesh
FrmViewer.OpenMorphDir = MorphPath
FrmViewer.Show 1
End Sub