SuperLoto Randomize (Estimate) Tool

'UserForm1

'A) Windows XP® Office 2003® Normal Referance List

'A1) Name: VBA, Description: Visual Basic For Applications, FullPath: C:\Program Files\Common Files\Microsoft Shared\VBA\VBA6\VBE6.DLL
'A2) Name: Excel, Description: Microsoft Excel 11.0 Object Library, FullPath: C:\Program Files\Microsoft Office\OFFICE11\EXCEL.EXE
'A3) Name: stdole, Description: OLE Automation, FullPath: C:\WINDOWS\system32\STDOLE2.TLB
'A4) Name: Office, Description: Microsoft Office 11.0 Object Library, FullPath: C:\Program Files\Common Files\Microsoft Shared\OFFICE11\MSO.DLL
'A5) Name: MSForms, Description: Microsoft Forms 2.0 Object Library, FullPath: C:\WINDOWS\system32\FM20.DLL [Picture:1]

'B) UserForm1 E Eklenen Araçlar (Add Tools)

'B1) Image1, Label1, Label2
'B2) Label3,TextBox1,Label4,TextBox2,Label5,TextBox3
'B3) ListBox1
'B4) CommandButton1

Option Explicit
Dim KolonAdet As Integer, TopAdet As Integer, SatırAdet As Integer
Dim Sayaç(1 To 3)
Dim Birim As Boolean
Dim i As Integer, ii As Integer, iii As Integer, iv As Integer, Numara As Integer
Dim Arşiv As Variant
Dim Sonuç
Private Sub UserForm_Initialize()

On Error Resume Next
Me.Caption = "[PBİD ®] SuperLoto Randomize (Estimate) Tool"
Call EkranDüzenle

End Sub
Sub EkranDüzenle()

On Error Resume Next
With Me

.Height = 228.75
.Width = 269.25
.BackColor = vbWhite
.Picture = Resim(URL1)
'.Picture = LoadPicture("C:\Documents and Settings\PC\Desktop\BLOGSPOT\zarifVİSTA.bmp")
.PictureAlignment = fmPictureAlignmentTopLeft
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = False
With Image1

.BackStyle = fmBackStyleTransparent
.BorderColor = &HFF0000
.BorderStyle = fmBorderStyleSingle
.Top = 6
.Left = 6
.Height = 24
.Width = 24
.Picture = Resim(URL2)
'.Picture = LoadPicture("C:\Documents and Settings\PC\Desktop\BLOGSPOT\Örnekİkonlar\PBİD.ico")

End With
With Label1

.Caption = " " & "Mustafa ULUSARAÇ"
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.Left = 30
.Top = 6
.Height = 12
.Width = 198
.Font.Bold = True
.ForeColor = &HFF0000

End With
With Label2

.Caption = " " & "01ulusarac@superonline.com"
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.Left = 30
.Top = 18
.Height = 12
.Width = 198
.Font.Bold = True
.ForeColor = &HFF0000

End With
With Label3

.Caption = " " & "Kolon Sayısı"
.SpecialEffect = fmSpecialEffectEtched
.Left = 6
.Top = 36
.Height = 18
.Width = 54
.ForeColor = &H80000012

End With
With TextBox1

.Value = 6
.SpecialEffect = fmSpecialEffectEtched
.Left = Label3.Left + Label3.Width
.Top = 36
.Height = 18
.Width = 30
.ForeColor = vbBlue

End With
With Label4

.Caption = " " & "Top Sayısı"
.SpecialEffect = fmSpecialEffectEtched
.Left = TextBox1.Left + TextBox1.Width
.Top = 36
.Height = 18
.Width = 54
.ForeColor = &H80000012

End With
With TextBox2

.Value = 49
.SpecialEffect = fmSpecialEffectEtched
.Left = Label4.Left + Label4.Width
.Top = 36
.Height = 18
.Width = 30
.ForeColor = vbBlue

End With
With Label5

.Caption = " " & "Satır Sayısı"
.SpecialEffect = fmSpecialEffectEtched
.Left = TextBox2.Left + TextBox2.Width
.Top = 36
.Height = 18
.Width = 54
.ForeColor = &H80000012

End With
With TextBox3

.Value = 12
.SpecialEffect = fmSpecialEffectEtched
.Left = Label5.Left + Label5.Width
.Top = 36
.Height = 18
.Width = 30
.ForeColor = vbBlue

End With
With ListBox1

.ColumnCount = TextBox1.Value
.ColumnWidths = "40;40;40;40;40;40"
.SpecialEffect = fmSpecialEffectEtched
.BackColor = &H80000018
.Left = 6
.Top = 54
.Height = 123.75
.Width = TextBox1.Value * 40 + 12

End With
With CommandButton1

.Caption = "Oyna"
.Left = 6
.Top = 180
.Height = 18
.Width = 252

End With

End With

End Sub
Private Sub CommandButton1_Click()

On Error GoTo Hata
KolonAdet = TextBox1.Value
TopAdet = TextBox2.Value
SatırAdet = TextBox3.Value
ReDim OyunHafıza(1 To SatırAdet, 1 To KolonAdet)
ii = 1
ListBox1.Clear
For i = 1 To SatırAdet

Call SüperLoto
For Sayaç(1) = 1 To KolonAdet

For ii = 1 To KolonAdet

OyunHafıza(i, ii) = Sonuç(ii)

Next ii

Next Sayaç(1)

Next i
ListBox1.List() = OyunHafıza
Call SayfaDüzenle
Exit Sub
Hata:
MsgBox Error(Err), vbExclamation, "[PBİD®] Veri Giriş Hatası..."
ListBox1.Clear

End Sub
Private Function SüperLoto()

ReDim Hafıza(KolonAdet) As Integer
VBA.Randomize
Sayaç(1) = 0
Sayaç(3) = 1
Do

Sayaç(1) = Sayaç(1) + 1
Do

Birim = False
Numara = VBA.Int(VBA.Rnd * TopAdet) + 1
For Sayaç(2) = 1 To KolonAdet

If Numara = Hafıza(Sayaç(2)) Then Birim = True: Exit For

Next Sayaç(2)
If Birim = False Then Hafıza(Sayaç(1)) = Numara

Loop Until Birim = False

Loop Until Sayaç(1) >= KolonAdet 'Kolon Sayısı Kadar
For iii = 1 To KolonAdet

For iv = 1 To KolonAdet - 1

If Hafıza(iv) > Hafıza(iii) Then 'Sırala

Arşiv = Hafıza(iv)
Hafıza(iv) = Hafıza(iii)
Hafıza(iii) = Arşiv

End If

Next iv

Next iii
Sonuç = Hafıza

End Function
Sub SayfaDüzenle()

On Error Resume Next
Cells.Delete Shift:=xlUp
ActiveSheet.Cells(1, 1) = "No"
For i = 1 To TextBox1.Value

ActiveSheet.Cells(1, 1 + i) = "Kolon" & i

Next i
With ActiveSheet.Range(Cells(1, 1), Cells(1, TextBox1.Value + 1))

.Font.Bold = True
.Font.ColorIndex = 2
.Interior.ColorIndex = 5
.Interior.Pattern = xlSolid

End With
With ActiveSheet.Range(Cells(1, 1), Cells((TextBox1.Value * 2) + 1, 1))

.Font.Bold = True
.Font.ColorIndex = 2
.Interior.ColorIndex = 5
.Interior.Pattern = xlSolid

End With
With ActiveSheet.Columns("A:IV")

.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
.EntireColumn.AutoFit

End With
ActiveSheet.Range(Cells(2, 2), Cells(TextBox3.Value + 1, TextBox1.Value + 1)) = ListBox1.List
For i = 1 To TextBox3.Value

ActiveSheet.Cells(i + 1, 1) = i

Next i

End Sub

'Module1

Option Explicit
Public Declare Function CLSIDFromString Lib "ole32" (ByVal lpstrCLSID As Long, lpCLSID As Any) As Long
Public Declare Function OleLoadPicturePath Lib "oleaut32" (ByVal szURLorPath As Long, ByVal punkCaller As Long, ByVal dwReserved As Long, ByVal clrReserved As OLE_COLOR, ByRef riid As Any, ByRef ppvRet As Any) As Long
Public IPic(15) As Byte
Public Const ClsID As Variant = "{7BF80980-BF32-101A-8BBB-00AA00300CAB}" 'It may take a few seconds, please wait.
Public Const URL1 As String = "http://2.bp.blogspot.com/_hsHTxo_5L8E/S7rn6KHVfNI/AAAAAAAACRs/fxVMg9YGzb4/s1600/VectorBackround.jpg" 'Microsoft Office Excel® Kod Klavuzu [Vector Backround]
Public Const URL2 As String = "http://2.bp.blogspot.com/_hsHTxo_5L8E/S78EbvJyhRI/AAAAAAAACS0/txbOQ1qubg8/s1600/PB%C4%B0D_jpg.jpg" 'Microsoft Office Excel® Kod Kılavuzu [PBİD Icon]
Public URL As String
Sub FormAç() 'Open UserForm

On Error Resume Next
UserForm1.Show 0

End Sub
Public Function Resim(URL) As Picture 'Picture load frome web address...

On Error Resume Next
CLSIDFromString StrPtr(ClsID), IPic(0)
OleLoadPicturePath StrPtr(URL), 0&, 0&, 0&, IPic(0), Resim

End Function
'Sub References_List()

' On Error Resume Next
' Dim Eleman, No
' No = 1
' For Each Eleman In ThisWorkbook.VBProject.References

' Sheets(1).Cells(No, 1) = No & ") Name: "
' Sheets(1).Cells(No, 2) = Eleman.Name
' Sheets(1).Cells(No, 3) = ", Description: "
' Sheets(1).Cells(No, 4) = Eleman.Description
' Sheets(1).Cells(No, 5) = ", FullPath: "
' Sheets(1).Cells(No, 6) = Eleman.FullPath
' No = No + 1

' Next Eleman

'End Sub