GFAlphaBlend/SphereTest/SphereTest.frm
VERSION 5.00
Begin VB.Form Testfrm
BorderStyle = 1 'Fest Einfach
Caption = "SphereTest"
ClientHeight = 6750
ClientLeft = 45
ClientTop = 450
ClientWidth = 9990
LinkTopic = "Form1"
MaxButton = 0 'False
ScaleHeight = 6750
ScaleWidth = 9990
StartUpPosition = 3 'Windows‑Standard
Begin VB.PictureBox Picture2
Height = 3060
Left = 6780
ScaleHeight = 200
ScaleMode = 3 'Pixel
ScaleWidth = 200
TabIndex = 3
Top = 3540
Width = 3060
End
Begin VB.PictureBox Picture1
AutoRedraw = ‑1 'True
AutoSize = ‑1 'True
Height = 3390
Left = 6765
Picture = "SphereTest.frx":0000
ScaleHeight = 222
ScaleMode = 3 'Pixel
ScaleWidth = 207
TabIndex = 2
Top = 105
Width = 3165
End
Begin VB.CommandButton Command2
Caption = "CheckRadiusArray"
Height = 315
Left = 4740
TabIndex = 1
Top = 480
Width = 1875
End
Begin VB.CommandButton Command1
Caption = "Sphere Test"
Height = 315
Left = 4740
TabIndex = 0
Top = 60
Width = 1875
End
End
Attribute VB_Name = "Testfrm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'(c)2001 by Louis. Test project for GFAlphaBlend.
'
'NOTE: parts of this project's code have been copied to GFAlphaBlend[frm/mod].
'
'TranslationStruct
Private Type TranslationStruct
XNew As Single
YNew As Single
End Type
Private Sub Form_Load()
'on error resume next
'
'NOTE: it is important that Picture1 is rectangular and has a
'special size as the sphere radius will be half the picture box width.
'
Picture1.ScaleMode = vbPixels
Picture2.ScaleMode = vbPixels
Picture1.Width = (200 + 4) * Screen.TwipsPerPixelX
Picture1.Height = (200 + 4) * Screen.TwipsPerPixelY
End Sub
Private Sub Command1_Click()
'on error resume next
Dim SphereRadiusArray() As Single
Dim TranslationArray() As TranslationStruct
Dim X As Long
Dim Y As Long
'preset
Call GetRadiusArray(Picture1.ScaleWidth / 2, SphereRadiusArray())
Call GetTranslationStructArray(Picture1.ScaleWidth / 2, SphereRadiusArray(), TranslationArray())
'begin
For X = 1 To 200
For Y = 1 To 200
Picture2.PSet (TranslationArray(X, Y).XNew, TranslationArray(X, Y).YNew), Picture1.Point(X, Y)
Next Y
Next X
End Sub
Private Sub Command2_Click()
'on error resume next
Call CheckRadiusArray
End Sub
'******************************DEBUG SPHERE CREATION CODE*******************************
Private Sub 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
Private Sub 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
'***************************END OF DEBUG SPHERE CREATION CODE***************************
Private Sub CheckRadiusArray()
'on error resume next
Dim RadiusArray() As Single
Dim Temp As Long
'preset
Me.ScaleMode = vbPixels
Me.Line (0, 0)‑(300, 300), RGB(255, 0, 0), B
'begin
'
'NOTE: the coordinate system has the dimensions 300x300.
'The graph represents the cross‑section through the sphere in
'z‑direction.
'
Call GetRadiusArray(300, RadiusArray())
'
For Temp = 1 To 300
Me.PSet (Temp, 300 ‑ RadiusArray(Temp))
Next Temp
'
End Sub
[END OF FILE]