Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

17 Mayıs 2011 Salı

Asal Sayı Üretimi ve Goldbach Kestirimi Testi


'UserForm1
'Mustafa ULUSARAÇ 17.Mayıs.2011


'A. Available References List
'1) Name: VBA, Description: Visual Basic For Applications, FullPath: C:\PROGRA~2\COMMON~1\MICROS~1\VBA\VBA7\VBE7.DLL
'2) Name: Excel, Description: Microsoft Excel 14.0 Object Library, FullPath: C:\Program Files (x86)\Microsoft Office\Office14\EXCEL.EXE
'3) Name: stdole, Description: OLE Automation, FullPath: C:\Windows\SysWOW64\stdole2.tlb
'4) Name: Office, Description: Microsoft Office 14.0 Object Library, FullPath: C:\Program Files (x86)\Common Files\Microsoft Shared\OFFICE14\MSO.DLL
'5) Name: MSForms, Description: Microsoft Forms 2.0 Object Library, FullPath: C:\Windows\SysWOW64\FM20.DLL
'B. Available Tools List
'1) İmage1
'2) Label1
'3) Label2
'4) CheckBox1
'5) ListBox1
'6) Label3
'7) Label4
'8) Label5
'9) TextBox1
'10) TextBox2
'11) TextBox3
'12) Label6
'13) ComboBox1
'14) Label7, CommandButton1
'C. Paylaşım Yolu (Share URL)
'http://cid-453d1b1a593a53f0.office.live.com/browse.aspx/GoldbachTest.xls
Option Explicit
Private i As Single, ii As Single
Private TS As Double, KS As Double, Fark As Double, Bas As Double, Son As Double, Adet As Double, No As Double
Private Kolon As Double
Private MKolon As Double
Private AS1 As Double
Private AS2 As Double
Private Kalan As Double
Private Aranan As Double
Private En As String
Private Durum As Boolean
Private Bellek(1 To 1, 1 To 99)
Private Sub UserForm_Initialize()
On Error Resume Next
Me.Caption = "[PBİD®] Asal Sayı Üretimi (Prime Number Generation) ve Goldbach Kestirimi Testi"
Call Ekran_Duzenle
End Sub
Private Sub CheckBox1_Click()
On Error Resume Next
With CheckBox1
If .Value = True Then
.Caption = "Bir [1]; asal ise!"
Else
.Caption = "Bir [1]; asal değilse!"
End If
End With
End Sub
Private Sub TextBox1_AfterUpdate()
On Error Resume Next
TextBox1.Text = VBA.Format(TextBox1.Text, "#,##0")
End Sub
Private Sub TextBox1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
On Error Resume Next
TextBox1.Text = VBA.Format(TextBox1.Text, "##0")
End Sub
Private Sub TextBox1_Change()
On Error Resume Next
TextBox3.Value = VBA.Format(TextBox2.Value - TextBox1.Value + 1, "#,##0")
If TextBox1.Value = 1 Then
ComboBox1.Enabled = True
Else
ComboBox1.Enabled = False
End If
End Sub
Private Sub TextBox2_AfterUpdate()
On Error Resume Next
TextBox2.Text = VBA.Format(TextBox2.Text, "#,##0")
End Sub
Private Sub TextBox2_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
On Error Resume Next
TextBox2.Text = VBA.Format(TextBox2.Text, "##0")
End Sub
Private Sub TextBox2_Change()
On Error Resume Next
TextBox3.Value = VBA.Format(TextBox2.Value - TextBox1.Value + 1, "#,##0")
End Sub
Sub CommandButton1_Click()
On Error Resume Next
Durum = False
Bas = TextBox1.Value
Son = TextBox2.Value
Adet = TextBox3.Value
ListBox1.Clear
ComboBox1.Clear
Label7.Caption = ""
DoEvents
If TextBox1.Value = 1 Then
ComboBox1.Enabled = True
Else
ComboBox1.Enabled = False
End If
If Adet > 0 Then Call Asal_Sayi_Uret
Durum = True
End Sub
Private Sub ComboBox1_Change()
On Error Resume Next
If Durum = False Then Exit Sub
Label7.Caption = ""
With ListBox1
.MultiSelect = fmMultiSelectSingle
.MultiSelect = fmMultiSelectMulti
Call Goldbach_Kestirimi_Testi(ComboBox1.Value)
.Height = 258
.Width = 450
End With
Me.Repaint
DoEvents
End Sub
Private Sub Ekran_Duzenle()
On Error Resume Next
With Me
.BackColor = vbWhite
.Height = 358
.Width = 467.25
.Picture = Resim(URL1)
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = True
.SpecialEffect = fmSpecialEffectFlat
With Image1
.Top = 6
.Left = 6
.Height = 24
.Width = 24
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleSingle
.BorderColor = vbBlue
.Picture = Resim(URL2)
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = False
End With
With Label1
.Left = 36
.Top = 6
.Height = 12
.Width = 420
.Caption = "Mustafa ULUSARAÇ"
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.Font.Name = "Arial"
.ForeColor = vbBlue
End With
With Label2
.Left = 36
.Top = 18
.Height = 12
.Width = 420
.Caption = "01ulusarac@superonline.com"
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.Font.Name = "Arial"
.ForeColor = vbBlue
End With
With CheckBox1
.Width = 104
.Left = Me.InsideWidth - .Width - 6
.Top = 6
.Height = 24
.Caption = "Bir [1]; asal ise!"
.Value = True
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.Font.Name = "Arial"
.ForeColor = vbRed
End With
With ListBox1
.Left = 6
.Top = 36
.Height = 272
.Width = 450
.SpecialEffect = fmSpecialEffectEtched
.ColumnHeads = False
.TextAlign = fmTextAlignRight
.BackColor = VBA.RGB(230, 230, 230)
.MultiSelect = fmMultiSelectMulti
.ListStyle = fmListStyleOption
.ControlTipText = "1. Kolon: Dizin, 2. Kolon: Asal Sayılar, Diğer Kolonlar: Dizindeki sayıları bölen doğal sayıları gösterir"
End With
With Label3
.Left = 6
.Top = 300
.Height = 12
.Width = 60
.Caption = "Dizin Başı"
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.Font.Bold = False
.Font.Name = "Tahoma"
.TextAlign = fmTextAlignCenter
End With
With Label4
.Left = 66
.Top = 300
.Height = 12
.Width = 60
.Caption = "Dizin Sonu"
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.Font.Bold = False
.Font.Name = "Tahoma"
.TextAlign = fmTextAlignCenter
End With
With Label5
.Left = 126
.Top = 300
.Height = 12
.Width = 60
.Caption = "Dizin Sayısı"
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.Font.Bold = False
.Font.Name = "Tahoma"
.TextAlign = fmTextAlignCenter
End With
With TextBox1
.Left = 6
.Top = 312
.Height = 18
.Width = 60
.AutoSize = False
.ControlTipText = "Üretilecek asal sayı dizin in alt limiti..."
.ForeColor = vbBlue
.Font.Bold = True
.MultiLine = False
.SpecialEffect = fmSpecialEffectEtched
.Locked = False
.TextAlign = fmTextAlignRight
End With
With TextBox2
.Left = 66
.Top = 312
.Height = 18
.Width = 60
.AutoSize = False
.ControlTipText = "Üretilecek asal sayı dizin in üst limiti..."
.ForeColor = vbBlue
.Font.Bold = True
.MultiLine = False
.SpecialEffect = fmSpecialEffectEtched
.Locked = False
.TextAlign = fmTextAlignRight
End With
With TextBox3
.Left = 126
.Top = 312
.Height = 18
.Width = 60
.AutoSize = False
.ControlTipText = "Üretilecek asal sayı dizin in üst limiti..."
.ForeColor = vbBlack
.Font.Bold = True
.MultiLine = False
.SpecialEffect = fmSpecialEffectEtched
.Locked = True
.TextAlign = fmTextAlignRight
End With
With CommandButton1
.Left = 192
.Top = 300
.Height = 30
.Width = 48
.Caption = "Hesapla"
End With
With Label6
.Left = 246
.Top = 300
.Height = 12
.Width = 210
.Caption = "Goldbrach Kestirimi Testi"
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.Font.Bold = False
.Font.Name = "Tahoma"
.TextAlign = fmTextAlignCenter
End With
With ComboBox1
.Left = 246
.Top = 312
.Height = 18
.Width = 72
.BackStyle = fmBackStyleTransparent
.ColumnWidths = 60
.ListWidth = 72
.AutoSize = False
.SpecialEffect = fmSpecialEffectEtched
.TextAlign = fmTextAlignLeft
.Font.Bold = True
.ForeColor = vbBlue
.ControlTipText = "Goldbrach kestirimi testinin yapılabilmesi için dizin başı değeri mutlaka 1 olmalıdır."
End With
With Label7
.Left = 318
.Top = 312
.Height = 18
.Width = 138
.Caption = ""
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.Font.Name = "Tahoma"
.TextAlign = fmTextAlignCenter
End With
End With
End Sub
Sub Asal_Sayi_Uret()
On Error Resume Next
With ListBox1
.ColumnCount = 99
For i = 1 To 99
If 99 > i Then
En = En & "42;"
Else
En = En & "42"
End If
Bellek(1, i) = ""
Next i
.ColumnWidths = En
.List() = Bellek
No = 0
MKolon = 0
For i = Bas To Son Step 1
No = No + 1
If No > 1 Then
.AddItem ""
.List((No - 1), 1) = ""
.List((No - 1), 2) = ""
End If
Kolon = 1
For ii = 2 To (i - 1) Step 1
TS = i \ ii
KS = i / ii
Fark = TS - KS
If Fark = 0 Then
Kolon = Kolon + 1
If Kolon > MKolon Then MKolon = Kolon
.List((No - 1), Kolon) = ii
End If
Next ii
.List((No - 1), 0) = i
Aranan = VBA.Val(.List((No - 1), 2))
If CheckBox1.Value = True Then
If Aranan = 0 Then .List((No - 1), 1) = i
Else
If Aranan = 0 And No > 1 Then .List((No - 1), 1) = i
End If
.ListIndex = (No - 1)
DoEvents
Next i
.Selected((No - 1)) = True
.ControlTipText = "1. Kolon: Dizin, 2. Kolon: Asal Sayılar, Diğer " & (MKolon + 1 - 2) & " Kolon: Dizindeki sayıları bölen doğal sayıları gösterir" '.ColumnCount = MKolon + 2

.Selected((No - 1)) = True
.Height = 258
.Width = 450
DoEvents
For i = 1 To Adet
TS = ListBox1.List((i - 1), 0) \ 2
KS = ListBox1.List((i - 1), 0) / 2
Fark = TS - KS
If Fark = 0 Then ComboBox1.AddItem ListBox1.List((i - 1), 0)
Next i
End With
End Sub
Private Sub Goldbach_Kestirimi_Testi(TestV As Double)
On Error Resume Next
For i = 0 To (Adet - 1)
AS1 = VBA.Val(ListBox1.List(i, 1))
If AS1 > 0 Then
Kalan = TestV - AS1
For ii = 0 To (Adet - 1)
AS2 = VBA.Val(ListBox1.List(ii, 1))
If AS2 > 0 And AS1 <> AS2 And AS2 = Kalan Then GoTo Tamam
Next ii
End If
Next i
Exit Sub
Tamam:
Label7.Caption = AS1 & " - " & AS2
ListBox1.Selected((AS1 - 1)) = True
ListBox1.Selected((AS2 - 1)) = True
End Sub


'Module1
'Mustafa ULUSARAÇ 17.Mayıs.2011


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/-G3KDFVP7V0Q/TcUhtYtMifI/AAAAAAAACw0/Ta6mFpFJtZ8/s1600/39.bmp" 'Microsoft Office Excel® Kod Kılavuzu [PBİD BackroundPicture]
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 Form_Aç() '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

Hiç yorum yok:

Blog Arşivi

Bu gadget'ta bir hata oluştu

Bu Blogda Ara

Contributor

Contributor
Mustafa ULUSARAÇ İstanbul, TÜRKİYE
free counters
T. C. Central Bank Indicative Exchange Rates
Currency Exchange Rate Widget,Currency Converter Widget
Borsa İstanbul