'===================ABV PROJECT====================== '===================MODULE 1 ======================= Const pmin = -2.25 Const pmax = 0.75 Const qmin = -1.5 Const qmax = 1.5 Const r_max = 50 Const k_max = 50 Const xres = 100 Const yres = 99 Const MaxColors = 10 Dim ak As Integer Dim k As Integer dim dp,dq,p,q,x,x_alt,y As Single Dim z,s,u_f As Integer Sub main () 'you can edit this macro to execute any command when loading this workbook call formatsheet() 'next line call the routine that fill the sheet call absmain () End Sub '_______________________________________________________ 'this sub adjust row and column for drawing fractal 'this sub add a macro button to launch the computation Sub formatsheet () Dim objbutton As Object Worksheets(1).Activate for i = 1 to xres Columns(i).ColumnWidth = 0.7 next i for i = 1 to yres Rows(i).RowHeight = 5 next i Set objbutton = ActiveSheet.Buttons.Add (696,120,63,41) objbutton.OnAction = "mandel" objbutton.Text = "RUN!" End Sub '_______________________________________________________ Sub PutPixel (r,c,col) Cells(c +1,r+1).Interior.ColorIndex = col+10 Cells(c +1,r+1) = Col End Sub '_______________________________________________________ Sub EffaceFractale() for i = 2 to yres for j = 2 to xres Cells(i,j).Interior.ColorIndex = 19 Cells(i,j) = 0 next j next i repaint() End Sub '_______________________________________________________ Sub iterat (np,nq) p = pmin + np * dp q = qmin + nq * dq k=0 x=0 y=0 Do x_alt = x x = x*x - y*y+p y=2*x_alt*y+q k=k+1 Loop Until (x*x + y*y > r_max) or (k = k_max) if k = k_max Then k=0 end if z=np s=yres-nq u_f = k Mod ak call PutPixel (z,s,u_f) End sub '_______________________________________________________ Sub mandel() ak = MaxColors + 1 dp = (pmax-pmin)/xres dq = (qmax-qmin) /yres for np = 1 to xres-1 for nq = 0 to yres-1 call iterat (np,nq) next next end sub '_______________________________________________________ Sub absmain () 'Do not edit this macro, changes will not be saved with the workbook!!! End Sub