www.pudn.com > PausVbMorpher.zip > ModWrap.bas
Attribute VB_Name = "ModWrap"
'This module deals with the morphing process
'You may use any part of this module in your own programs,
'but give me some votes and recommend this program to your friends.
'If you use parts of this program, then include me in the about box!, and give refrence to where
'this program can be found no PSC!
Public T(2) As PointSng
Public F(2) As PointSng
Type PointSng
X As Single
Y As Single
End Type
Type Triangle
V(2) As PointSng
End Type
Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Declare Function SetPixelV Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Declare Function GetTickCount Lib "kernel32" () As Long
Public sTM() As PointSng 'start triangular mesh
Public eTM() As PointSng 'end triangular mesh
Public StartTriangles() As Triangle 'the vertices of the start triangle
Public EndTriangles() As Triangle 'the vertices of the end triangle
Dim MaxX As Single, MinX As Single
Dim MaxY As Single, MinY As Single
Dim XLoc(2) As Single
Dim Y As Long, X As Long
Dim U As Single, V As Single, W As Single
Dim rt As PointSng, rt2 As PointSng
Dim XB(2) As PointSng 'x=min,y=max
Dim PWidth As Long, PHeight As Long
Dim Tarea As Single
Dim R1 As Long, G1 As Long, B1 As Long
Dim R2 As Long, G2 As Long, B2 As Long
'this small value is used to make sure that all parth of the triangle is drawn,
'it has to be used because other wise the triangles are not started from their proper Y coordinates
'can't figure out why???
'set the value of r to be 0 to see what I mean
Const R = 0.001
'function check to see if a point is with in a circle
Function CheckCircleCollision(CircleX As Single, CircleY As Single, CircleRadius As Long, X As Single, Y As Single)
d = Sqr((X - CircleX) ^ 2 + (Y - CircleY) ^ 2)
If d < CircleRadius Then CheckCircleCollision = True Else CheckCircleCollision = False
End Function
Sub WrapPic(StartTriangle() As Triangle, EndTriangle() As Triangle, CurFrame As Long, Frames As Long, StartPic As PictureBox, EndPicture As PictureBox, DestPicture As PictureBox)
Dim CurTri() As Triangle
ReDim CurTri(UBound(StartTriangle))
Dim Transparency As Single
Transparency = (CurFrame / Frames)
For I = 0 To UBound(CurTri)
For Tt = 0 To 2
CurTri(I).V(Tt).X = (EndTriangle(I).V(Tt).X - StartTriangle(I).V(Tt).X) * Transparency + StartTriangle(I).V(Tt).X
CurTri(I).V(Tt).Y = (EndTriangle(I).V(Tt).Y - StartTriangle(I).V(Tt).Y) * Transparency + StartTriangle(I).V(Tt).Y
Next Tt
Next I
PWidth = StartPic.ScaleWidth - 1
PHeight = StartPic.ScaleHeight - 1
For I = 0 To UBound(StartTriangles)
FillTriangle DestPicture, StartPic, EndPicture, CurTri(I), StartTriangle(I), EndTriangle(I), Transparency
Next I
End Sub
'this function fills the triangle, with an wraped image from a triangle in the pictureBox (WrapPicture)
Sub FillTriangle(Dest As PictureBox, StartPic As PictureBox, EndPic As PictureBox, P3 As Triangle, StartTri As Triangle, EndTri As Triangle, Transparent As Single)
'these set the X bounds for each sides of the triangle, note that the small value of r is add to
'completly fill the triangle
'I have used the PointSng type to set the bounds to make things simple, x=min,y=max
If P3.V(0).X > P3.V(1).X Then
XB(0).X = P3.V(1).X - R
XB(0).Y = P3.V(0).X + R
Else
XB(0).X = P3.V(0).X - R
XB(0).Y = P3.V(1).X + R
End If
If P3.V(1).X > P3.V(2).X Then
XB(1).X = P3.V(2).X - R
XB(1).Y = P3.V(1).X + R
Else
XB(1).X = P3.V(1).X - R
XB(1).Y = P3.V(2).X + R
End If
If P3.V(2).X > P3.V(0).X Then
XB(2).X = P3.V(0).X - R
XB(2).Y = P3.V(2).X + R
Else
XB(2).X = P3.V(2).X - R
XB(2).Y = P3.V(0).X + R
End If
'we find the graident of each sides, if the value of the change in X is zero then the graident is infinet
'so we set a large vvalue for it
If (P3.V(1).X - P3.V(0).X) <> 0 Then m1 = (P3.V(1).Y - P3.V(0).Y) / (P3.V(1).X - P3.V(0).X) Else m1 = 100000
If (P3.V(2).X - P3.V(1).X) <> 0 Then m2 = (P3.V(2).Y - P3.V(1).Y) / (P3.V(2).X - P3.V(1).X) Else m2 = 100000
If (P3.V(0).X - P3.V(2).X) <> 0 Then m3 = (P3.V(0).Y - P3.V(2).Y) / (P3.V(0).X - P3.V(2).X) Else m3 = 100000
'if the graident turns out to be zero, then set a small value for it otherwise, we get a DEVIDE BY ZERO error
'in later calculations
If m1 = 0 Then m1 = 0.0000001
If m2 = 0 Then m2 = 0.0000001
If m3 = 0 Then m3 = 0.0000001
'the y intercept of each sides of the triangle
c1 = P3.V(0).Y - (m1 * P3.V(0).X)
c2 = P3.V(1).Y - (m2 * P3.V(1).X)
C3 = P3.V(2).Y - (m3 * P3.V(2).X)
'Now calculate the Y bounds of the triangle
MaxY = P3.V(0).Y
MinY = P3.V(0).Y
For Y = 1 To 2
If P3.V(Y).Y > MaxY Then MaxY = P3.V(Y).Y
If P3.V(Y).Y < MinY Then MinY = P3.V(Y).Y
Next Y
'get the area of the current triangle
Tarea = GetTriangleArea(P3.V(0), P3.V(1), P3.V(2))
'go from the top to the bottom of the triangle
For Y = MinY To MaxY
'and for that Y value, find the X value on each of the three sides of the triangle,
'to do this, Just use the straight line equation , y=mx+c, rearanged to get x
XLoc(0) = (Y - c1) / m1
XLoc(1) = (Y - c2) / m2
XLoc(2) = (Y - C3) / m3
'now we obtain the max and the Min X values of the triangles
MaxX = -100000
MinX = 100000
For X = 0 To 2
'check to see if its the max or the min so long as the x value is within the bounds of the
'triangles X values
If XLoc(X) >= XB(X).X And XLoc(X) <= XB(X).Y Then
If XLoc(X) > MaxX Then MaxX = XLoc(X)
If XLoc(X) < MinX Then MinX = XLoc(X)
End If
Next X
'go horizontally filling the points in the triangle
For X = MinX To MaxX
'for the point in the triangle, change its coordinates to Barycentric coordinates
PointToB P3, X, Y, Tarea, U, V, W
'make sure that the point is really inside the triangle
'this is needed because some slight floating point error may occure during calculations by the computer
'note that we have used a value of 1.01, an exact value should be 1 but som error may have occured
If U + V + W <= 1.01 Then
'now obtain the corrosponding point on the starting triangle
rt = BtoPoint(U, V, W, StartTri)
rt2 = BtoPoint(U, V, W, EndTri)
'make sure that the given point is within the picture box
If rt.X > PWidth Then rt.X = PWidth
If rt.Y > PHeight Then rt.Y = PHeight
If rt2.X > PWidth Then rt2.X = PWidth
If rt2.Y > PHeight Then rt2.Y = PHeight
GetRGB GetPixel(StartPic.hdc, rt.X, rt.Y), R1, G1, B1
GetRGB GetPixel(EndPic.hdc, rt2.X, rt2.Y), R2, G2, B2
rf = R2 * Transparent + R1 * (1 - Transparent)
gf = G2 * Transparent + G1 * (1 - Transparent)
BF = B2 * Transparent + B1 * (1 - Transparent)
If rf < 0 Then rf = 0
If gf < 0 Then gf = 0
If BF < 0 Then BF = 0
'plot the color from the wrapping picture box to the destination
SetPixelV Dest.hdc, X, Y, RGB(rf, gf, BF) 'GetPixel(WrapPicture.hdc, rt.x, rt.y)
End If
Next X
Next Y
End Sub
'the next two functions are used to map the pixels from one triangel to the other triangle
'converts a point to Barycentric coordinates
Sub PointToB(T As Triangle, X, Y, TriArea As Single, ByRef U As Single, ByRef V As Single, ByRef W As Single)
Dim PPt As PointSng
PPt.X = X
PPt.Y = Y
'TriArea is then area of the whole triangle
'to get the values of U,V and W, the triangle is split into 3 triangles using a point given within the triangle (X and Y)
'then the ratios of their area agains the whole triangle is found
'if the point X and Y is within the triangle, the value of (U+V+W) is equal to 1, ( ignoring some errors that may occure when the computer calculates the values)
'get the ratios
If TriArea = 0 Then TriArea = 0.000001
U = GetTriangleArea(PPt, T.V(1), T.V(2)) / TriArea
V = GetTriangleArea(T.V(0), PPt, T.V(2)) / TriArea
W = GetTriangleArea(T.V(0), T.V(1), PPt) / TriArea
End Sub
'converts Barycentric coordinates to a point
Function BtoPoint(U As Single, V As Single, W As Single, T As Triangle) As PointSng
BtoPoint.X = U * T.V(0).X + V * T.V(1).X + W * T.V(2).X
BtoPoint.Y = U * T.V(0).Y + V * T.V(1).Y + W * T.V(2).Y
End Function
'function to calculate the area of a triangle
Function GetTriangleArea(A As PointSng, B As PointSng, C As PointSng) As Single
'this gets the length of a side of the triangle
lm = Sqr((A.X - B.X) ^ 2 + (A.Y - B.Y) ^ 2)
'get the griadent of the same side, making sure that the change in the x cordinate is not zero,
'if its zero then the graident is infinet, so set a large value for the graident
If (A.X - B.X) <> 0 Then m = ((A.Y - B.Y) / (A.X - B.X)) Else m = 1E+20
'the y intercept of the side of which the graident is found
Cm = A.Y - m * A.X
'this is the height of the triangle, it is the perpendicular distance between the line and the third point of the triangle
Bm = Abs(-m * C.X + C.Y + -Cm) / (Sqr(m ^ 2 + 1))
'I am sure you know what this is !!! ???
GetTriangleArea = 0.5 * lm * Bm
End Function
Sub GetRGB(ByVal Col As Long, ByRef R As Long, ByRef G As Long, ByRef B As Long)
R = Col Mod 256
G = ((Col And &HFF00&) \ 256&) Mod 256&
B = (Col And &HFF0000) \ 65536
End Sub
Sub SaveMorph(OutFileName As String, PictureStart As String, PictureEnd As String, StartMesh() As PointSng, EndMesh() As PointSng, T As TextBox)
T.Text = ""
T.SelText = PictureStart & vbNewLine
T.SelText = PictureEnd & vbNewLine
T.SelText = UBound(StartMesh, 1) & vbNewLine
T.SelText = UBound(StartMesh, 2) & vbNewLine
T.SelText = UBound(EndMesh, 1) & vbNewLine
T.SelText = UBound(EndMesh, 2) & vbNewLine
For j = 0 To UBound(StartMesh, 2)
For I = 0 To UBound(StartMesh, 1)
T.SelText = StartMesh(I, j).X & vbNewLine
T.SelText = StartMesh(I, j).Y & vbNewLine
Next I
Next j
For j = 0 To UBound(EndMesh, 2)
For I = 0 To UBound(EndMesh, 1)
T.SelText = EndMesh(I, j).X & vbNewLine
T.SelText = EndMesh(I, j).Y & vbNewLine
Next I
Next j
T.SelText = FrmMesh.MorphTitle & vbNewLine
T.SelText = FrmMesh.MorphDirectory & vbNewLine
T.SelText = FrmMesh.TotalFrames & vbNewLine
Open OutFileName For Output As #1
Print #1, T.Text
Close #1
End Sub
Function ReadMorphFile(FileName As String, StartPic As PictureBox, EndPic As PictureBox, StartMesh() As PointSng, EndMesh() As PointSng) As String
Open FileName For Input As #1
Line Input #1, file1
If Dir(file1) = "" Then GoTo ErFile1
Line Input #1, file2
If Dir(file2) = "" Then GoTo ErFile2
On Error GoTo BadFile
Line Input #1, u1
Line Input #1, u2
ReDim StartMesh(u1, u2)
Line Input #1, u1
Line Input #1, u2
ReDim EndMesh(u1, u2)
ReDim StartTriangles(u1 * u2 * 2 - 1)
ReDim EndTriangles(u1 * u2 * 2 - 1)
FrmMesh.Ht = u1 - 1
FrmMesh.Vt = u2 - 1
For j = 0 To UBound(StartMesh, 2)
For I = 0 To UBound(StartMesh, 1)
Line Input #1, vx
StartMesh(I, j).X = vx
Line Input #1, vy
StartMesh(I, j).Y = vy
Next I
Next j
For j = 0 To UBound(EndMesh, 2)
For I = 0 To UBound(EndMesh, 1)
Line Input #1, vx
EndMesh(I, j).X = vx
Line Input #1, vy
EndMesh(I, j).Y = vy
Next I
Next j
Line Input #1, mTitle
Line Input #1, mDir
FrmMesh.MorphTitle = mTitle
FrmMesh.MorphDirectory = mDir
Line Input #1, tFrames
FrmMesh.TotalFrames = tFrames
Close #1
EndPic.Picture = LoadPicture(file2)
StartPic.Picture = LoadPicture(file1)
FrmMesh.StartFile = file1
FrmMesh.EndFile = file2
ReadMorphFile = "ok"
Exit Function
ErFile1:
ReadMorphFile = file1 & " is missing, morph can not be loaded"
Exit Function
ErFile2:
ReadMorphFile = file2 & " is missing, morph can not be loaded"
Exit Function
BadFile:
ReadMorphFile = "There is an unknown error in the morph file so it can not be loaded"
End Function