GFAlphaBlend/GFAlphaBlendmod.bas
Attribute VB_Name = "GFAlphaBlendmod"
Option Explicit
'(c)2001 by Louis.
'
'NOTE: the GFAlphaBlend_Sphere code does not work yet,
'the sphere functions of this module are (still) useless.
'
'general use
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
'
'NOTE: this module contains subs/functions that are to be used by
'GFAlphaBlendfrm and which are used to create special graphics effects.
'The target project needn't to call any sub/function of this module.
'
'TranslationStruct
Public Type TranslationStruct
XNew As Single
YNew As Single
End Type
'****************************************SPHERE*****************************************
'NOTE: the following subs/functions are all used by
'GFAlphaBlendfrm.GFAlphaBlend_CreateSphere.
'
'NOTE: when calculating mathematical terms then short var names are used
'as tests showed that they are more useful for these types of programming
'(no large systems but short algorithms).
Public Sub Sphere_GetRadiusArray(ByVal SphereRadius As Long, ByRef SphereRadiusArray() As Single)
'on error resume next
Dim Temp As Long
'preset
ReDim SphereRadiusArray(1 To SphereRadius) As Single
'begin
'
'NOTE: the following code is very important.
'The radius graph must never have a gradient greater than 1 or the sphere middle point will look 'dissolved'.
'Furthermore the 'end' of the graph must have the gradient 0 or the final sphere will not be completely round.
'Large parts of the outer edges of the source image will not be visible in the sphere anymore.
'
For Temp = 1 To SphereRadius 'a radius of 0 is not useful as then mostly division by 0 errors appear somewhere in the code
'
'NOTE: the Select Case statement is a good thing to split up the x axis
'of the graph in regions. One formula for the whole x axis did not work.
'
Select Case Temp
Case Is < (SphereRadius / 3&)
'
SphereRadiusArray(Temp) = Int(Temp)
'
Case (SphereRadius / 3& * 1&) To (SphereRadius / 3& * 2&)
'
SphereRadiusArray(Temp) = _
(SphereRadius / 3&) + ((SphereRadius / 2&) ‑ (SphereRadius / 3&)) * (Temp ‑ (SphereRadius / 3&)) / (SphereRadius / 3&)
'
Case Else
'
'NOTE: the final radius will never exceed half of the original radius =>
'sphere will have half the size of the input picture.
'
SphereRadiusArray(Temp) = SphereRadius / 2
End Select
Next Temp
End Sub
Public Sub Sphere_GetTranslationStructArray(ByVal SphereRadius As Long, ByRef SphereRadiusArray() As Single, ByRef TranslationArray() As TranslationStruct)
'on error resume next
Dim X As Single
Dim Y As Single
Dim CX As Single 'circle center x
Dim CY As Single 'circle center y
Dim CR As Single 'circle radius
Dim VX As Single 'vector x from point to circle center
Dim VY As Single 'vector y from point to circle center
Dim VL As Single 'vector length from point to circle center
Dim XN As Single 'new x coordinate of current point
Dim YN As Single 'new y coordinate of current point
'preset
ReDim TranslationArray(1 To (SphereRadius * 2), 1 To (SphereRadius * 2)) As TranslationStruct
CX = SphereRadius
CY = SphereRadius
'begin
For X = 1 To (SphereRadius * 2)
For Y = 1 To (SphereRadius * 2)
'
'NOTE: the following line calculates a circle's radius using the formula:
'r� = sqr((x ‑ cx)� + (y ‑ cy)�).
'
CR = Sqr((X ‑ CX) ^ 2! + (Y ‑ CY) ^ 2!): VL = CR
If Not ((CR < LBound(SphereRadiusArray())) Or (CR > UBound(SphereRadiusArray()))) Then
'Debug.Print CR & " ";
CR = SphereRadiusArray(CR)
'Debug.Print CR & " ";
'
VX = (CX ‑ X) / VL '‑1...+1
VY = (CY ‑ Y) / VL '‑1...+1
'
XN = CX ‑ VX * CR
YN = CY ‑ VY * CR
'
'NOTE: use a structure array,
'nor TranslationXArray(x) works,
'neither TranslationArray(x, y) (<‑ of course).
'
TranslationArray(X, Y).XNew = XN
TranslationArray(X, Y).YNew = YN
'
End If
'
Next Y
Next X
End Sub
Public Sub Sphere_VerifyTranslationStructArray(ByRef TranslationStructArray() As TranslationStruct)
'on error resume next
Dim TempTranslationStructArray() As TranslationStruct
Dim X1 As Long
Dim Y1 As Long
Dim X2 As Long
Dim Y2 As Long
Dim UBound1 As Long
Dim UBound2 As Long
'
'NOTE: this sub verifies no double points are in TranslationStructArray() so that
'the final sphere drawing works as fast as possible.
'As only THE LAST one of double, triple, etc. points would would be drawn
'we loop through the source points in reverse direction and transfer
'only those points which weren't transferred yet, already transferred points
'are reset to (‑1) for 'do not use'.
'
'NOTE: as TranslationStructArray() is a two‑dimensional array there is no
'TranslationStructNumber, use UBound() instead.
'
Exit Sub 'DEBUG
'preset
UBound1 = UBound(TranslationStructArray(), 1)
UBound2 = UBound(TranslationStructArray(), 2)
ReDim TempTranslationStructArray(1 To UBound1, 1 To UBound2) As TranslationStruct 'same size, but some array values will be marked as 'do not use'
'begin
For X1 = UBound1 To 1 Step (‑1)
For Y1 = UBound2 To 1 Step (‑1)
For X2 = 1 To UBound1
For Y2 = 1 To UBound2
If TranslationStructArray(X1, Y1).XNew = TempTranslationStructArray(X2, Y2).XNew Then
If TranslationStructArray(X1, Y1).YNew = TempTranslationStructArray(X2, Y2).YNew Then
TempTranslationStructArray(X1, Y1).XNew = ‑1
TempTranslationStructArray(X1, Y1).YNew = ‑1
GoTo Jump: 'point already existing in verified array, skip it
End If
End If
Next Y2
Next X2
TempTranslationStructArray(X1, Y1).XNew = TranslationStructArray(X1, Y1).XNew
TempTranslationStructArray(X1, Y1).YNew = TranslationStructArray(X1, Y1).YNew
Jump:
Next Y1
Next X1
Call CopyMemory(TranslationStructArray(1, 1), TempTranslationStructArray(1, 1), UBound(TranslationStructArray(), 1) * UBound(TranslationStructArray(), 2) * Len(TranslationStructArray(1, 1)))
End Sub
'*************************************END OF SPHERE*************************************
[END OF FILE]