'Daha önce hiç böyle bir Unload Gördünüzmü..!!
'Alin size insanoglunun geldigi son nokta :-))
'Standart Form UnLoad Clicklerinden bikanlara güzel bir kod.
'Asagida belirttigim gibi (+,-) ayarlarini kendi göz
'zevkinize göre degistirebilirsiniz...
'******************************************************************************
'Burdan Copy/Paste yapin...
Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next
Me.WindowState = 0
 
Do
Me.Top = Me.Top + 10
Me.Left = Me.Left + 10
Me.Width = Me.Width - 20
Me.Height = Me.Height - 20
'Üstteki (+,-) ayarlari Formunuzun küçülerek
'kapanacagi yönü, hizini ve Kapanma boyutunu
'gösterir. Kendi göz zevkinize göre degistirebilirsiniz.
'Deneye deneye güsel bir Unload yapabilirsiniz...
Loop Until Me.Top = Screen.Height
End Sub

Private Sub Form_Load()
Msflexgrid1.cols = 8
Msflexgrid1.rows = 8
End Sub

Private Sub Form_Load()
Msflexgrid1.col = 0
Msflexgrid1.row = 5
Msflexgrid1.Text= "Ahmet"
End Sub

Dim dön1 'döngü için tanıttık
Private Sub Form_Load()
For dön1 = 0 to 5 'sütün sayısı 0 ila 5 arası
For dön2 = 0 to 2 'sıra sayısı 0 ila 2 arası
Msflexgrid1.col = dön1
Msflexgrid1.row = dön2
Msflexgrid1.Text = "Ahmet" '6*3 lük bir alandaki bütün hücrelerin içeriği Ahmet oldu
Next dön2 'döngüye devam
Next dön1
End Sub

'Forma Yazilacak Kisim Burdan itibaren Baslamaktadir....(Copy Paste yapsaniz yeterli olur.)
'Yardim ve Bilgi icin lutfen bana yaziniz...
'SessizAdam
'[Linkleri görebilmek için üye olun veya giriş yapın.]
Option Explicit
Dim xAngle As GLfloat
Dim yAngle As GLfloat
Dim zAngle As GLfloat
Dim YScale As Long
Dim XScale As Long
Private Sub Form_Load()
Dim hGLRC As Long
Dim fAspect As GLfloat
Call InitializeArrays
Form1.ScaleMode = 3
xAngle = 0
yAngle = 0
zAngle = 0
SetupPixelFormat hDC
hGLRC = wglCreateContext(hDC)
wglMakeCurrent hDC, hGLRC
glEnable GL_DEPTH_TEST
glEnable GL_DITHER
glDepthFunc GL_LESS
glClearDepth 1
glClearColor 0, 0, 0, 0
glMatrixMode GL_PROJECTION
glLoadIdentity
If Form1.ScaleHeight > 0 Then
fAspect = Form1.ScaleWidth / Form1.ScaleHeight
Else
fAspect = 0
End If
gluPerspective 60, fAspect, 1, 2000
glViewport 0, 0, Form1.ScaleWidth, Form1.ScaleHeight
 
glMatrixMode GL_MODELVIEW
glLoadIdentity
glLightfv GL_LIGHT0, GL_POSITION, LightPos(0)
glEnable GL_LIGHTING
glEnable GL_LIGHT0
glShadeModel GL_SMOOTH
glFrontFace GL_CCW
glMaterialfv GL_FRONT, GL_SPECULAR, SpecRef(0)
glMateriali GL_FRONT, GL_SHININESS, 50
BuildCube
Form_Paint
End Sub
Private Sub Form_Paint()
Dim i As Integer
Dim a As Integer
Dim b As Integer
Dim c As Integer
glLoadIdentity
gluLookAt m_Translate_X, m_Translate_Y, m_Translate_Z, m_Translate_X + (100# * (Cos(m_camera_radsFromEast))), m_Translate_Y + m_camera_direction_y, m_Translate_Z - (100# * Sin(m_camera_radsFromEast)), 0#, 1#, 0#
 
glClear GL_COLOR_BUFFER_BIT Or GL_DEPTH_BUFFER_BIT
glPushMatrix
glTranslatef 0, 0, -3
glRotatef xAngle, 0.1, 0, 0
glRotatef yAngle, 0, 0.1, 0
glRotatef zAngle, 0, 0, 1
glCallList m_Cube
glPopMatrix
glPushMatrix
glTranslatef 0, -2, 0
glPopMatrix
SwapBuffers hDC
End Sub
Private Sub Form_Resize()
glViewport 0, 0, Form1.ScaleWidth, Form1.ScaleHeight
Form_Paint
End Sub
Private Sub Form_Unload(Cancel As Integer)
If hGLRC <> 0 Then
wglMakeCurrent 0, 0
wglDeleteContext hGLRC
End If
If hPalette <> 0 Then
DeleteObject hPalette
End If
End Sub
Sub BuildCube()
Dim i As Integer
Dim a As Integer
Dim b As Integer
Dim c As Integer
m_Cube = glGenLists(1)
glNewList m_Cube, GL_COMPILE_AND_EXECUTE
For i = 0 To TRIANGLE_COUNT - 1
a = index(i, 0)
b = index(i, 1)
c = index(i, 2)
Call RenderTriangle(a, b, c)
Next
glEnd
glEndList
End Sub
Private Sub Timer1_Timer()
YScale = YScale + 1
XScale = XScale + 1
yAngle = YScale
xAngle = XScale
If YScale = 359 Then
YScale = 0
XScale = 0
End If
Form_Paint
End Sub
'Forma Yazilacak Kisim Burda Sona erdi (Umarim Copy Paste Yapmissinizdir.)

Option Explicit
Private Type PALETTEENTRY
peRed As Byte
peGreen As Byte
peBlue As Byte
peFlags As Byte
End Type
Private Type LOGPALETTE
palVersion As Integer
palNumEntries As Integer
palPalEntry(0 To 255) As PALETTEENTRY
End Type
Private Type PIXELFORMATDESCRIPTOR
nSize As Integer
nVersion As Integer
dwFlags As Long
iPixelType As Byte
cColorBits As Byte
cRedBits As Byte
cRedShift As Byte
cGreenBits As Byte
cGreenShift As Byte
cBlueBits As Byte
cBlueShift As Byte
cAlphaBits As Byte
cAlphaShift As Byte
cAccumBits As Byte
cAccumRedBits As Byte
cAccumGreenBits As Byte
cAccumBlueBits As Byte
cAccumAlpgaBits As Byte
cDepthBits As Byte
cStencilBits As Byte
cAuxBuffers As Byte
iLayerType As Byte
bReserved As Byte
dwLayerMask As Long
dwVisibleMask As Long
dwDamageMask As Long
End Type
Const PFD_TYPE_RGBA = 0
Const PFD_TYPE_COLORINDEX = 1
Const PFD_MAIN_PLANE = 0
Const PFD_DOUBLEBUFFER = 1
Const PFD_DRAW_TO_WINDOW = &H4
Const PFD_SUPPORT_OPENGL = &H20
Const PFD_NEED_PALETTE = &H80
Private Declare Function ChoosePixelFormat Lib "gdi32" (ByVal hDC As Long, pfd As PIXELFORMATDESCRIPTOR) As Long
Private Declare Function CreatePalette Lib "gdi32" (pPal As LOGPALETTE) As Long
Private Declare Sub DeleteObject Lib "gdi32" (hObject As Long)
Private Declare Sub DescribePixelFormat Lib "gdi32" (ByVal hDC As Long, ByVal PixelFormat As Long, ByVal nBytes As Long, pfd As PIXELFORMATDESCRIPTOR)
Private Declare Function GetDC Lib "gdi32" (ByVal hWnd As Long) As Long
Private Declare Function GetPixelFormat Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Sub GetSystemPaletteEntries Lib "gdi32" (ByVal hDC As Long, ByVal start As Long, ByVal entries As Long, ByVal ptrEntries As Long)
Private Declare Sub RealizePalette Lib "gdi32" (ByVal hPalette As Long)
Private Declare Sub SelectPalette Lib "gdi32" (ByVal hDC As Long, ByVal hPalette As Long, ByVal bln As Long)
Private Declare Function SetPixelFormat Lib "gdi32" (ByVal hDC As Long, ByVal i As Long, pfd As PIXELFORMATDESCRIPTOR) As Boolean
Private Declare Sub SwapBuffers Lib "gdi32" (ByVal hDC As Long)
Private Declare Function wglCreateContext Lib "OpenGL32" (ByVal hDC As Long) As Long
Private Declare Sub wglDeleteContext Lib "OpenGL32" (ByVal hContext As Long)
Private Declare Sub wglMakeCurrent Lib "OpenGL32" (ByVal l1 As Long, ByVal l2 As Long)
Public hPalette As Long
Public hGLRC As Long
Public LightPos(3) As GLfloat
Public SpecRef(3) As GLfloat
Public Diffuse(3) As GLfloat
Public Const TRIANGLE_COUNT = 12
Public vdata(23, 2) As GLfloat
Public vcolor(23, 2) As GLfloat
Public index(TRIANGLE_COUNT, 3) As GLfloat
Public m_Grid As Integer
Public m_Cube As Integer
Public m_Translate_X As Integer
Public m_Translate_Y As Integer
Public m_Translate_Z As Integer
Public m_camera_radsFromEast As GLfloat
Public m_translationUnit As Double
Public m_camera_direction_y As Integer
Sub FatalError(ByVal strMessage As String)
MsgBox "Fatal Error: " & strMessage, vbCritical + vbApplicationModal + vbOKOnly + vbDefaultButton1, "Fatal Error In " & App.Title
Unload frmMain
Set frmMain = Nothing
End
End Sub
Sub SetupPixelFormat(ByVal hDC As Long)
Dim pfd As PIXELFORMATDESCRIPTOR
Dim PixelFormat As Integer
pfd.nSize = Len(pfd)
pfd.nVersion = 1
pfd.dwFlags = PFD_SUPPORT_OPENGL Or PFD_DRAW_TO_WINDOW Or PFD_DOUBLEBUFFER Or PFD_TYPE_RGBA
pfd.iPixelType = PFD_TYPE_RGBA
pfd.cColorBits = 24
pfd.cDepthBits = 24
pfd.iLayerType = PFD_MAIN_PLANE
PixelFormat = ChoosePixelFormat(hDC, pfd)
If PixelFormat = 0 Then FatalError "Could not retrieve pixel format!"
SetPixelFormat hDC, PixelFormat, pfd
End Sub
Sub SetupPalette(ByVal lhDC As Long)
Dim PixelFormat As Long
Dim pfd As PIXELFORMATDESCRIPTOR
Dim pPal As LOGPALETTE
Dim PaletteSize As Long
PixelFormat = GetPixelFormat(lhDC)
DescribePixelFormat lhDC, PixelFormat, Len(pfd), pfd
If (pfd.dwFlags And PFD_NEED_PALETTE) <> 0 Then
PaletteSize = 2 ^ pfd.cColorBits
Else
Exit Sub
End If
pPal.palVersion = &H300
pPal.palNumEntries = PaletteSize
Dim redMask As Long
Dim GreenMask As Long
Dim BlueMask As Long
Dim i As Long
redMask = 2 ^ pfd.cRedBits - 1
GreenMask = 2 ^ pfd.cGreenBits - 1
BlueMask = 2 ^ pfd.cBlueBits - 1
For i = 0 To PaletteSize - 1
With pPal.palPalEntry(i)
.peRed = i
.peGreen = i
.peBlue = i
.peFlags = 0
End With
Next
GetSystemPaletteEntries frmMain.hDC, 0, 256, VarPtr(pPal.palPalEntry(0))
hPalette = CreatePalette(pPal)
If hPalette <> 0 Then
SelectPalette lhDC, hPalette, False
RealizePalette lhDC
End If
End Sub
Public Sub InitializeArrays()
m_Translate_X = 0
m_Translate_Z = 5
m_translationUnit = 1
m_camera_direction_y = 0
m_camera_radsFromEast = 1.56
LightPos(0) = 0
LightPos(1) = 2
LightPos(2) = 2
LightPos(3) = 1
SpecRef(0) = 1#
SpecRef(1) = 0#
SpecRef(2) = 0#
SpecRef(3) = 1#
 
'Front (0-3)
vdata(0, 0) = 1
vdata(0, 1) = 1
vdata(0, 2) = 1
vdata(1, 0) = 1
vdata(1, 1) = -1
vdata(1, 2) = 1
vdata(2, 0) = -1
vdata(2, 1) = -1
vdata(2, 2) = 1
vdata(3, 0) = -1
vdata(3, 1) = 1
vdata(3, 2) = 1
'back (4-7)
vdata(4, 0) = 1#
vdata(4, 1) = 1#
vdata(4, 2) = -1#
vdata(5, 0) = 1#
vdata(5, 1) = -1#
vdata(5, 2) = -1#
vdata(6, 0) = -1#
vdata(6, 1) = -1#
vdata(6, 2) = -1#
vdata(7, 0) = -1#
vdata(7, 1) = 1#
vdata(7, 2) = -1#
'right (8-11)
vdata(8, 0) = 1#
vdata(8, 1) = 1#
vdata(8, 2) = 1#
vdata(9, 0) = 1#
vdata(9, 1) = 1#
vdata(9, 2) = -1#
vdata(10, 0) = 1#
vdata(10, 1) = -1#
vdata(10, 2) = -1#
vdata(11, 0) = 1#
vdata(11, 1) = -1#
vdata(11, 2) = 1#
'left (12-15)
vdata(12, 0) = -1#
vdata(12, 1) = 1#
vdata(12, 2) = 1#
vdata(13, 0) = -1#
vdata(13, 1) = 1#
vdata(13, 2) = -1#
vdata(14, 0) = -1#
vdata(14, 1) = -1#
vdata(14, 2) = -1#
vdata(15, 0) = -1#
vdata(15, 1) = -1#
vdata(15, 2) = 1#
'Top (16-20)
vdata(16, 0) = 1#
vdata(16, 1) = 1#
vdata(16, 2) = 1#
vdata(17, 0) = 1#
vdata(17, 1) = 1#
vdata(17, 2) = -1#
vdata(18, 0) = -1#
vdata(18, 1) = 1#
vdata(18, 2) = -1#
vdata(19, 0) = -1#
vdata(19, 1) = 1#
vdata(19, 2) = 1#
'Botton
vdata(20, 0) = 1#
vdata(20, 1) = -1#
vdata(20, 2) = 1#
vdata(21, 0) = 1#
vdata(21, 1) = -1#
vdata(21, 2) = -1#
vdata(22, 0) = -1#
vdata(22, 1) = -1#
vdata(22, 2) = -1#
vdata(23, 0) = -1#
vdata(23, 1) = -1#
vdata(23, 2) = 1#
 
'Index
'front
index(0, 0) = 0
index(0, 1) = 1
index(0, 2) = 2
index(1, 0) = 0
index(1, 1) = 2
index(1, 2) = 3
'Back
index(2, 0) = 4
index(2, 1) = 6
index(2, 2) = 5
index(3, 0) = 4
index(3, 1) = 7
index(3, 2) = 6
'Right
index(4, 0) = 8
index(4, 1) = 9
index(4, 2) = 10
index(5, 0) = 8
index(5, 1) = 10
index(5, 2) = 11
'Left
index(6, 0) = 12
index(6, 1) = 14
index(6, 2) = 13
index(7, 0) = 12
index(7, 1) = 15
index(7, 2) = 14
'Top
index(8, 0) = 16
index(8, 1) = 18
index(8, 2) = 17
index(9, 0) = 16
index(9, 1) = 19
index(9, 2) = 18
'Bottom
index(10, 0) = 20
index(10, 1) = 21
index(10, 2) = 22
index(11, 0) = 20
index(11, 1) = 22
index(11, 2) = 23
'Color
'front
vcolor(0, 0) = 1
vcolor(0, 1) = 1
vcolor(0, 2) = 1
vcolor(1, 0) = 1
vcolor(1, 1) = 0
vcolor(1, 2) = 1
vcolor(2, 0) = 0
vcolor(2, 1) = 0
vcolor(2, 2) = 1
vcolor(3, 0) = 0
vcolor(3, 1) = 1
vcolor(3, 2) = 1
'back
vcolor(4, 0) = 1#
vcolor(4, 1) = 1#
vcolor(4, 2) = 0#
vcolor(5, 0) = 1#
vcolor(5, 1) = 0#
vcolor(5, 2) = 0#
vcolor(6, 0) = 0#
vcolor(6, 1) = 0#
vcolor(6, 2) = 0#
vcolor(7, 0) = 0#
vcolor(7, 1) = 1#
vcolor(7, 2) = 0#
'right
vcolor(8, 0) = 1#
vcolor(8, 1) = 1#
vcolor(8, 2) = 1#
vcolor(9, 0) = 1#
vcolor(9, 1) = 1#
vcolor(9, 2) = 0#
vcolor(10, 0) = 1#
vcolor(10, 1) = 0#
vcolor(10, 2) = 0#
vcolor(11, 0) = 1#
vcolor(11, 1) = 0#
vcolor(11, 2) = 1#
'left
vcolor(12, 0) = 0#
vcolor(12, 1) = 0.1
vcolor(12, 2) = 1#
vcolor(13, 0) = 0#
vcolor(13, 1) = 1#
vcolor(13, 2) = 0#
vcolor(14, 0) = 0#
vcolor(14, 1) = 0#
vcolor(14, 2) = 0#
vcolor(15, 0) = 0#
vcolor(15, 1) = 0#
vcolor(15, 2) = 1#
'Top
vcolor(16, 0) = 1#
vcolor(16, 1) = 1#
vcolor(16, 2) = 1#
vcolor(17, 0) = 1#
vcolor(17, 1) = 1#
vcolor(17, 2) = 0#
vcolor(18, 0) = 0#
vcolor(18, 1) = 1#
vcolor(18, 2) = 0#
vcolor(19, 0) = 0#
vcolor(19, 1) = 1#
vcolor(19, 2) = 1#
'Bottom
vcolor(20, 0) = 1#
vcolor(20, 1) = 0#
vcolor(20, 2) = 1#
vcolor(21, 0) = 1#
vcolor(21, 1) = 0#
vcolor(21, 2) = 0#
vcolor(22, 0) = 0#
vcolor(22, 1) = 0#
vcolor(22, 2) = 0#
vcolor(23, 0) = 0#
vcolor(23, 1) = 0#
vcolor(23, 2) = 1#
 
End Sub
Public Sub RenderTriangle(a As Integer, b As Integer, c As Integer)
Dim x1 As GLfloat
Dim y1 As GLfloat
Dim z1 As GLfloat
Dim lRC As Long
Dim x2 As GLfloat
Dim y2 As GLfloat
Dim z2 As GLfloat
Dim x3 As GLfloat
Dim y3 As GLfloat
Dim z3 As GLfloat
Dim v1(3) As GLfloat
Dim v2(3) As GLfloat
Dim v3(3) As GLfloat
Dim v(3) As GLfloat
Dim w(3) As GLfloat
Dim out(3) As GLfloat
Dim r1 As GLfloat
Dim g1 As GLfloat
Dim b1 As GLfloat
Dim r2 As GLfloat
Dim g2 As GLfloat
Dim b2 As GLfloat
Dim r3 As GLfloat
Dim g3 As GLfloat
Dim b3 As GLfloat
b1 = vcolor(a, 1)
g1 = vcolor(a, 2)
r2 = vcolor(b, 0)
b2 = vcolor(b, 1)
g2 = vcolor(b, 2)
r3 = vcolor(c, 0)
b3 = vcolor(c, 1)
g3 = vcolor(c, 2)
v1(0) = vdata(a, 0)
v1(1) = vdata(a, 1)
v1(2) = vdata(a, 2)
x1 = vdata(a, 0)
y1 = vdata(a, 1)
z1 = vdata(a, 2)
v2(0) = vdata(b, 0)
v2(1) = vdata(b, 1)
v2(2) = vdata(b, 2)
x2 = vdata(b, 0)
y2 = vdata(b, 1)
z2 = vdata(b, 2)
v3(0) = vdata(c, 0)
v3(1) = vdata(c, 1)
v3(2) = vdata(c, 2)
x3 = vdata(c, 0)
y3 = vdata(c, 1)
z3 = vdata(c, 2)
'--------------------------------------------------------------------
 
v(0) = x2 - x1
v(1) = y2 - y1
v(2) = z2 - z1
w(0) = x3 - x2
w(1) = y3 - y2
w(2) = z3 - z2
Call normcrossprod(v, w, out)
glBegin (GL_TRIANGLES)
'Flip the normal
glNormal3f -1 * out(0), -1 * out(1), -1 * out(2)
Diffuse(0) = r1
Diffuse(1) = b1
Diffuse(2) = g1
Diffuse(3) = 1
glMaterialfv GL_FRONT, GL_AMBIENT_AND_DIFFUSE, Diffuse(0)
glVertex3f v1(0), v1(1), v1(2)
Diffuse(0) = r2
Diffuse(1) = b2
Diffuse(2) = g2
Diffuse(3) = 1
glMaterialfv GL_FRONT, GL_AMBIENT_AND_DIFFUSE, Diffuse(0)
glVertex3f v2(0), v2(1), v2(2)
Diffuse(0) = r3
Diffuse(1) = b3
Diffuse(2) = g3
Diffuse(3) = 1
glMaterialfv GL_FRONT, GL_AMBIENT_AND_DIFFUSE, Diffuse(0)
glVertex3f v3(0), v3(1), v3(2)
glEnd
End Sub
Public Sub normalize(out() As GLfloat)
Dim d As GLfloat
d = Sqr(out(0) * out(0) + out(1) * out(1) + out(2) * out(2))
If (d = 0) Then
Exit Sub
End If
out(0) = out(0) / d
out(1) = out(1) / d
out(2) = out(2) / d
End Sub
Public Sub normcrossprod(v() As GLfloat, w() As GLfloat, out() As GLfloat)
'[Vx Vy Vz] X [Wx Wy Wz] =[(Vy*Wz-Wy*Vz),(Wx*Vz-Vx*Wz),(Vx*Wy-Wx*Vy)]
out(0) = v(1) * w(2) - w(1) * v(2)
out(1) = w(0) * v(2) - v(0) * w(2)
out(2) = v(0) * w(1) - w(0) * v(1)
Call normalize(out)
End Sub
 

(declaretions)
Dim DX7 As DirectX7
Dim DSAs DirectSound
Dim DSB As DirectSoundBuffer 'Burada DSB'yi array olarak kullanabilirsiniz. Örneğin; Dim DSB(10) As DirectSoundBuffer
Dim bufferDesc As DSBUFFERDESC
Dim waveFormat As WAVEFORMATEX
 
 
Private Sub Form_Load()
Set DX7 = New DirectX7 'Direct X 'i çalıştıralım
Set DS = DX7.DirectSoundCreate("") 'DirectSound'u açalım
 
 
DS.SetCooperativeLevel Me.hWdn, DSSCL_PRIORITY 'DirectSound'un bu form üzerinden çalışacağını belirtelim
 
 
' Ses özelliklerini belirleyelim
bufferDesc.lBufferBytes = 16384
bufferDesc.lFlags = DSBCAPS_CTRLFREQUENCY Or DSBCAPS_CTRLPAN Or DSBCAPS_CTRLVOLUME Or DSBCAPS_STATIC
waveFormat.nFormatTag = WAVE_FORMAT_PCM
waveFormat.nChannels = 16
waveFormat.lSamplesPerSec = 44100
waveFormat.nBitsPerSample = 16
waveFormat.nBlockAlign = waveFormat.nBitsPerSample / 8 * waveFormat.nChannels
waveFormat.lAvgBytesPerSec = waveFormat.lSamplesPerSec * waveFormat.nBlockAlign
 
 
' Dosyayı RAM'e yükletelim
Set DSB = DS.CreateBufferFromFile ("dosyaadi.wav",bufferdesc,waveformat)
End Sub
 
 
Private Sub CmdChal_Click()
DSB.Play DSPLAY_DEFAULT 'eğer DSPLAY_DEFAULT yerine DSPLAY_LOOPING derseniz sürekli başa sarıp hiç beklemeden tekrar çalacaktır.
End Sub
 
 
Private Sub CmdDurk_Click()
DSB.Stop
End Sub
 
 
Private Sub CmdDur_Click()
DSB.Stop
DSB.SetCurrentPosition 1
End Sub

Function tobinary(x As Integer) As String
Dim s As String
If x = 0 Then
s = "0"
Else
s = ""
While x <> 0
s = (x Mod 2) & s
x = Int(x / 2)
Wend
End If
If Len(s) = 1 Then s = "0000000" + s
If Len(s) = 2 Then s = "000000" + s
If Len(s) = 3 Then s = "00000" + s
If Len(s) = 4 Then s = "0000" + s
If Len(s) = 5 Then s = "000" + s
If Len(s) = 6 Then s = "00" + s
If Len(s) = 7 Then s = "0" + s
tobinary = s
End Function

Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Type pAttributes
fontName As String * 25
fontSize As Integer
fontBold As Boolean
fontColor As Long
textString As String * 60
textBufferBox As PictureBox
textBufferWidth As Integer
textBufferHeight As Integer
textLocX As Integer
textLocY As Integer
scrBufferBox As PictureBox
LastX As Integer
LastY As Integer
End Type

Public Declare Function GetDesktopWindow Lib "user32" () As Long
Public Declare Function GetWindowDC Lib "user32" (ByVal hWnd As Long) As Long
Public Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Public Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Public Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Public Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long

Public Sub PrintOnScreen(ByRef textAttrib As pAttributes)
Dim hDcDsk As Long, hWndDsk As Long
Dim Rec As RECT
Dim winW As Long, winH As Long
Dim X As Long, Y As Long, c As Long, orgC As Long
' PictureBox için gerekli olan ayarlari yapalim..
textAttrib.textBufferBox.Font.Name = textAttrib.fontName
textAttrib.textBufferBox.fontBold = textAttrib.fontBold
textAttrib.textBufferBox.ForeColor = textAttrib.fontColor
textAttrib.textBufferBox.fontSize = textAttrib.fontSize
textAttrib.textBufferBox.Width = textAttrib.textBufferWidth * Screen.TwipsPerPixelX
textAttrib.textBufferBox.Height = textAttrib.textBufferHeight * Screen.TwipsPerPixelY
textAttrib.scrBufferBox.Width = Screen.Width
textAttrib.scrBufferBox.Height = Screen.Height
textAttrib.scrBufferBox.BackColor = textAttrib.fontColor
textAttrib.textBufferBox.AutoRedraw = True
textAttrib.scrBufferBox.AutoRedraw = True
textAttrib.textBufferBox.Visible = False
textAttrib.scrBufferBox.Visible = False
' Yaziyi pictureBox' a yazdiralim,
textAttrib.textBufferBox.Cls
textAttrib.scrBufferBox.Cls
textAttrib.textBufferBox.Print textAttrib.textString
GetWindowRect textAttrib.textBufferBox.hWnd, Rec ' Picture Box' in boyutlarini alalim..
winW = Rec.Right - Rec.Left ' Genisligi ve yüksekligi hesaplayalim
winH = Rec.Bottom - Rec.Top
hWndDsk = GetDesktopWindow ' Ekranin handle ini alalim
hDcDsk = GetWindowDC(hWndDsk) ' ve bu handle a ait olan hDc(Handle Direct Call) numarasini
' alalim.
For X = 0 To winW
For Y = 0 To winH
c = GetPixel(textAttrib.textBufferBox.hdc, X, Y) 'PictureBox üzerindeki rengi alalim,
If c = textAttrib.fontColor Then 'Eger secilen renk, belirledigimiz renkse..
' Ekran üzerindeki orjinal rengi alalim ve diger picturebox a yazalim.
orgC = GetPixel(hDcDsk, textAttrib.textLocX + X, textAttrib.textLocY + Y)
' Ekran üzerine PictureBox dan aldigimiz rengi koyalim.
SetPixel hDcDsk, textAttrib.textLocX + X, textAttrib.textLocY + Y, c
' Diger picturebox a ekran üzerinden aldigimiz rengi koyalim.
SetPixel textAttrib.scrBufferBox.hdc, textAttrib.textLocX + X, textAttrib.textLocY + Y, orgC
DoEvents
textAttrib.LastX = textAttrib.textLocX + X ' En son nokta koyulan koordinatlari kaydedelim.
End If
Next Y ' Y yi döndür.
textAttrib.LastY = textAttrib.textLocY + Y
Next X ' X i döndür.
End Sub
Public Sub ClearScreen(ByRef textAttrib As pAttributes)
Dim hDcDsk As Long, hWndDsk As Long
Dim Rec As RECT
Dim winW As Long, winH As Long
Dim X As Long, Y As Long, c As Long, orgC As Long
hWndDsk = GetDesktopWindow ' Ekranin handle ini alalim
hDcDsk = GetWindowDC(hWndDsk) ' ve bu handle a ait olan hDc(Handle Direct Call) numarasini
' alalim.
For X = 0 To textAttrib.LastX
For Y = 0 To textAttrib.LastY
c = GetPixel(textAttrib.scrBufferBox.hdc, X, Y)
If Not c = textAttrib.fontColor Then
SetPixel hDcDsk, X, Y, c ' PictureBox tan alıp ekrana yazalim
DoEvents
End If
Next Y
Next X
End Sub
 
' Şimdi en son tanımlamalara yani değişkenlere geldik. Aşağıdaki değişkenleri Formda tanımlamayı unutmayınız.
Private myText As pAttributes
' Sonunda geldik programın kodlarına. Aşağıdaki kodları programınıza direk olarak kopyalamadan önce programınıza btnClear(CommandButton) , btnPrint(CommandButton), Picture1,Picture2(PictureBox) olarak 2 adet picturebox ekleyiniz ve 1 tane de txtString(TextBox) ekleyiniz.
Private Sub btnClear_Click()
ClearScreen myText
End Sub
Private Sub btnPrint_Click()
PrintOnScreen myText
End Sub
Private Sub Form_Load()
myText.fontName = "Sans"
myText.fontBold = True
myText.fontSize = 12
myText.fontColor = RGB(255, 0, 0)
Set myText.scrBufferBox = Picture2
Set myText.textBufferBox = Picture1
myText.textBufferWidth = 300
myText.textBufferHeight = 100
myText.textLocX = 100
myText.textLocY = 100
myText.textString = txtString.Text
End Sub

Private Sub Command1_Click()
Randomize Timer
text1.Caption = Int(Rnd * 49) + 1
text2.Caption = Int(Rnd * 49) + 1
text3.Caption = Int(Rnd * 49) + 1
text4.Caption = Int(Rnd * 49) + 1
text5.Caption = Int(Rnd * 49) + 1
text6.Caption = Int(Rnd * 49) + 1
End Sub
Private Sub Text1_Change()
If text1.Caption = text2.Caption Or text1.Caption = text3.Caption Or text1.Caption = text4.Caption Or text1.Caption = text5.Caption Or text1.Caption = text6.Caption Then
text1.Caption = Int(Rnd * 49) + 1
End If
End Sub
Private Sub Text2_Change()
If text2.Caption = text1.Caption Or text2.Caption = text3.Caption Or text2.Caption = text4.Caption Or text2.Caption = text5.Caption Or text2.Caption = text6.Caption Then
text2.Caption = Int(Rnd * 49) + 1
End If
End Sub
Private Sub Text3_Change()
If text3.Caption = text1.Caption Or text3.Caption = text2.Caption Or text3.Caption = text4.Caption Or text3.Caption = text5.Caption Or text3.Caption = text6.Caption Then
text3.Caption = Int(Rnd * 49) + 1
End If
End Sub
Private Sub Text4_Change()
If text4.Caption = text1.Caption Or text4.Caption = text2.Caption Or text4.Caption = text3.Caption Or text4.Caption = text5.Caption Or text4.Caption = text6.Caption Then
text4.Caption = Int(Rnd * 49) + 1
End If
End Sub
Private Sub Text5_Change()
If text5.Caption = text1.Caption Or text5.Caption = text2.Caption Or text5.Caption = text3.Caption Or text5.Caption = text4.Caption Or text5.Caption = text6.Caption Then
text5.Caption = Int(Rnd * 49) + 1
End If
End Sub
Private Sub Text6_Change()
If text6.Caption = text1.Caption Or text6.Caption = text2.Caption Or text6.Caption = text3.Caption Or text6.Caption = text4.Caption Or text6.Caption = text5.Caption Then
text6.Caption = Int(Rnd * 49) + 1
End If
End Sub

Dim b$(9)
Dim y$(9)
Dim m$(4)
Dim v(15)
Dim c(3)
Private Sub Form_Load()
Text1.Text = Yaziyla$(15000)
End Sub
Function Yaziyla$(sayi)
b$(0) = ""
b$(1) = "Bir"
b$(2) = "Yki"
b$(3) = "Üç"
b$(4) = "Dört"
b$(5) = "Be?"
b$(6) = "Alty"
b$(7) = "Yedi"
b$(8) = "Sekiz"
b$(9) = "Dokuz"
y$(0) = ""
y$(1) = "On"
y$(2) = "Yirmi"
y$(3) = "Otuz"
y$(4) = "Kyrk"
y$(5) = "Elli"
y$(6) = "Altmy?"
y$(7) = "Yetmi?"
y$(8) = "Seksen"
y$(9) = "Doksan"
m$(0) = "Trilyon"
m$(1) = "Milyar"
m$(2) = "Milyon"
m$(3) = "Bin"
m$(4) = ""
a$ = Str(sayi)
If Left$(a$, 1) = " " Then pozitif = 1 Else pozitif = 0
a$ = Right$(a$, Len(a$) - 1)
For x = 1 To Len(a$)
If (Asc(Mid$(a$, x, 1)) > Asc("9")) Or (Asc(Mid$(a$, x, 1))
< Asc("0")) Then GoTo hataNext xIf Len(a$) > 15 Then GoTo hata
a$ = String(15 - Len(a$), "0") + a$
For x = 1 To 15
v(x) = Val(Mid$(a$, x, 1))
Next x
s$ = ""
For x = 0 To 4
c(1) = v((x * 3) + 1)
c(2) = v((x * 3) + 2)
c(3) = v((x * 3) + 3)
If c(1) = 0 Then
e$ = ""
ElseIf c(1) = 1 Then
e$ = "Yüz"
Else
e$ = b$(c(1)) + "Yüz"
End If
e$ = e$ + y$(c(2)) + b$(c(3))
If e$ <> "" Then e$ = e$ + m$(x)
If (x = 3) And (e$ = "BirBin") Then e$ = "Bin"
s$ = s$ + e$
Next x
If s$ = "" Then s$ = "Syfyr"
If pozitif = 0 Then s$ = "Eksi" + s$
Yaziyla$ = s$
GoTo tamam
hata: Yaziyla$ = "Hata"
End Function

Private Sub cmdgonder_Click()
On Error GoTo hata
Mesaj = txtmesaj.Text
MSComm.Output = Mesaj
Exit Sub
hata:
MsgBox "Mesaj Yollanamadı"
End Sub
Private Sub Form_Load()
MSComm.CommPort = 1
MSComm.Settings = "9600,N,8,1"
On Local Error GoTo hata
MSComm.PortOpen = True
Exit Sub
hata:
MsgBox "Port Acılamıyor"
End Sub

Private Sub cmdAra_Click()
On Error GoTo Hata
num = txtnumara.Text
MSComm.Output = "ATDT" & num & vbCr
Exit Sub
Hata:
MsgBox "Hata"
End Sub
 
Private Sub Form_Load()
MSComm.CommPort = 4
MSComm.Settings = "9600,N,8,1"
On Local Error GoTo Hata
MSComm.PortOpen = True
Exit Sub
Hata:
MsgBox "Port Acılamıyor"
End Sub

 
What are you doing
What is she doing
What am i doing

RealString 'Kullanicinin bilgisayara söyleyecegi cümle

TheString = Lcase (RealString)
TheString = Replace ( TheString, " i ", " [su1] ")
TheString = Replace ( TheString, " you ", " [su1] ")
TheString = Replace ( TheString, " we ", " [su1] ")
TheString = Replace ( TheString, " he ", " [su1] ")
TheString = Replace ( TheString, " she ", " [su1] ")
TheString = Replace ( TheString, " it ", " [su1] ")
TheString = Replace ( TheString, " they ", " [su1] ")
if left (TheString, 2) = "i " then
TheString = "[sub1]" & Mid(TheString,2,len(TheString))
Goto RearCheck
end if
if left (TheString, 4) = "you " then
TheString = "[sub1]" & Mid(TheString,4,len(TheString))
Goto RearCheck
end if
if left (TheString, 3) = "he " then
TheString = "[sub1]" & Mid(TheString,3,len(TheString))
Goto RearCheck
end if
if left (TheString, 4) = "she " then
TheString = "[sub1]" & Mid(TheString,4,len(TheString))
Goto RearCheck
end if
if left (TheString, 3) = "it " then
TheString = "[sub1]" & Mid(TheString,3,len(TheString))
Goto RearCheck
end if
if left (TheString, 3) = "we " then
TheString = "[sub1]" & Mid(TheString,3,len(TheString))
Goto RearCheck
end if
if left (TheString, 5) = "they " then
TheString = "[sub1]" & Mid(TheString,5,len(TheString))
Goto RearCheck
end if
RearCheck:
if right (TheString, 5) = " they" then
TheString = left(TheString,len(TheString)-4) & "[su1]"
Goto CheckComplete
end if
if right (TheString, 3) = " we" then
TheString = left(TheString,len(TheString)-2) & "[su1]"
Goto CheckComplete
end if
if right (TheString, 4) = " you" then
TheString = left(TheString,len(TheString)-3) & "[su1]"
Goto CheckComplete
end if
if right (TheString, 4) = " she" then
TheString = left(TheString,len(TheString)-3) & "[su1]"
Goto CheckComplete
end if
if right (TheString, 3) = " he" then
TheString = left(TheString,len(TheString)-2) & "[su1]"
Goto CheckComplete
end if
if right (TheString, 2) = " i" then
TheString = left(TheString,len(TheString)-1) & "[su1]"
Goto CheckComplete
end if
if right (TheString, 3) = " it" then
TheString = left(TheString,len(TheString)-2) & "[su1]"
Goto CheckComplete
end if
CheckComplete

Dim txt As String

txt = LCase(Text)
txt = Replace(txt, " " & Find & " ", " " & Rep & " ")
if Left(txt, Len(Find) + 1) = Find & " " Then
txt = Rep & Mid(txt, Len(Find) + 1, Len(txt))
End if
if Right(txt, Len(Find) + 1) = " " & Find Then
txt = Left(txt, Len(txt) - Len(Find)) & Rep
End if
ShowinStructure = txt
End Function

TheString = ShowinStructure(TheString,"they","[su1]")

TheString = ShowinStructure(TheString,"he","[su1]")
TheString = ShowinStructure(TheString,"she","[su1]")
TheString = ShowinStructure(TheString,"it","[su1]")
TheString = ShowinStructure(TheString,"you","[su1]")
TheString = ShowinStructure(TheString,"i","[su1]")
TheString = ShowinStructure(TheString,"we","[su1]")

 

TheString = ShowinStructure(TheString, "be","[be]")
TheString = ShowinStructure(TheString, "am","[be]")
TheString = ShowinStructure(TheString, "is","[be]")
TheString = ShowinStructure(TheString, "are","[be]")

Public Declare Function GetWindowLong Lib "User32.dll" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long

Public Declare Function SetWindowLong Lib "User32.dll" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function SetLayeredWindowAttributes Lib "User32.dll" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Public Declare Function SetLayeredAttributes Lib "User32.dll" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Public Declare Function UpdateLayeredWindow Lib "User32.dll" (ByVal hWnd As Long, ByVal hdcDst As Long, pptDst As Any, psize As Any, ByVal hdcSrc As Long, pptSrc As Any, crKey As Long, ByVal pblend As Long, ByVal dwFlags As Long) As Long

Public Const GWL_STYLE = (-16)

Public Const GWL_EXSTYLE = (-20)
Public Const WS_EX_LAYERED = &H80000
Public Const ULW_COLORKEY = &H1
Public Const ULW_ALPHA = &H2
Public Const ULW_OPAQUE = &H4
Public Const AC_SRC_OVER = &H0
Public Const AC_SRC_ALPHA = &H1
Public Const AC_SRC_NO_PREMULT_ALPHA = &H1
Public Const AC_SRC_NO_ALPHA = &H2
Public Const AC_DST_NO_PREMULT_ALPHA = &H10
Public Const AC_DST_NO_ALPHA = &H20
Public Const LWA_COLORKEY = &H1
Public Const LWA_ALPHA = &H2

Public Sub MakeTransparent(hWnd, Rate)

Dim WinInfo As Long
On Local Error Resume Next
WinInfo = GetWindowLong(hWnd, GWL_EXSTYLE)
WinInfo = WinInfo Or WS_EX_LAYERED
On Local Error Resume Next
SetWindowLong hWnd, GWL_EXSTYLE, WinInfo
On Local Error Resume Next
SetLayeredWindowAttributes hWnd, 0, Rate, LWA_ALPHA
End Sub

For X = 0 To 254 Step -19

MakeTransparent Me.hWnd, X
Next
Me.Show

For X = 254 To 0 Step -19

MakeTransparent Me.hWnd, X
Next
End

'Fx = yazınn kağıt üzerinde yatay düzlemdeki yeri

'Fy = yazınn kağıt üzerinde dikey düzlemdeki yeri
'Fh=Font yüksekliği
'Fw=Font genişliği
'Fara = bir satırdaki harf sayısı, HARF SINIRI (FCH) nı aşdığında aşağıya geçer.Bu değişken iki satır arasındaki aralığın uzunluğudur.
'Fch bir satırdaki harf sayısı
Dim ZStr As String
Public Sub ZbrPrn(InWrd, Fx As Integer, Fy As Integer, Fh As Integer, Fw As Integer, Fara As Integer, FCh As Integer)
Dim Ad1 As String
Dim S As Integer
If Trim(InWrd) <> "" Then
Ad1 = ""
For S = 1 To Len(InWrd)
If S < Len(InWrd) And Len(Ad1) < FCh Then
Ad1 = Ad1 & Mid(InWrd, S, 1)
ElseIf S < Len(InWrd) And Len(Ad1) = FCh Then
Ad1 = Ad1 & Mid(InWrd, S, 1)
ZStr = ZStr & " ^FO" & Fx & "," & Fy & "^AON," & Fh & "," & Fw & "^FD" & Ad1 & "^FS"
Fy = Fy + Fara
Ad1 = ""
ElseIf S = Len(InWrd) Then
Ad1 = Ad1 & Mid(InWrd, S, 1)
ZStr = ZStr & " ^FO" & Fx & "," & Fy & "^AON," & Fh & "," & Fw & "^FD" & Ad1 & "^FS"
Ad1 = ""
End If
Next
End If
End Sub

Public Sub ZbrOut(MsComm1 As Object)
MsComm1.Output = ZStr
End Sub
Public Sub ZbrStr()
ZStr = "^XA"
End Sub
Public Sub ZbrEnd()
ZStr = ZStr & "^XZ"
End Sub
Public Sub ZbrClose(MsComm1 As Object)
MsComm1.PortOpen = False
End Sub
Public Sub ZbrOpen(MsComm1 As Object)
With MsComm1
.CommPort = Trim(UsrCfg.PortNo)
.Settings = Trim(UsrCfg.BpS) & "," & Trim(UsrCfg.Prt) & "," & Trim(UsrCfg.DBit) & "," & Trim(UsrCfg.SBit)
.PortOpen = True
.InputLen = 0
End With
End Sub
Private Sub Command1_Click()
ZbrOpen MsComm1
ZbrStr
ZbrPrn "BU BIR DENEMEDIR", 50, 50, 40, 20, 50, 30
ZbrEnd
ZbrOut MsComm1
ZbrClose MsComm1
End Sub

Private Sub Form_Load()
If App.PrevInstance Then
MsgBox "Program zaten çalışıyor"
End
End If
End Sub

Private Sub Form_Paint()
ScaleMode = 3 'pixel moduna geçir
For i = 0 To ScaleHeight
Line (0, i)-(ScaleWidth, i), i * 18000
Next
End Sub

Private Sub Form_Load()
Show
Dim a, b, i
a = Form1.ScaleWidth
b = Form1.ScaleHeight
For i = 0 To a
Line (i, i)-(a, b)
Line (a, i)-(i, b)
Next
For i = 1 To b / 2 Step b / 200
Circle (a / 2, b / 2), i
Next
End Sub

Dim cümle As String, kelime As String, hece As String, harf As String
Sub main()
cümle = InputBox("Metni yazın")
cümle = cümle + " "
MsgBox fonksiyon(cümle)
End Sub
 
Function fonksiyon(cümle As String) As String
For i = 1 To Len(cümle)
harf = Mid(cümle, i, 1) 'cümleyi harf harf inceleyerek kelime ayırmak için boşluk arıyor...
harf = harfayır(harf)
'kelime tamamlanmışsa
If harf = " " Then
fonksiyon = fonksiyon + hecele(kelime)
kelime = ""
harf = ""
End If
'tamamlanmamışsa harf eklemeye devam...
kelime = kelime + harf
Next i
cümle = ""
End Function
Function hecele(kelime As String) As String
For i = Len(kelime) To 1 Step -1 'kelimeyi tersten harf harf incele
harf = Mid(kelime, i, 1)
hece = harf + hece 'her harfi heceye kat
If Not sEsli(harf) Then 'sessiz harf ise hece bitmiş demektir
If Len(hece) > 1 Then 'hece başlıyor da olabilir, hece uzunluğunu kontrol et
'eğer hece 1 harften fazlaysa başlıyor değil bitmiştir.
If Len(hece) = 2 And sEsli(Left(hece, 1)) = sEsli(Right(hece, 1)) Then GoTo atla
'yalnız hecenin son iki harfi sessiz de olabilir buna da dikkat et, eğer iki harfte sessizse atla!
'eğer hece nin son iki harfi sessiz değilse hece bitmiş demektir. ayırarak geri göndermek üzere kaydet, aman dikkat ters sırada gönderme!
hecele = hece + " " + hecele 'o yüzden heceyi daha önceki hecelerin başına ekle ki ters sırada olmasın
hece = "" 'eklenmiş hece bitmiş demektir, baştan yeni hece için "hece"yi sıfırla!
atla:
End If
Else
'hecenin içinde arka arkaya gelen sesli harfleri ayırmak için şöyle yap:
If Len(hece) >= 2 And sEsli(Left(hece, 1)) And sEsli(Mid(hece, 2, 1)) Then hece = Left(hece, 1) + " " + Right(hece, Len(hece) - 1)
'sonrada eğer hece kelimenin ilk hecesi mi diye bak
If i = 1 Then
'eğer kelime inceleme bittiyse veya ilk heceye sıra geldiyse onuda hece olarak al
hecele = hece + " " + hecele
hece = ""
'heceyi sıfırlamayı unutma çünkü bu değişken global!
End If
End If
Next i
hece = ""
End Function
Function sEsli(harf As String) As Boolean
Select Case harf
Case "a", "e", "ı", "i", "o", "ö", "u", "ü"
sEsli = True
Case Else
sEsli = False
End Select
End Function
 
Function harfayır(harf As String) As String
Select Case Asc(harf)
Case 254, 222, 231, 199, 246, 214, 253, 252, 240, 208, 220, 221, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 114, 115, 116, 117, 118, 119, 120, 121, 122
harfayır = harf
Case Else
harfayır = " "
End Select
End Function

Private Sub Form_Load()
With Data1 [font=Arial][size=9][color=#ffffff][font=Arial][size=9][color=#ffffff][font=Arial][size=9][color=#ffffff]‘ Veri taban[/color][/size][/font][/color][/size][/font][/color][/size][/font][size=9][color=#ffffff][size=9][color=#ffffff]ı tanımları
.DatabaseName = "referans.mdb"
.RecordSource = "full"
.Connect = ";Pwd=eski"
.Refresh
End With
End Sub

Private Sub Command1_Click() [/color][/size][/color][/size][font=Arial][size=9][color=#ffffff][font=Arial][size=9][color=#ffffff][font=Arial][size=9][color=#ffffff]‘ [/color][/size][/font][/color][/size][/font][/color][/size][/font][font=Arial][size=9][color=#ffffff][font=Arial][size=9][color=#ffffff][font=Arial][size=9][color=#ffffff]Şifre değiştir
Data1.Database.NewPassword "eski", "yeni"
End Sub
[/color][/size][/font][/color][/size][/font][/color][/size][/font]

Dim a, b, c As String
    Private Sub VScrollBar1_Scroll(ByVal sender As System.Object, ByVal e
 As System.Windows.Forms.ScrollEventArgs) Handles VScrollBar1.Scroll
        a = VScrollBar1.Value
        Label1.Text = VScrollBar1.Value
        PictureBox1.BackColor = Drawing.ColorTranslator.FromOle(RGB(a, b, c))

    End Sub

    Private Sub VScrollBar2_Scroll(ByVal sender As System.Object, ByVal e
 As System.Windows.Forms.ScrollEventArgs) Handles VScrollBar2.Scroll
        b = VScrollBar2.Value
        Label2.Text = VScrollBar2.Value
        PictureBox1.BackColor = Drawing.ColorTranslator.FromOle(RGB(a, b, c))
    End Sub

    Private Sub VScrollBar3_Scroll(ByVal sender As System.Object, ByVal e
 As System.Windows.Forms.ScrollEventArgs) Handles VScrollBar3.Scroll
        c = VScrollBar3.Value
        Label3.Text = VScrollBar3.Value
        PictureBox1.BackColor = Drawing.ColorTranslator.FromOle(RGB(a, b, c))
    End Sub   

Dim isim As String
Private Sub Command1_Click()
a = Val(Text1)
b = Val(Text2)
c = Val(Text3)
d = Val(Text4)
e = Val(Text5)
Select Case a
Case 1: a1 = 2.044
Case 2: a1 = 4.088
Case 3: a1 = 6.132
Case 4: a1 = 8.176
Case 5: a1 = 10.22
Case 6: a1 = 12.264
Case 7: a1 = 14.308
Case 8: a1 = 16.352
Case 9: a1 = 18.396
Case 10: a1 = 20.44
Case 11: a1 = 22.484
Case 12: a1 = 24.528
Case 13: a1 = 26.572
Case 14: a1 = 28.616
Case 15: a1 = 30.66
Case 16: a1 = 32.704
Case 17: a1 = 34.748
Case 18: a1 = 36.792
Case 19: a1 = 38.836
Case 20: a1 = 40.88
Case 21: a1 = 42.924
Case 22: a1 = 44.968
Case 23: a1 = 47.012
Case 24: a1 = 49.056
Case 25: a1 = 51.1
Case 26: a1 = 53.144
Case 27: a1 = 55.188
Case 28: a1 = 57.232
Case 29: a1 = 59.276
Case 30: a1 = 61.32
Case 31: a1 = 63.364
Case 32: a1 = 65.408
Case 33: a1 = 67.452
Case 34: a1 = 69.496
Case 35: a1 = 71.54
Case 36: a1 = 73.584
Case 37: a1 = 75.628
Case 38: a1 = 77.672
Case 39: a1 = 79.716
Case 40: a1 = 81.76
Case 41: a1 = 83.804
Case 42: a1 = 85.848
Case 43: a1 = 87.862
Case 44: a1 = 89.936
Case 45: a1 = 91.98
End Select
Select Case b
Case 1: b1 = 1.252
Case 2: b1 = 2.504
Case 3: b1 = 3.756
Case 4: b1 = 5.008
Case 5: b1 = 6.26
Case 6: b1 = 7.512
Case 7: b1 = 8.764
Case 8: b1 = 10.016
Case 9: b1 = 11.268
Case 10: b1 = 12.52
Case 11: b1 = 13.772
Case 12: b1 = 15.024
Case 13: b1 = 16.276
Case 14: b1 = 17.528
Case 15: b1 = 18.78
Case 16: b1 = 20.032
Case 17: b1 = 21.284
Case 18: b1 = 22.536
Case 19: b1 = 23.788
Case 20: b1 = 25.04
Case 21: b1 = 26.292
Case 22: b1 = 27.544
Case 23: b1 = 28.796
Case 24: b1 = 30.048
Case 25: b1 = 31.3
Case 26: b1 = 32.552
Case 27: b1 = 33.804
Case 28: b1 = 35.056
Case 29: b1 = 36.308
Case 30: b1 = 37.56
Case 31: b1 = 38.812
Case 32: b1 = 40.064
Case 33: b1 = 41.316
Case 34: b1 = 42.568
Case 35: b1 = 43.82
Case 36: b1 = 45.072
Case 37: b1 = 46.324
Case 38: b1 = 47.576
Case 39: b1 = 48.828
Case 40: b1 = 50.08
Case 41: b1 = 51.332
Case 42: b1 = 52.584
Case 43: b1 = 53.836
Case 44: b1 = 55.088
Case 45: b1 = 56.34
End Select
Select Case c
Case 1: c1 = 0.508
Case 2: c1 = 1.016
Case 3: c1 = 1.524
Case 4: c1 = 2.032
Case 5: c1 = 2.54
Case 6: c1 = 3.048
Case 7: c1 = 3.556
Case 8: c1 = 4.064
Case 9: c1 = 4.572
Case 10: c1 = 5.08
Case 11: c1 = 5.588
Case 12: c1 = 6.096
Case 13: c1 = 6.604
Case 14: c1 = 7.112
Case 15: c1 = 7.62
Case 16: c1 = 8.128
Case 17: c1 = 8.636
Case 18: c1 = 9.144
Case 19: c1 = 9.652
Case 20: c1 = 10.16
Case 21: c1 = 10.668
Case 22: c1 = 11.176
Case 23: c1 = 11.684
Case 24: c1 = 12.192
Case 25: c1 = 12.7
Case 26: c1 = 13.208
Case 27: c1 = 13.716
Case 28: c1 = 14.224
Case 29: c1 = 14.732
Case 30: c1 = 15.24
Case 31: c1 = 15.748
Case 32: c1 = 16.256
Case 33: c1 = 16.764
Case 34: c1 = 17.272
Case 35: c1 = 17.78
Case 36: c1 = 18.288
Case 37: c1 = 18.796
Case 38: c1 = 19.304
Case 39: c1 = 19.812
Case 40: c1 = 20.32
Case 41: c1 = 20.828
Case 42: c1 = 21.336
Case 43: c1 = 21.844
Case 44: c1 = 22.352
Case 45: c1 = 22.86
End Select
Select Case d
Case 1: d1 = 0.208
Case 2: d1 = 0.416
Case 3: d1 = 0.624
Case 4: d1 = 0.832
Case 5: d1 = 1.04
Case 6: d1 = 1.248
Case 7: d1 = 1.456
Case 8: d1 = 1.664
Case 9: d1 = 1.872
Case 10: d1 = 2.08
Case 11: d1 = 2.288
Case 12: d1 = 2.496
Case 13: d1 = 2.704
Case 14: d1 = 2.912
Case 15: d1 = 3.12
Case 16: d1 = 3.328
Case 17: d1 = 3.536
Case 18: d1 = 3.744
Case 19: d1 = 3.952
Case 20: d1 = 4.16
Case 21: d1 = 4.368
Case 22: d1 = 4.576
Case 23: d1 = 4.784
Case 24: d1 = 4.992
Case 25: d1 = 5.2
Case 26: d1 = 5.408
Case 27: d1 = 5.616
Case 28: d1 = 5.824
Case 29: d1 = 6.032
Case 30: d1 = 6.24
Case 31: d1 = 6.448
Case 32: d1 = 6.656
Case 33: d1 = 6.864
Case 34: d1 = 7.072
Case 35: d1 = 7.28
Case 36: d1 = 7.488
Case 37: d1 = 7.696
Case 38: d1 = 7.904
Case 39: d1 = 8.112
Case 40: d1 = 8.32
Case 41: d1 = 8.528
Case 42: d1 = 8.736
Case 43: d1 = 8.944
Case 44: d1 = 9.152
Case 45: d1 = 9.36
End Select
MsgBox isim & " ÖSS Sözel Puanın: " & (a1 + b1 + c1 + d1 + 119.425)
MsgBox "Öss Sözel Puan(Eklemeli): " & (a1 + b1 + c1 + d1 + 119.425 + e)
End Sub
Private Sub Command2_Click()
a = Val(Text1)
b = Val(Text2)
c = Val(Text3)
d = Val(Text4)
e = Val(Text5)
st = a * 1.505
ss = b * 0.543
sm = c * 1.714
sf = d * 0.21
MsgBox isim & " Öss Eşit Ağırlık Puanın: " & (st + ss + sm + sf + 121.215)
MsgBox "Öss Eşit Ağırlık Puanı(Eklemeli): " & (st + ss + sm + sf + 121.215 + e)
End Sub
 
Private Sub Command3_Click()
a = Val(Text1)
b = Val(Text2)
c = Val(Text3)
d = Val(Text4)
e = Val(Text5)
st = a * 0.537
ss = b * 0.172
sm = c * 1.796
sf = d * 1.404
MsgBox isim & " Öss Sayısal Puanın: " & (st + ss + sm + sf + 124.001)
MsgBox "Öss Sayısal Puan(Eklemeli): " & (st + ss + sm + sf + 124.001 + e)
End Sub
Private Sub Command4_Click()
End
End Sub
Private Sub Command5_Click()
MsgBox "Sözel:119.425 T.M:121.215 Sayısal:124.001"
End Sub
Private Sub Command6_Click()
Text1 = ""
Text2 = ""
Text3 = ""
Text4 = ""
Text5 = ""
End Sub
 
Private Sub Form_Load()
isim = InputBox("İsminizi giriniz")
End Sub
 
Basit bir msn
 
Dim a As String
Private Sub Command1_Click()
ww.RemotePort = 808
ww.RemoteHost = Text1
ww.Connect
End Sub
 
Private Sub Command2_Click()
With ww
.LocalPort = 808
.Listen
End With
End Sub
 
Private Sub Command3_Click()
ww.SendData Text2
Label2 = "gönderildi"
End Sub
 
 
Private Sub ww_ConnectionRequest(ByVal requestID As Long)
ww.Close
ww.Accept requestID
End Sub
 
Private Sub ww_DataArrival(ByVal bytesTotal As Long)
ww.GetData a
Text3.Text = a
Label2 = "Alındı"
End Sub
 
Private Sub ww_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)
MsgBox Description
End Sub
 
Fare ile Çizim
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
 
Dim mx, my
 
mx = X
my = Y
 
PSet (X, Y) 'başlangıç koordinatını belirlek için nota koy
 
 
End Sub
 
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
 
 
Dim mx, my
 
'sağ tuşa basılı ise çenber ciz
If Button = vbRightButton Then Circle (mx, my), Abs(mx - X)
'sol tuşa basılı ise dikdört ciz
If Button = vbLeftButton Then Line (mx, my)-(X, Y), , B
 
 
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
 
Dim mx, my
 
mx = X
my = Y
 
PSet (X, Y) 'başlangıç koordinatını belirlek için nota koy
 
 
End Sub
 
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
 
 
Dim mx, my
 
'sağ tuşa basılı ise çenber ciz
If Button = vbRightButton Then Circle (mx, my), Abs(mx - X)
'sol tuşa basılı ise dikdört ciz
If Button = vbLeftButton Then Line (mx, my)-(X, Y), , B
 
 
End Sub
 
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
 
Dim mx, my
 
mx = X
my = Y
 
PSet (X, Y) 'başlangıç koordinatını belirlek için nota koy
 
 
End Sub
 
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
 
 
Dim mx, my
 
'sağ tuşa basılı ise çenber ciz
If Button = vbRightButton Then Circle (mx, my), Abs(mx - X)
'sol tuşa basılı ise dikdört ciz
If Button = vbLeftButton Then Line (mx, my)-(X, Y), , B
 
 
End Sub
 
 
basit ses ayar programı
 
'bir kaydırma cubuğu(Slider1)(textpozision=0 yapın)
've bir metin kutusu(Text1) ihtiyaç vardır.
 
Private Declare Function waveOutSetVolume Lib "Winmm" (ByVal wDeviceID As Integer, ByVal dwVolume As Long) As Integer
Private Declare Function waveOutGetVolume Lib "Winmm" (ByVal wDeviceID As Integer, dwVolume As Long) As Integer
Private Sub Command1_Click()
Dim a, i As Long
Dim tmp As String
a = waveOutGetVolume(0, i)
tmp = "&h" & Right(Hex$(i), 4)
Text1 = CLng(tmp)
End Sub
 
 
 
Private Sub Slider1_Scroll()
Dim a, i As Long
Dim tmp, vol As String
Slider1.Min = 0
Slider1.Max = 100
 
 
 
vol = Slider1.Value * 650
Text1 = Slider1.Value * 650
tmp = Right((Hex$(vol + 65536)), 4)
vol = CLng("&H" & tmp & tmp)
a = waveOutSetVolume(0, vol)
 
 
End Sub
 
Girilen sayının Faktöriyelini Verir
 
Private Function fakt(a As Byte) As Variant
f = 1
For i = 1 To a
f = f * i
Next
fakt = f
End Function
 
Private Sub Command1_Click()
Label1.Caption = fakt(Text1.Text)
End Sub
 

Option Explicit
 
Const MAX_PATH = 260
Const TH32CS_SNAPPROCESS = 2&
 
Private Type PROCESSENTRY32
lSize As Long
lUsage As Long
lProcessId As Long
lDefaultHeapId As Long
lModuleId As Long
lThreads As Long
lParentProcessId As Long
lPriClassBase As Long
lFlags As Long
sExeFile As String * MAX_PATH
End Type
 
Private Declare Sub CloseHandle Lib "kernel32" (ByVal hPass As Long)
 
Private Declare Function CreateToolhelpSnapshot Lib "kernel32" _
Alias "CreateToolhelp32Snapshot" (ByVal lFlags As Long, _
ByVal lProcessId As Long) As Long
 
Private Declare Function ProcessFirst Lib "kernel32" _
Alias "Process32First" (ByVal hSnapshot As Long, _
uProcess As PROCESSENTRY32) As Long
 
Private Declare Function ProcessNext Lib "kernel32" _
Alias "Process32Next" (ByVal hSnapshot As Long, _
uProcess As PROCESSENTRY32) As Long

Private Sub Form_Load()
Dim sExeName As String
Dim sPid As String
Dim sParentPid As String
Dim lSnapShot As Long
Dim r As Long
Dim uProcess As PROCESSENTRY32
 
lSnapShot = CreateToolhelpSnapshot(TH32CS_SNAPPROCESS, 0&)
If lSnapShot <> 0 Then
With grdProcs
.Clear
.Rows = 1
.TextMatrix(0, 0) = "Module Name"
.TextMatrix(0, 1) = "Process Id"
.TextMatrix(0, 2) = "Parent" & vbCrLf & "Process"
.TextMatrix(0, 3) = "Threads"
.RowHeight(0) = 400
.ColWidth(0) = 4200
.ColWidth(1) = 950
.ColWidth(2) = 950
.ColWidth(3) = 775
.ColAlignment(0) = flexAlignLeftBottom
.ColAlignment(1) = flexAlignLeftBottom
.ColAlignment(2) = flexAlignLeftBottom
.ColAlignment(3) = flexAlignLeftBottom
 
uProcess.lSize = Len(uProcess)
r = ProcessFirst(lSnapShot, uProcess)
 
Do While r
sExeName = Left(uProcess.sExeFile, InStr(1, uProcess.sExeFile, vbNullChar) - 1)
sPid = Hex$(uProcess.lProcessId)
sParentPid = Hex$(uProcess.lParentProcessId)
.AddItem sExeName & vbTab & sPid & vbTab & _
sParentPid & vbTab & CStr(uProcess.lThreads)
r = ProcessNext(lSnapShot, uProcess)
Loop
CloseHandle (lSnapShot)
End With
End If
End Sub