A SÜTUNUNDA ÇĠFT OLANLRIN YANINA(B SÜT)X
A SÜTUNUNA RENKLER B SÜTUNUNA NUMARALARI
A SÜTUNUNU TOPLAYAN TEXTBOX
A6 DAKĠ ĠSĠMLE SAYFA AÇAR
AÇILAN USERFORM
AKTĠF HÜCRE RENKLĠ
AKTĠF HÜCRE RENKLĠ
BĠLGĠSAYARIN ADINI A1 E YAZAR
COMBOBOXA VERĠ EKLEMEK
COMBOBOXTA AYLAR OTOMATĠK
DIġ BAĞLANTI BULMA KODU
DOSYALARAOTOMATĠK LĠNK
EKRAN KARTI BĠLGĠLERĠ
GÜNÜ TARĠHĠ MSGBOXTA
IP NOSUNU A1 E YAZAR
KAÇ TEXTBOX DOLU
KENDĠ KAPANAN USERFORM
KLASÖR SĠLME
LĠSTBOXTAN SAYFADAKĠ SATIRI SĠLME SIRA NOYU DÜZELTME
PAGE SEÇMEK
POP UP MENÜ
PROGRESSBAR
SAYFA AYARI OTOMATĠK
SAYFA ÜZERĠNDE ÖZEL MENÜ OLUġTURUR
SAYFADA HAREKETLĠ DÜĞME( KISITLI ALANDA)
SAYFADA HARKETLĠ DÜĞME
SAYFALARI SIRALA
SEÇĠLEN ĠLK SATIR NOSU ĠLE SON NOSU ARASINDAKĠ SATIRLAR BĠRER ATLAMALI SEÇĠLĠR
SEÇĠLĠ SATIR RENKLĠ
ġĠFRE
ġĠFRE2
TARĠH FARKI
TEXTBOX AYRAÇSIZ TARĠH GĠRĠġ(2)
TEXTBOX ĠÇERĠKLERĠNĠ SAYFAYA AKTAR
TEXTBOX ĠLK HARF BÜYÜK
TEXTBOXA AYRAÇSIZ TARĠH GĠRME
TEXTBOXA HARF GĠRĠġĠ YASAK & RAKAM GĠRĠġĠ YASAK
TEXTBOXLARA AYRAÇSIZ YTL GĠRĠġĠ(NAMESĠ DEĞĠġTĠRĠLMEYENLER)
TEXTBOXTA METĠN BULMA
TEXTBOXTAKĠ DEĞERĠ BUL HÜCREYĠ BĠLDĠR
TEXTBOXTAKĠ DEĞERĠ BULUR O HÜCREYĠ VE YANINDAKĠ 5 HÜCREYĠ SEÇER
USERFORM TAM EKRAN
USERFORM ÜZERĠNDEN LĠNK VERMEK
USERFORM X ĠġARETĠNĠ KAPATMA
USERFORM X PASĠF
USERFORMDA COMBOBOXA ELLE VERĠ GĠRĠġĠNĠ ENGELLEME
USERFORMDA KAÇ ÇEKBOST ĠġARETLĠ
USERFORMDA MENÜ
USERFORMDA SAAT
USERFORMDA TÜM ĠL VE ĠLÇELER
USERFORMUN YERĠNĠ BELĠRLEMEK
ÜÇ DÜĞMELĠ USERFORM
VERĠ GĠRĠLMEYEN TEXTBOX
YANIP SÖNEN LABEL
YAZIYA CEVĠRME FONKSĠYONU
YAZIYA ÇEVĠR PARA(TL-KRġ)
YAZIYA ÇEVĠR(iKĠ VĠRGÜL YĠRMĠ GĠBĠ)
YERĠ DEĞĠġTĠRĠLEMEYEN USERFORM
YUVARLAK&OTOMATĠK KAPANAN USERFORM
Sub benzeribulisaretle()
Dim i, y, a As Integer
Sub renkler()
Dim i As Integer
Range("B1").Value = "ĠNDEX"
Private Sub UserForm_Activate()
TextBox1 = 0
For i = 1 To 15
TextBox1.Value = TextBox1.Value + Cells(i, 1).Value
Next
End Sub
Sub CreateSheet()
Dim nRow As Integer, nColumn As Integer
Dim i As Byte
Dim MyShName As String
On Error GoTo ErrorHandler:
MyShName = ActiveSheet.Name
nRow = Sheets(MyShName).UsedRange.Rows.Count
nColumn = Sheets(MyShName).UsedRange.Columns.Count
For i = 1 To Worksheets.Count
If Sheets(i).Name = Sheets(MyShName).Range("A6").Value Or _
Sheets(MyShName).Range("A6").Value = Empty Then
MsgBox "Lütfen A6 hücresine, yeni sayfa ismini giriniz !", vbCritical, "Dikkat !"
Exit Sub
End If
Next
Sheets(MyShName).Copy after:=Sheets(Worksheets.Count)
ActiveSheet.Name = Sheets(MyShName).Range("A6").Value
Sheets(MyShName).Select
Exit Sub
ErrorHandler:
Application.CutCopyMode = False
Sheets(MyShName).Select
MsgBox "Hata No = " & Err.Number & vbCrLf & vbCrLf & "Açıklama :" & vbCrLf &
Err.Description, vbApplicationModal, "HATA !"
End Sub
MODÜL
Sub Animasyon()
Dim i As Integer
For i = 0 To 400
UserForm1.Height = i
Next i
End Sub
Sub aç()
UserForm1.Show
End Sub
'USERFORM
Private Sub UserForm_Initialize()
Me.StartUpPosition = 0
Me.Height = 0
Me.Top = 10
Me.Left = 200
Application.OnTime Now + TimeValue("00:00:01"), "animasyon"
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Selection.Cells.Count > 1 Then Exit Sub
Application.EnableEvents = False
Dim MyRow, MyColumn As Integer
Dim aMyRow, aMyColumn, MyActiveCell, MySelection As Range
MyRow = ActiveCell.Row
MyColumn = ActiveCell.Column
Set MyActiveCell = ActiveCell
Set aMyRow = Range(Cells(MyRow, 1), Cells(MyRow, MyColumn))
Set aMyColumn = Range(Cells(1, MyColumn), Cells(MyRow, MyColumn))
Set MySelection = Union(aMyRow, aMyColumn)
MySelection.Select
MyActiveCell.Activate
Set MyActiveCell = Nothing
Set aMyRow = Nothing
Set aMyColumn = Nothing
Set MySelection = Nothing
Application.EnableEvents = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Static EskiHucre As Range
On Error Resume Next
If Target.Interior.ColorIndex = -4142 Then
Target.Interior.ColorIndex = 46
EskiHucre.Interior.ColorIndex = xlColorIndexNone
Set EskiHucre = Target
Else
EskiHucre.Interior.ColorIndex = xlColorIndexNone
End If
End Sub
Declare Function GetComputerName& Lib "kernel32" Alias "GetComputerNameA"
(ByVal lbbuffer As String, nsize As Long)
Sub Bilgisayar_Adi()
Dim BilgiAdi As String * 64
Call GetComputerName(BilgiAdi, 64)
Range("A1") = BilgiAdi
End Sub
Private Sub UserForm_Initialize()
With ComboBox1
Private Sub UserForm_Initialize()
Dim i%
Dim TMP$
ComboBox1.Clear
For i = 1 To 12
TMP = Format(DateSerial(2004, i, 1), "mmmm")
ComboBox1.AddItem TMP
Next i
ComboBox1.ListIndex = 0
Sub ExRef()
Dim MyRange As Range
Dim i As Integer, j As Integer, No As Integer
Dim MyMsg1 As String, MyMsg2 As String, MyMsg3 As String
Dim MyArray()
For i = 1 To Worksheets.Count
No = 0
For Each MyRange In Sheets(i).UsedRange
If InStr(1, MyRange.Formula, "[") Then
MyRange.Interior.ColorIndex = 6
No = No + 1
ReDim MyArray(1 To No)
MyArray(No) = Sheets(i).Name & " --- " & MyRange.Address(False, False)
For j = LBound(MyArray) To UBound(MyArray)
If MyArray(j) "" Then MyMsg2 = MyMsg2 & vbCrLf & MyArray(j)
Next
End If
Next
MyMsg1 = MyMsg1 & vbCrLf & Sheets(i).Name & " sayfasında " & No & " adet "
Next
MyMsg3 = "(Bulunan hücreler sarı renkle iĢaretlenmiĢtir.)"
MsgBox MyMsg1 & vbCrLf & WorksheetFunction.Rept("--", 20) & vbCrLf & "DıĢ
bağlantılı hücre bulundu." _
& vbCrLf & vbCrLf & "Bulunan hücreler :" & vbCrLf & MyMsg2 _
& vbCrLf & vbCrLf & MyMsg3, , "Rapor !"
End Sub
****************************************************
'* Dosya Listeleme & Dosyalara Link kurmak *
'* Version 1.2.1 b *
'* Raider ® *
'* Nisan 2003 *
'****************************************************
'
Const MyExt As String = "*.xls"
Const IncludeSubFolder As Boolean = True
Dim MyPath As String
Dim FileSize, Folder, LastModified, LastAccessed
'
Sub FileList()
Dim FileNamesList As Variant, i As Long
Range("A:E").ClearContents
On Error GoTo ErrHandler:
Set objFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir
klasor seçin !", 0)
If Not objFolder Is Nothing Then
MyPath = objFolder.Items.Item.Path
If InStr(1, MyPath, Application.PathSeparator) 0 Then
MsgBox "WMI yüklenmemiĢ! Programdan çıkılacak...", vbExclamation, _
"Windows Management Instrumentation"
Exit Sub
On Error GoTo 0
End If
For Each MyVideoController In MyOBJ
MyMsg = MyMsg & "Ekran Kartı bilgileri :" & vbCrLf
MyMsg = MyMsg & String(50, "-") & vbCrLf
MyMsg = MyMsg & "Üretici Firma : " & MyVideoController.AdapterCompatibility
&_
" (" & MyVideoController.Caption & ")" & vbCrLf
MyMsg = MyMsg & "Yatay çözünürlük : " &
MyVideoController.CurrentHorizontalResolution & vbCrLf
MyMsg = MyMsg & "Dikey çözünürlük : " &
MyVideoController.CurrentVerticalResolution & vbCrLf
MyMsg = MyMsg & "Renk kalitesi : " & MyVideoController.CurrentBitsPerPixel
& " bps" & vbCrLf
MyMsg = MyMsg & "Video Modu : " &
MyVideoController.VideoModeDescription & vbCrLf
MyMsg = MyMsg & "ĠĢlemci : " & MyVideoController.VideoProcessor & vbCrLf
Next
MsgBox MyMsg, vbInformation, "Ekran Kartı Bilgileri (Raider ®)"
End Sub
Sub tar()
MsgBox "Merhaba bugun " & Date & ", Iyi Günler dilerim..."
End Sub
Type WSADATA
wversion As Integer
wHighVersion As Integer
szDescription(256) As Byte
szSystemStatus(128) As Byte
wMaxSockets As Long
wMaxUDPDG As Long
dwVendorInfo As Long
End Type
Type HOSTENT
hName As Long
hAliases As Long
hAddrType As Integer
hLength As Integer
hAddrList As Long
End Type
Declare Function GetHostByName Lib "wsock32" Alias "gethostbyname" (ByVal
hostname As String) As Long
Declare Function WSAStartup Lib "wsock32" (ByVal wVersionRequired As
Integer, Data As WSADATA) As Long
Declare Function WSACleanup Lib "wsock32" () As Long
Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (Destination As
Any, Source As Any, ByVal Length As Long)
Sub IP_Bul()
On Error GoTo ExitSub:
Dim Out As Integer
Dim Data As WSADATA
Dim Host As Long
Dim Entry As HOSTENT
Dim Address As Long
Private Sub CommandButton1_Click()
Dim say As Integer
For i = 1 To 10
If Controls("TextBox" & i).Text Empty Then say = say + 1
Next
TextBox11.Text = say
End Sub
Private Sub UserForm_Initialize()
Application.OnTime Now + TimeValue("00:00:10"), "Kapat"
Label1.Caption = "Merhaba"
Me.Caption = "Lütfen bekleyiniz....."
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode 1 Then
Me.Caption = "Sabırlı olun, iĢlem devam ediyor...."
Cancel = True
End If
End Sub
Sub DeleteFilesFolders()
'Microsoft Scripting Runtime Referansı seçili olmalı
Dim MyFolder As String
Dim FSO As New Scripting.FileSystemObject
Dim Fld, Fld1 As Scripting.Folder
Dim Fil As Scripting.File
Dim SbFldrs As String
MyFolder = InputBox("Ġçeriğini temizlemek istediğiniz klasörün tam yolunu
yazınız..." & vbCrLf & "Örneğin:", "Hedef Klasör", "C:\Deneme")
On Error Resume Next
Set Fld = FSO.GetFolder(MyFolder)
If FSO.FolderExists(Fld) = False Then
MsgBox "Geçerli Klasör Yolu Tanımladığınızdan Emin Olun."
End
End If
On Error GoTo 0
For Each Fil In Fld.Files
Fil.Delete
Next
SbFldrs = MsgBox("AltKlasörleri de silmek istiyor musunuz?", vbQuestion +
vbYesNo)
If SbFldrs = vbNo Then Exit Sub
For Each Fld1 In Fld.SubFolders
Fld1.Delete
Next
Fld.Delete
End Sub
Private Sub CommandButton1_Click()
Dim mySeçim As String
mySeçim = ListBox1.List(ListBox1.ListIndex, 0)
Range("a5").Select
ara:
Cells.Find(What:=mySeçim, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext,
MatchCase:=False) _
.Activate
If ActiveCell.Offset(0, 1) = ListBox1.List(ListBox1.ListIndex, 1) Then
Selection.EntireRow.Delete
ListBox1.RemoveItem ListBox1.ListIndex
Else: GoTo ara
End If
Dim i As Long, No As Long
For i = 5 To Cells(65536, 2).End(xlUp).Row
If Cells(i, 2) Empty Then
No = No + 1
Cells(i, 1) = No
Else
Cells(i, 1) = Empty
End If
Next
End Sub
Private Sub UserForm_Initialize()
Dim myArray(20, 2)
For i = 1 To 20
myArray(i - 1, 0) = Cells(i, 1)
myArray(i - 1, 1) = Cells(i, 1).Offset(0, 1)
myArray(i - 1, 2) = Cells(i, 1).Offset(0, 2)
Next
ListBox1.List() = myArray()
End Sub
Private Sub CommandButton1_Click()
MultiPage1.Pages(1).Visible = True
MultiPage1.Value = 1
End Sub
Sub Auto_Open()
PopUpMenu
End Sub
Sub PopUpMenu()
Dim cb As CommandBar, i As Integer
On Error Resume Next
Set cb = Application.CommandBars("Cell")
For i = cb.Controls.Count To 0 Step -1
cb.Controls(i).Delete
Next
With cb
For i = 1 To Sheets.Count
With .Controls.Add(Type:=msoControlButton)
.OnAction = "SayfaGoster"
.FaceId = 7
.Caption = Sheets(i).Name
End With
Next
End With
Set cb = Nothing
End Sub
Sub SayfaGoster()
Dim ac As CommandBarButton
Set ac = Application.CommandBars.ActionControl
Sheets(ac.Caption).Select
Set ac = Nothing
End Sub
Sub Auto_Close()
Application.CommandBars("Cell").Reset
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As
Boolean)
UserForm1.Show
End Sub
Private Sub UserForm_Initialize()
ProgressBar1.Max = 100000
ProgressBar1.Min = 1
End Sub
Private Sub UserForm_Activate()
Dim i As Long
UserForm1.Caption = "Dosya Ģimdi kaydediliyor"
For i = 1 To 100000
ProgressBar1.Value = i
Next i
Unload Me
End Sub
Private Sub Workbook_BeforePrint(Cancel As Boolean)
Sheets("Sheet2").PageSetup.PrintArea = Range("A1:F" & Cells(65536,
1).End(xlUp).Row).Address
End Sub
EXCEL: ThisWorkbook Module
'==============================================================
===========
Option Explicit
Private Sub Workbook_Activate()
On Error Resume Next
Application.CommandBars("My Menu").Visible = True
On Error GoTo 0
End Sub
Private Sub Workbook_Deactivate()
On Error Resume Next
Application.CommandBars("My Menu").Visible = False
On Error GoTo 0
End Sub
Private Sub Workbook_Open()
Create_Menu
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Delete_Menu
End Sub
'==============================================================
===========
' WORD: ThisDocument Module
'==============================================================
===========
Option Explicit
Private Sub Document_Close()
Delete_Menu
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If ActiveCell.Column >= 14 And ActiveCell.Column d2 Then
tarih = d1
d1 = d2
d2 = tarih
End If
yilfarki = Year(d2) - Year(d1)
If DateSerial(Year(d2), Month(d1), Day(d1)) > d2 Then
yilfarki = yilfarki - 1
End If
If Month(d2) > Month(d1) Then
If Day(d2) >= Day(d1) Then
ayfarki = Month(d2) - Month(d1)
Else
ayfarki = Month(d2) - Month(d1) - 1
End If
Else
If Day(d2) >= Day(d1) Then
ayfarki = Month(d2) - Month(d1) + 12
If ayfarki = 12 Then ayfarki = 0
Private Sub TextBox1_Change()
With TextBox1
.SelLength = 1
If .SelText = "." Then
.SelStart = .SelStart + 1
.SelLength = 1
End If
End With
End Sub
'
Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger,
ByVal Shift As Integer)
On Error GoTo ErrHand:
With TextBox1
If KeyCode = vbKeyLeft Or KeyCode = vbKeyBack Then
KeyCode = vbKeySelect
.SelStart = .SelStart - 1
.SelLength = 1
ElseIf KeyCode = vbKeyRight Then
KeyCode = vbKeySelect
.SelStart = .SelStart + 1
.SelLength = 1
ElseIf KeyCode = vbKeyDelete Then
KeyCode = vbKeySelect
If .SelText = "." Then
.SelText = "."
Else
.SelText = "#"
End If
.SelStart = .SelStart - 1
.SelLength = 1
ElseIf KeyCode = vbKeyHome Then
KeyCode = vbKeySelect
Private Sub CommandButton1_Click()
Sheets("Sayfa1").Select
Range("A1").Select
ActiveCell.Offset(0, 0).Value = TextBox1.Value
ActiveCell.Offset(1, 0).Value = TextBox2.Value
ActiveCell.Offset(2, 0).Value = TextBox3.Value
End Sub
Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
TextBox1.Value = StrConv(TextBox1.Value, vbProperCase)
End Sub
Public fl As Boolean
Private Sub Tamam_Click()
Dim t
t = Split(Me.TextBox1.Value, "/")
Sheets(1).Range("A1").Value = DateSerial(Day:=t(0), Month:=t(1), Year:=t(2))
TextBox1 = ""
Unload Me
End Sub
Private Sub TextBox1_Change()
Dim l As Integer
With Me.TextBox1
l = Len(.Value)
If fl Then
fl = False
If l = 2 Then
If .Value > 31 Then
MsgBox "Lütfen gün formatını doğru ayarlayınız en fazla 31 olabilir",
vbInformation, "YanlıĢ Gün Formatı"
.Value = ""
Exit Sub
End If
.Value = .Value & "/"
End If
If l = 5 Then
If Not IsDate(.Value & "/2004") Then
MsgBox "Lütfen ay formatını doğru ayarlayınız en fazla 12 olabilir.",
vbInformation, "YanlıĢ Ay Formatı"
.Value = Left$(.Value, 3)
Else
.Value = .Value & "/"
End If
End If
If l >= 10 Then
Private Sub TextBox1_Change()
If Not (IsNumeric(TextBox1)) Then SendKeys "{bs}"
End Sub
'
Private Sub TextBox2_Change()
If Right(TextBox2, 1) Like "[0-9]" Then SendKeys "{bs}"
End Sub
Calss1
Public WithEvents txt As MSForms.TextBox
Private Sub txt_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii Asc(9) Then
KeyAscii = 0
Beep
End If
End Sub
Private Sub txt_Change()
Dim a
a = Replace(txt, ",", "")
a = Replace(a, ".", "")
If IsNumeric(a) = False Then
txt.Value = "0.00"
ElseIf a 0 Then GoTo atla
ara = InputBox("Aramak istediğiniz kelimeyi seçin")
TextBox1.Text = WorksheetFunction.Substitute(txt, vbCrLf, " ")
If InStr(1, txt, ara, vbTextCompare) > 0 Then
A = InStr(1, txt, ara, vbTextCompare)
TextBox1.SetFocus
TextBox1.SelStart = A - 1
TextBox1.SelLength = Len(ara)
say = say + 1
Exit Sub
Else
MsgBox "Aradığınız kelime bulunamadı", vbCritical
Exit Sub
End If
atla:
Cevap = MsgBox("Aramaya devam etmek için EVET" & vbCrLf & "Yeni arama için
ĠPTAL tıklayın", vbQuestion + vbYesNo)
If Cevap = vbNo Then GoTo Son
If InStr(A + 1, txt, ara, vbTextCompare) > 0 Then
A = InStr(A + 1, txt, ara, vbTextCompare)
TextBox1.SetFocus
TextBox1.SelStart = A - 1
TextBox1.SelLength = Len(ara)
Else: MsgBox "Aradığınız kelime bulunamadı", vbCritical: say = 0
End If
Exit Sub
Son:
say = 0
Private Sub CommandButton1_Click()
Dim i As Byte
If Len(TextBox1) > 0 Then
For i = 1 To Worksheets.Count
Call MyFind(Worksheets(i).Name)
Next
End If
End Sub
Private Function MyFind(ShName As String)
Dim MyRng As Range
On Error Resume Next
Set MyRng = Range(Sheets(ShName).Cells.Find(TextBox1,
LookAt:=xlWhole).Address)
MsgBox "Aranılan değer " & ShName & " sayfasında " & MyRng.Address(False,
False) & " hücresinde bulundu !"
Set MyRng = Nothing
End Function
Private Sub CommandButton1_Click()
Aranan = TextBox1.Value
Satir = Cells.Find(Aranan, Range("A1"), xlFormulas, xlPart, xlByRows, xlNext,
False, False).Row
Range("A" & Satir & ":G" & Satir).Select
End Sub
Dim FrmW As Integer, FrmH As Integer
'
Private Sub UserForm_Activate()
Dim Ctrl As Control
RFrmW = Me.Width
RFrmH = Me.Height
On Error Resume Next
For Each Ctrl In Me.Controls
If Ctrl.Left > 0 Then Ctrl.Left = (((Ctrl.Left)) * (RFrmW / FrmH))
If Ctrl.Top > 0 Then Ctrl.Top = (Ctrl.Top * (RFrmH / FrmH))
Ctrl.Width = (Ctrl.Width * (RFrmW / FrmW))
Ctrl.Height = (Ctrl.Height * (RFrmH / FrmW))
If TypeName(Ctrl) = "ListBox" Then
Ctrl.Font.Size = Ctrl.Font.Size * ((RFrmH / FrmH)) - 2
Else
Ctrl.Font.Size = Ctrl.Font.Size * ((RFrmH / FrmH))
End If
Next
End Sub
'
Private Sub UserForm_Initialize()
FrmW = Me.Width
FrmH = Me.Height
With Application
Me.Height = .Height
Me.Width = .Width
Me.Top = .Top
Me.Left = .Left
End With
End Sub
Private Declare Function ShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String,
_
ByVal nShowCmd As Long) As Long
'
Private Sub Label1_Click()
MyEmail = Label1.Caption
MySubject = "Merhaba...."
MyBody = "Bu bir deneme amaçlı e-mail'dir."
URL = "mailto:" & MyEmail & "?subject=" & MySubject & "&body=" & MyBody
ShellExecute 0&, vbNullString, URL, vbNullString, vbNullString, vbNormalFocus
End Sub
'
Private Sub Label1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer,
ByVal X As Single, ByVal Y As Single)
Label1.Font.Underline = True
Label1.ForeColor = vbRed
End Sub
'
Private Sub UserForm_Initialize()
Label1.Caption = "esen@muhasebat.gov.tr"
End Sub
'
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As
Integer, ByVal X As Single, ByVal Y As Single)
Label1.Font.Underline = False
Label1.ForeColor = vbBlue
End Sub
Private Declare Function GetWindowLongA Lib "user32" (ByVal hWnd As Long,
ByVal nIndex As Long) As Long
Private Declare Function SetWindowLongA Lib "user32" (ByVal hWnd As Long,
ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function FindWindowA Lib "user32" (ByVal lpClassName As
String, ByVal lpWindowName As String) As Long
Private Sub CommandButton1_Click()
Unload Me
End Sub
Private Sub UserForm_Initialize()
Dim hWnd As Long
hWnd = FindWindowA("Thunder" & IIf(Application.Version Like "8*", "X", "D") &
"Frame", Me.Caption)
SetWindowLongA hWnd, -16, GetWindowLongA(hWnd, -16) And
&HFFF7FFFF
End Sub
Private Sub CommandButton1_Click()
Unload Me
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then Cancel = True
End Sub
Private Sub ComboBox1_KeyUp(ByVal KeyCode As MSForms.ReturnInteger,
ByVal Shift As Integer)
ComboBox1 = Empty
End Sub
Private Sub CommandButton1_Click()
Dim Ctr As Control
Dim Say As Integer, msg
Say = 0: msg = ""
For Each Ctr In Controls
If TypeName(Ctr) = "CheckBox" Then
If Ctr.Value Then
Say = Say + 1
msg = msg & Ctr.Name & vbCr
End If
End If
Next
MsgBox Say & " adet CheckBox iĢaretli" & vbCr & vbCr & msg
End Sub
Private Type POINTAPI
X As Long
Y As Long
End Type
'
Private Declare Function CreatePopupMenu Lib "user32" () As Long
Private Declare Function TrackPopupMenuEx Lib "user32" _
(ByVal hMenu As Long, ByVal wFlags As Long, ByVal X As Long, ByVal Y As
Long, _
ByVal hWnd As Long, ByVal lptpm As Any) As Long
Private Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" _
(ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long,
_
ByVal lpNewItem As Any) As Long
Private Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As
Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As
Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
'
Const MF_CHECKED = &H8&
Const MF_APPEND = &H100&
Const TPM_LEFTALIGN = &H0&
Const MF_SEPARATOR = &H800&
Const MF_STRING = &H0&
Const TPM_RETURNCMD = &H100&
Const TPM_RIGHTBUTTON = &H2&
'
Dim hMenu As Long
Dim hWnd As Long
'
Private Sub UserForm_Initialize()
Private Sub UserForm_Activate()
Do
Label1.Caption = Format(Now, "hh:mm:ss")
DoEvents
Loop
End Sub
Private Sub ComboBox1_Change()
ComboBox1.Value = WorksheetFunction.Proper(ComboBox1.Value)
With ComboBox2
.AddItem "Türkiyenin Ġlçeleri"
.Font.Italic = False
.Font.Bold = True
.Font.Size = 8
.ControlTipText = "Hazırlayan Obivan Konabi (TeĢekkürler)"
.ForeColor = &H80000012
.Enabled = True
.Value = "ġimdi Ġlçeleri Seçebilirsiniz."
End With
With ComboBox1
.Font.Bold = True
.Font.Size = 8
.ForeColor = &H80000012
End With
If ComboBox1.Value = "Adana" Then
ComboBox2.Clear
ComboBox2.ListRows = 15
ComboBox2.AddItem "Adana Merkez"
ComboBox2.AddItem "Aladağ"
ComboBox2.AddItem "Ceyhan"
ComboBox2.AddItem "Feke"
ComboBox2.AddItem "Ġmamoğlu"
ComboBox2.AddItem "Karaisalı"
ComboBox2.AddItem "KarataĢ"
ComboBox2.AddItem "Kozan"
ComboBox2.AddItem "Pozantı"
istediğiniz için ayrı bir koda gerek yok, bunu ayarlamak için userfomu
seçin,"properties" penceresinde "position" kısmından "startupposition" seçeneğini
"0-manuel" olarak seçin, bu seçimin ardından userformun ekrandaki yerini
belirlemek için "left" ve "top" değerlerini değiĢtirin örneğin left=350,top=0
yaparsanız ekranın sağ üst köĢesinde görünecektir.
uf
Dim objFormResize As New Class1
Private Sub UserForm_Activate()
Set objFormResize.Form = Me
End Sub
'class mod
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal
lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA"
(ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA"
(ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As
Long
Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal
nCmdShow As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As
Long
Dim hWndForm As Long
Public Property Set Form(objForm As Object)
hWndForm = FindWindow(vbNullString, objForm.Caption)
SetUserFormStyle
End Property
Private Sub SetUserFormStyle()
Dim frmStyle As Long
frmStyle = GetWindowLong(hWndForm, (-16))
frmStyle = frmStyle Or &H80000 Or &H20000 Or &H10000
SetWindowLong hWndForm, (-16), frmStyle
Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
If TextBox1 31 Then
TextBox1 = Empty
Cancel = True
End If
End Sub
MODÜLE
Public RunWhen As Double
'
Sub StartTimer()
RunWhen = Now + TimeSerial(0, 0, 1)
Application.OnTime earliesttime:=RunWhen, procedure:="MyAnimation",
schedule:=True
End Sub
'
Sub StopTimer()
On Error Resume Next
Application.OnTime earliesttime:=RunWhen, procedure:="MyAnimation",
schedule:=False
End Sub
'
Sub MyAnimation()
Dim x As Boolean
x = UserForm1.Label1.Visible
UserForm1.Label1.Visible = Not x
StartTimer
End Sub
'USERFORM
Private Sub UserForm_Activate()
Call StartTimer
End Sub
'
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Call StopTimer
End Sub
Function cevir$(rakam)
Dim a$(9)
Dim b$(9)
Dim c$(4)
Dim d(15)
Dim e(3)
a$(0) = ""
a$(1) = "bir"
a$(2) = "iki"
a$(3) = "üç"
a$(4) = "dört"
a$(5) = "beĢ"
a$(6) = "altı"
a$(7) = "yedi"
a$(8) = "sekiz"
a$(9) = "dokuz"
b$(0) = ""
b$(1) = "on"
b$(2) = "yirmi"
b$(3) = "otuz"
b$(4) = "kırk"
b$(5) = "elli"
b$(6) = "altmıĢ"
b$(7) = "yetmiĢ"
b$(8) = "seksen"
b$(9) = "doksan"
c$(0) = "trilyon"
c$(1) = "milyar"
Public Function ParaCevir(Para)
Dim ParaStr As String
Dim Lira As String, Kurus As String
If Not IsNumeric(Para) Then GoTo SayiDegil
ParaStr = Format(Abs(Para), "0.00")
Lira = Left(ParaStr, Len(ParaStr) - 3)
Kurus = Right(ParaStr, 2)
ParaCevir = IIf(Para < 0, "Eksi ", "") & Cevir(Lira) & " Lira " & Cevir(Kurus) & "
KuruĢ"
Exit Function
SayiDegil:
ParaCevir = "GĠRĠLEN DEĞER SAYI DEĞĠL!"
End Function
Private Function Cevir(SayiStr As String) As String
Dim Rakam(15)
Dim c(3), Sonuc, e
Birler = Array("", "bir", "iki", "üç", "dört", "beĢ", "altı", "yedi", "sekiz", "dokuz")
Onlar = Array("", "on", "yirmi", "otuz", "kırk", "elli", "altmıĢ", "yetmiĢ", "seksen",
"doksan")
Binler = Array("trilyon", "milyar", "milyon", "bin", "")
SayiStr = String(15 - Len(SayiStr), "0") + SayiStr
For i = 1 To 15
Rakam(i) = Val(Mid$(SayiStr, i, 1))
Function Yaziyla(Sayi#)
ReDim birler$(10), onlar$(10), basamak$(5)
birler$(0) = "": birler$(1) = "Bir"
birler$(2) = "Ġki": birler$(3) = "Üç"
birler$(4) = "Dört": birler$(5) = "BeĢ"
birler$(6) = "Altı": birler$(7) = "Yedi"
birler$(8) = "Sekiz": birler$(9) = "Dokuz"
onlar$(0) = "": onlar$(1) = "On"
onlar$(2) = "Yirmi": onlar$(3) = "Otuz"
onlar$(4) = "Kırk": onlar$(5) = "Elli"
onlar$(6) = "AltmıĢ": onlar$(7) = "YetmiĢ"
onlar$(8) = "Seksen": onlar$(9) = "Doksan"
basamak$(1) = "": basamak$(2) = "Bin"
basamak$(3) = "Milyon": basamak$(4) = "Milyar"
basamak$(5) = "Trilyon"
virgul2$ = "": cevap$ = "": onda$ = ""
Say$ = Str$(Sayi#)
virgul% = InStr(1, Say$, ".")
If virgul% Then
Say$ = Right$(Say$, Len(Say$) - virgul%)
Select Case Len(Say$)
Case 6: onda$ = "milyonda"
Case 5: onda$ = "yüzbinde"
Case 4: onda$ = "onbinde"
Case 3: onda$ = "binde"
Case 2: onda$ = "yüzde"
Case 1: onda$ = "onda"
Private Sub UserForm_Layout()
' Von Bert Körn
' http://www.forum.excelabc.de/
Me.Move Application.Width / 2 - Me.Width / 2, Application.Height / 2 -
Me.Height / 2
End Sub
Sub aç()
UserForm1.Show
End Sub
'Userform
Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal
Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long,
ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function FindWindowA Lib "user32" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Sub UserForm_Initialize()
Dim FormhWnd, EliptikHandle As Long
UserForm1.Width = 380
UserForm1.Height = 380
FormhWnd = FindWindowA(vbNullString, Me.Caption)
EliptikHandle = CreateEllipticRgn(110, 100, UserForm1.Width,
UserForm1.Height)
Call SetWindowRgn(FormhWnd, EliptikHandle, True)
End Sub
Private Sub UserForm_Activate()
Application.StatusBar = " MUTLU RAMAZANLAR VE ESENLĠKLER DĠLERĠM"
UserForm1.Repaint
With UserForm1
.StartUpPosition = 2
End With
UserForm1.Repaint
UserForm1.StartUpPosition = 2
UserForm_Layout
End Sub
1x
s 33
d x 33
f x
g 33
h
a x 44
d x 333 555
f x
1 333
1
1
1
1
1
1
1
1
1
D
Sub Password()
On Error GoTo bitti
basa:
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Password:="123456"
ActiveWindow.Close
Application.DisplayAlerts = True
GoTo basa
bitti:
Exit Sub
End Sub