Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

20 Aralık 2006 Çarşamba

Search For Files




'UserForm1

Option Explicit

Private Sub UserForm_Initialize()
On Error Resume Next
Me.Caption = "[PBİD®] Dosya seçim türü ve sayısı hesabı..."
Application.Visible = False
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
On Error Resume Next
Application.Visible = True
End Sub
Private Sub CommandButton1_Click()
On Error Resume Next
Call SearchForFiles
End Sub
Sub SearchForFiles()
On Error Resume Next
Dim Sayaç As Long
Dim Tür, Bulunan As Double
With Application.FileSearch
.NewSearch
.FileType = msoFileTypeWebPages
.FileTypes.Add msoFileTypeExcelWorkbooks
Tür = .FileTypes.Count
Label2.Caption = Tür
.LookIn = "C:\"
.SearchSubFolders = True
If .Execute <> 0 Then
Bulunan = .FoundFiles.Count
Label4.Caption = Bulunan
ReDim Hafıza(1 To Bulunan, 1 To 1)
For Sayaç = 1 To Bulunan
Hafıza(Sayaç, 1) = .FoundFiles.Item(Sayaç)
'If MsgBox(.FoundFiles.Item(Sayaç), vbOKCancel, "Dosya bulundu") = vbCancel Then
' Sayaç = Bulunan
'End If
If Bulunan > 0 Then ProgressBar1.Value = (100 * Sayaç / Bulunan): DoEvents
Next Sayaç
ListBox1.List() = Hafıza()
Else
Label4.Caption = 0
End If
End With
End Sub

10 Aralık 2006 Pazar

Hidden Mouse

'UserForm1
Option Explicit
Private Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long

Private Sub CommandButton1_Click()
On Error Resume Next
ShowCursor bShow
End Sub
Private Sub CommandButton2_Click()
On Error Resume Next
ShowCursor True
End Sub

1 Aralık 2006 Cuma

Call File Manager by Api Functions



'Module1

Option Explicit
Public Type BROWSEINFO

hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Public Type RECT

Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Const WM_USER = &H400
Public Const MAX_PATH = 260
Public Const BIF_RETURNONLYFSDIRS = &H1
Public Const BIF_DONTGOBELOWDOMAIN = &H2
Public Const BIF_STATUSTEXT = &H4
Public Const BIF_RETURNFSANCESTORS = &H8
Public Const BIF_EDITBOX = &H10
Public Const BIF_VALIDATE = &H20
Public Const BIF_NEWDIALOGSTYLE = &H40
Public Const BIF_BROWSEINCLUDEURLS = &H80
Public Const BIF_BROWSEFORCOMPUTER = &H1000
Public Const BIF_BROWSEFORPRINTER = &H2000
Public Const BIF_BROWSEINCLUDEFILES = &H4000
Public Const BIF_SHAREABLE = &H8000
Public Const BFFM_INITIALIZED = 1
Public Const BFFM_SELCHANGED = 2
Public Const BFFM_VALIDATEFAILED = 3
Public Const BFFM_SETSTATUSTEXTA = WM_USER + 100
Public Const BFFM_ENABLEOK = WM_USER + 101
Public Const BFFM_SETSELECTIONA = WM_USER + 102
Public Const BFFM_SETSELECTIONW = WM_USER + 103
Public Const BFFM_SETSTATUSTEXTW = WM_USER + 104
Public Const LMEM_FIXED = &H0
Public Const LMEM_ZEROINIT = &H40
Public Const LPTR = (LMEM_FIXED Or LMEM_ZEROINIT)
Private Declare Function GetCurrentVbaProject Lib "vba332.dll" Alias "EbGetExecutingProj" (hProject As Long) As Long
Private Declare Function GetFuncID Lib "vba332.dll" Alias "TipGetFunctionId" (ByVal hProject As Long, ByVal strFunctionName As String, ByRef strFunctionId As String) As Long
Private Declare Function GetAddr Lib "vba332.dll" Alias "TipGetLpfnOfFunctionId" (ByVal hProject As Long, ByVal strFunctionId As String, ByRef lpfn As Long) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Any) As Long
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
Public Declare Function LocalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal uBytes As Long) As Long
Public Declare Function LocalFree Lib "kernel32" (ByVal hMem As Long) As Long
Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Public Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Public Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
Public Const SM_CXFULLSCREEN = 16
Public Const SM_CYFULLSCREEN = 17

Sub Demo()
On Error Resume Next
Dim RetStr As String, Flags As Long, DoCenter As Boolean
Flags = Flags + BIF_RETURNONLYFSDIRS + BIF_EDITBOX + BIF_VALIDATE + BIF_STATUSTEXT + BIF_BROWSEINCLUDEFILES + BIF_NEWDIALOGSTYLE
DoCenter = xlOn
RetStr = GetDirectory(CurDir, Flags, DoCenter, "[PBİD®]Kaynak Dosyanızı Seçiniz...")
If RetStr <> "" Then MsgBox RetStr
End Sub
Public Function AddrOf(strFuncName As String) As Long
On Error Resume Next
Dim hProject As Long
Dim lngResult As Long
Dim strID As String
Dim lpfn As Long
Dim strFuncNameUnicode As String
Const NO_ERROR = 0
strFuncNameUnicode = StrConv(strFuncName, vbUnicode)
Call GetCurrentVbaProject(hProject)
If hProject <> 0 Then
lngResult = GetFuncID(hProject, strFuncNameUnicode, strID)
If lngResult = NO_ERROR Then
lngResult = GetAddr(hProject, strID, lpfn)
If lngResult = NO_ERROR Then
AddrOf = lpfn
End If
End If
End If
End Function
Function GetDirectory(InitDir As String, Flags As Long, CntrDlg As Boolean, Msg) As String
On Error Resume Next
Dim CntrDialog As Boolean
Dim bInfo As BROWSEINFO
Dim pidl As Long, lpInitDir As Long
CntrDialog = CntrDlg
bInfo.pidlRoot = 0
bInfo.lpszTitle = Msg
bInfo.ulFlags = Flags
lpInitDir = LocalAlloc(LPTR, Len(InitDir) + 1)
CopyMemory ByVal lpInitDir, ByVal InitDir, Len(InitDir) + 1
bInfo.lParam = lpInitDir
If (Val(Application.Version) > 8) Then
bInfo.lpfn = BrowseCallBackFuncAddress
Else
bInfo.lpfn = AddrOf("BrowseCallBackFunc")
End If
pidl = SHBrowseForFolder(bInfo)
GetDirectory = GetPathFromID(pidl)
CoTaskMemFree pidl
LocalFree lpInitDir
End Function
Function BrowseCallBackFunc(ByVal hwnd As Long, ByVal Msg As Long, ByVal lParam As Long, ByVal pData As Long) As Long
On Error Resume Next
Dim CntrDialog As Boolean
Select Case Msg
Case BFFM_INITIALIZED
SendMessage hwnd, BFFM_SETSELECTIONA, 1, pData
If CntrDialog Then CenterDialog hwnd
Case BFFM_SELCHANGED
SendMessage hwnd, BFFM_SETSTATUSTEXTA, 0, GetPathFromID(lParam)
Case BFFM_VALIDATEFAILED
Beep
SendMessage hwnd, BFFM_SETSTATUSTEXTA, 0, "Bad Directory"
BrowseCallBackFunc = 1
Exit Function
End Select
BrowseCallBackFunc = 0
End Function
Function GetPathFromID(ID As Long) As String
On Error Resume Next
Dim Result As Boolean, Path As String * MAX_PATH
Result = SHGetPathFromIDList(ID, Path)
If Result Then
GetPathFromID = Left(Path, InStr(Path, Chr$(0)) - 1)
Else
GetPathFromID = ""
End If
End Function
Function BrowseCallBackFuncAddress() As Long
On Error Resume Next
BrowseCallBackFuncAddress = Long2Long(AddressOf BrowseCallBackFunc)
End Function
Function Long2Long(x As Long) As Long
On Error Resume Next
Long2Long = x
End Function
Sub CenterDialog(hwnd As Long)
On Error Resume Next
Dim WinRect As RECT, ScrWidth As Integer, ScrHeight As Integer
Dim DlgWidth As Integer, DlgHeight As Integer
GetWindowRect hwnd, WinRect
DlgWidth = WinRect.Right - WinRect.Left
DlgHeight = WinRect.Bottom - WinRect.Top
ScrWidth = GetSystemMetrics(SM_CXFULLSCREEN)
ScrHeight = GetSystemMetrics(SM_CYFULLSCREEN)
MoveWindow hwnd, (ScrWidth - DlgWidth) / _
2, (ScrHeight - DlgHeight) / 2, DlgWidth, DlgHeight, 1
End Sub

20 Kasım 2006 Pazartesi

CreateFileList And FileLink




'Module1

Option Explicit
Const Uzantı As String = "*.xls"
Const AnaKlasör As Boolean = True
Dim Yol As String
Dim Büyüklük, Klasör, SonDüzenleme, SonErişim
Dim KlasörNesnesi As Object
Dim DosyaListesi, i As Long
Dim DosyaHafıza() As String, DosyaSayısı As Long
Dim fs, f
Sub CreateFileList_and_FileLink()

On Error GoTo ErrHandler:
Range("A:E").ClearContents
Set KlasörNesnesi = CreateObject("Shell.Application").BrowseForFolder(0, "[PBİD®]Link İçin bir klasör seçin !", 0)
If Not KlasörNesnesi Is Nothing Then
Yol = KlasörNesnesi.Items.Item.Path
DosyaListesi = CreateFileList(Uzantı, False)
For i = 1 To UBound(DosyaListesi)
Cells(i + 1, 1) = Dir(DosyaListesi(i))
Call FileDetails(DosyaListesi(i))
Cells(i + 1, 2) = Büyüklük
Cells(i + 1, 3) = Klasör
Cells(i + 1, 4) = SonDüzenleme
Cells(i + 1, 5) = SonErişim
ActiveSheet.Hyperlinks.Add Anchor:=Cells(i + 1, 1), Address:=DosyaListesi(i)
Next i
Columns("A:E").AutoFit
Rows("2:2").Select
ActiveWindow.FreezePanes = True
Range("A1").Select
Exit Sub
ErrHandler:
Select Case Err.Number
Case 7
MsgBox "Disket veya CD-ROM/WRITER sürücüsü boş !", vbOKOnly, "[PBİD®] Link Durumu! Toplam Dosya Sayısı: " & VBA.InStr(1, Yol, Application.PathSeparator)
Case 13
MsgBox "Klasorde geçerli *.xls dosyası bulunamadı !", vbOKOnly, "[PBİD®] Link Durumu! Toplam Dosya Sayısı: " & VBA.InStr(1, Yol, Application.PathSeparator)
Case 91
MsgBox "Geçerli bir klasor seçilmedi !", vbOKOnly, "[PBİD®] Link Durumu! Toplam Dosya Sayısı: " & VBA.InStr(1, Yol, Application.PathSeparator)
Case Else
MsgBox "Hata oluştu !" & vbCrLf & vbCrLf & "Hata No: " & Err.Number & vbCrLf & Err.Description, vbOKOnly, "[PBİD®] Link Durumu! Toplam Dosya Sayısı: " & VBA.InStr(1, Yol, Application.PathSeparator)
End Select
Err.Clear
Range("A1:E1").Clear
End If
End Sub
Function CreateFileList(DosyaTipi As String, AnaKlasör As Boolean) As Variant

CreateFileList = ""
Erase DosyaHafıza
With Application.FileSearch
.NewSearch
.LookIn = Yol
.Filename = DosyaTipi
.LastModified = msoLastModifiedAnyTime
.SearchSubFolders = AnaKlasör
If .Execute(SortBy:=msoSortByFileName, SortOrder:=msoSortOrderAscending) = 0 Then Exit Function
ReDim DosyaHafıza(.FoundFiles.Count)
For DosyaSayısı = 1 To .FoundFiles.Count
DosyaHafıza(DosyaSayısı) = .FoundFiles(DosyaSayısı)
Next DosyaSayısı
End With
CreateFileList = DosyaHafıza
Erase DosyaHafıza
End Function
Sub FileDetails(DosyaYolu)
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(DosyaYolu)
Büyüklük = f.Size / 1024
Klasör = f.ParentFolder
SonDüzenleme = Format(f.DateLastModified, "dd.mmmm.yyyy")
SonErişim = Format(f.DateLastAccessed, "dd.mmmm.yyyy")
Set f = Nothing
Set fs = Nothing
End Sub

10 Kasım 2006 Cuma

Call Calculator by ActiveMicrosoftApp Index


'Module1
Option Explicit

Sub Hesap_Makinesi()
On Error Resume Next
Application.ActivateMicrosoftApp Index:=0
'Index:=0 Calculator
'Index:=1 Microsoft Office ® Word
'Index:=2 Microsoft Office ® PowerPoint
'Index:=3 Microsoft Office ® OutLook
'Index:=4 Microsoft Office ® Access
'Index:=5 Microsoft Office ® FoxProw
'Index:=6 Microsoft Office ® WinProj
'Index:=7 Microsoft Office ® Schdplus
'Index:=8 Microsoft Office ® Access
End Sub

1 Kasım 2006 Çarşamba

Call NotePad by Shell


'Module1

Option Explicit

Sub Not_Defteri()
On Error Resume Next
Call Shell("NotePad.exe.", 1)
End Sub

20 Ekim 2006 Cuma

Eliptik UserForm




'UserForm1

Option Explicit
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
Dim FormhWnd, EliptikHandle As Long
Dim i As Integer
Dim PauseTime, Start
Private Sub UserForm_Initialize()
    On Error Resume Next
    With Me
        .Width = 380
        .Height = 380
        .BackColor = VBA.RGB(0, 0, 255)
        .BorderStyle = fmBorderStyleNone
        .SpecialEffect = fmSpecialEffectFlat
        FormhWnd = FindWindowA(vbNullString, .Caption)
        EliptikHandle = CreateEllipticRgn(110, 100, .Width, .Height)
    End With
    Call SetWindowRgn(FormhWnd, EliptikHandle, True)
End Sub
Private Sub UserForm_Activate()

    On Error Resume Next
    Application.StatusBar = " PBİD ®"
    Call UserForm_Layout
End Sub
Private Sub UserForm_Layout()

    On Error Resume Next
    PauseTime = 1
    Start = VBA.Timer
    Do While ((Start + PauseTime) > VBA.Timer)
        VBA.DoEvents
    Loop
    For i = 1 To 380
        With Me
            .Top = .Top - 1
            .Left = .Left - 1
            .Height = .Height - 1
            .Width = .Width - 1
            .Repaint
        End With
    Next i
    With Me
        .Height = 320
        .Width = 320
        .StartUpPosition = 2
    End With
    Unload Me
    Application.StatusBar = False
End Sub

10 Ekim 2006 Salı

PopUp Menu 2




'UserForm1

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()
Me.Caption = "[PBİD®]PopUp Menu2 düzenleme...
hWnd = FindWindow(vbNullString, Me.Caption)
End Sub
Private Sub UserForm_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim Pt As POINTAPI
Dim ret As Long
If Button = 2 Then
hMenu = CreatePopupMenu()
AppendMenu hMenu, MF_STRING, 1, "Menu - 1"
AppendMenu hMenu, mfRTF, 2, "Menu - 2"
AppendMenu hMenu, MF_STRING, 3, "Menu - 3"
AppendMenu hMenu, MF_CHECKED, 4, "Menu - 4"
AppendMenu hMenu, MF_SEPARATOR, 5, ByVal 0&
AppendMenu hMenu, MF_STRING, 6, "[Mustafa ULUSARAÇ] 01ulusarac@superonline.com"
GetCursorPos Pt
ret = TrackPopupMenuEx(hMenu, TPM_LEFTALIGN Or TPM_RETURNCMD Or TPM_RIGHTBUTTON,Pt.X, Pt.Y, hWnd, ByVal 0&)
DestroyMenu hMenu
Select Case ret
Case 1
Call MenuProc1
Case 2
Call MenuProc2
Case 4
Call MenuProc3
End Select
End If
End Sub
Private Sub MenuProc1()
MsgBox "PopUp menu-1 is activated !"
End Sub
Private Sub MenuProc2()
MsgBox "PopUp menu-2 is activated !"
End Sub
Private Sub MenuProc3()
MsgBox "Prepared by Raider ®"
End Sub

1 Ekim 2006 Pazar

Popup Menu 1




'UserForm1

Option Explicit
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
Dim Pt As POINTAPI
Dim ret As Long
Private Sub UserForm_Initialize()
On Error Resume Next
hWnd = FindWindow(vbNullString, Me.Caption)
Me.Caption = "[PBİD®] PopUp Menü1 düzenleme"
End Sub
Private Sub UserForm_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
On Error Resume Next
If Button = 2 Then
hMenu = CreatePopupMenu()
AppendMenu hMenu, MF_STRING, 1, "Menü1"
AppendMenu hMenu, MF_STRING, 2, "Menü2"
AppendMenu hMenu, MF_SEPARATOR, 3, ByVal 0&
AppendMenu hMenu, MF_STRING, 4, "[Mustafa ULUSARAÇ] 01ulusarac@superonline.com"
GetCursorPos Pt
ret = TrackPopupMenuEx(hMenu, TPM_LEFTALIGN Or TPM_RETURNCMD Or TPM_RIGHTBUTTON, Pt.X, Pt.Y, hWnd, ByVal 0&)
DestroyMenu hMenu
Select Case ret
Case 1
Call Menü1_Komut
Case 2
Call Menü2_Komut
Case 4
Call Menü3_Komut
End Select
End If
End Sub
Private Sub Menü1_Komut()
On Error Resume Next
MsgBox "PopUp MENÜ1 !"
End Sub
Private Sub Menü2_Komut()
On Error Resume Next
MsgBox "PopUp MENÜ2 !"
End Sub
Private Sub Menü3_Komut()
On Error Resume Next
MsgBox "AÇIKLAMA"
End Sub

20 Eylül 2006 Çarşamba

Dimensional DBase

'Module1

'A) Tek Boyutlu Sabit (Dimensional) Diziler

Option Base 1
Dim Arr(5)

Sub TekBoyutluSabitDiziler1()
Arr(1) = "Jan"
Arr(2) = "Feb"
Arr(3) = "Mar"
Arr(4) = "Apr"
Arr(5) = "May"
MsgBox Arr(1) & "-" & Arr(2) & "-" & Arr(3) & "-" & Arr(4) & "-" & Arr(5)
End Sub

'Module2

'B) Çok Boyutlu Değişken(ReDimensional) Diziler

Option Base 1

Sub ÇokBoyutluDeğişkenDiziler1()
On Error Resume Next
ReDim Arr(6)
Arr(1) = "Jan"
Arr(2) = "Feb"
Arr(3) = "Mar"
Arr(4) = "Apr"
Arr(5) = "May"
Arr(6) = "Jun"
MsgBox Arr(1) & "-" & Arr(2) & "-" & Arr(3) & "-" & Arr(4) & "-" & Arr(5)
End Sub
Sub ÇokBoyutluDeğişkenDiziler2()
On Error Resume Next
ReDim Arr(5)
Arr(1) = "Jan"
Arr(2) = "Feb"
Arr(3) = "Mar"
Arr(4) = "Apr"
Arr(5) = "May"
ReDim Arr(6)
Arr(6) = "Jun"
MsgBox Arr(1) & "-" & Arr(2) & "-" & Arr(3) & "-" & Arr(4) & "-" & Arr(5) & "-" & Arr(6)
End Sub
Sub ÇokBoyutluDeğişkenDiziler3()
On Error Resume Next
ReDim Arr(5)
Arr(1) = "Jan"
Arr(2) = "Feb"
Arr(3) = "Mar"
Arr(4) = "Apr"
Arr(5) = "May"
ReDim Preserve Arr(6)
Arr(6) = "Jun"
MsgBox Arr(1) & "-" & Arr(2) & "-" & Arr(3) & "-" & Arr(4) & "-" & Arr(5) & "-" & Arr(6)
End Sub

'Module3

'C) Çok Boyutlu Sabit(Dimensional) Diziler

Option Base 1
Dim Arr(2, 2)

Sub ÇokBoyutluSabitDizi1()
On Error Resume Next
Arr(1, 1) = 1000
Arr(1, 2) = 1200
Arr(2, 1) = 1500
Arr(2, 2) = 2000
MsgBox "Sale of CD in 2003 is " & Arr(1, 1) & vbCrLf & "Sale of CD in 2004 is " & Arr(2, 1) & vbCrLf & "Sale of DVD in 2003 is " & Arr(1, 2) & vbCrLf & "Sale of DVD in 2004 is " & Arr(2, 2)
End Sub

'Module4

'D) Dizilerin Büyük [Ubound] ve Küçük [Lbound] Değeri

Option Base 1
Dim A(1 To 100, 0 To 3, -3 To 4)
Dim x(6)

Sub DizilerinBüyükKüçükDeğeri1()
On Error Resume Next
x(1) = UBound(A, 1) '= 100
x(2) = UBound(A, 2) '= 3
x(3) = UBound(A, 3) '= 4
x(4) = LBound(A, 1) '= 1
x(5) = LBound(A, 2) '= 0
x(6) = LBound(A, 3) '= -3
MsgBox x(1) & vbCrLf & x(2) & vbCrLf & x(3) & vbCrLf & x(4) & vbCrLf & x(5) & vbCrLf & x(6)
End Sub
Sub DizilerinBüyükKüçükDeğeri2()
On Error Resume Next
x(1) = UBound(A, 1) - LBound(A, 1) + 1 '100 - 1 + 1
x(2) = UBound(A, 2) - LBound(A, 2) + 1 ' 3 - 0 + 1
x(3) = UBound(A, 3) - LBound(A, 3) + 1 '4 - (-3) + 1
MsgBox x(1) & vbCrLf & x(2) & vbCrLf & x(3)
End Sub

'Module5

'E) Dizi Sıralama

Option Explicit
Option Base 1
Dim Arr(5) As Integer
Dim Liste As String
Dim Temp As Double
Dim i, j As Long

Sub Sırala()
On Error Resume Next
Arr(1) = 8
Arr(2) = 4
Arr(3) = 3
Arr(4) = 7
Arr(5) = 2
Liste = ""
For i = 1 To 5
Liste = Liste & Arr(i) & vbCrLf
Next i
MsgBox "Before Sorting" & vbCrLf & Liste
Call Sıralatma(Arr)
Liste = ""
For i = 1 To 5
Liste = Liste & Arr(i) & vbCrLf
Next i
MsgBox "After Sorting" & vbCrLf & Liste
End Sub
Sub Sıralatma(Arr() As Integer)
On Error Resume Next
For j = 1 To UBound(Arr)
Temp = Arr(j)
For i = j - 1 To 1 Step -1
If (Arr(i) <= Temp) Then GoTo Durak: Arr(i + 1) = Arr(i)
Next i
i = 0
Durak:
Arr(i + 1) = Temp
Next j
End Sub

'Module6

'F) Rastgele (Resample/Random) Değeri Bulma

Option Explicit
Option Base 1
Dim Hold(8) As Single, Hold2(8) As String
Dim str As String
Dim xTemp As Double
Dim yTemp As String
Dim i As Long
Dim j As Long

Sub Rastgele()
On Error Resume Next
Hold2(1) = "Anthony"
Hold2(2) = "Bobby"
Hold2(3) = "Chris"
Hold2(4) = "Danny"
Hold2(5) = "Eton"
Hold2(6) = "Frank"
Hold2(7) = "George"
Hold2(8) = "Harry"
For i = 1 To UBound(Hold)
Hold(i) = VBA.Rnd
Cells(i, 2) = Hold(i)
Next i
Call DoubleSort(Hold, Hold2)
str = ""
For i = 1 To 3
str = str & Hold2(i) & vbCrLf
Cells(i, 1) = Hold2(i)
Next i
MsgBox str
End Sub
Sub DoubleSort(x() As Single, y() As String)
On Error Resume Next
For j = 2 To UBound(x)
xTemp = x(j)
yTemp = y(j)
For i = j - 1 To 1 Step -1
If (x(i) <= xTemp) Then GoTo Durak: x(i + 1) = x(i) y(i + 1) = y(i)
Next i
i = 0
Durak:
x(i + 1) = xTemp
y(i + 1) = yTemp
Next j
End Sub

'UserForm1

'G) Dizi İçinde Dikey ve Yatay Arama


'Application.Vlookup(Aranan,Array,Sütun,False)
'Application.Hlookup(Aranan,Array,Satır,False)
'Application.Match(Aranan,Array,0)


Option Explicit
Dim i
Dim Alan(20, 3)
Dim Alan1(20, 0)
Dim Bilgi

Private Sub UserForm_Initialize()
On Error Resume Next
With Me
.Height = 96
.Width = 172
.Caption = "[PBİD®]Dizi İçi Arama..."
End With
With ListBox1
.ColumnCount = 3
.ColumnWidths = "36;36;36"
.Left = 6
.Top = 6
.Height = 60
.Width = 118
End With
For i = 1 To 5
With Me("Label" & i)
.Left = 126
.Width = 36
.Top = (i - 1) * 12 + 6
End With
DoEvents
Next i
Me.Repaint
For i = 0 To (20 - 1)
Alan1(i, 0) = "A" & (i + 1)
Alan(i, 0) = "A" & (i + 1)
Alan(i, 1) = "B" & (i + 1)
Alan(i, 2) = "C" & (i + 1)
Next i
ListBox1.List() = Alan
End Sub
Private Sub ListBox1_Click()
On Error Resume Next
Bilgi = ListBox1.Value
Label1.Caption = Application.WorksheetFunction.Match(Bilgi, Alan1, 0)
Label2.Caption = Application.WorksheetFunction.VLookup(Bilgi, Alan, 3, False)
Label3.Caption = Application.WorksheetFunction.Index(Alan, Label1.Caption, 3)
Label4.Caption = Application.WorksheetFunction.CountA(Alan1)
Label5.Caption = Application.WorksheetFunction.CountA(Alan)
End Sub

10 Eylül 2006 Pazar

Choose Dim DBase


'UserForm1

Option Explicit
Dim Alan
Dim Aranan
Dim i As Long

Private Sub ListBox1_Click()
On Error Resume Next
TextBox1.Text = ListBox1.List(ListBox1.ListIndex, 0)
End Sub
Private Sub TextBox1_Change()
On Error Resume Next
Aranan = TextBox1.Text
Label1.Caption = Application.VLookup(Aranan, Alan, 2, False)
Label2.Caption = Application.VLookup(Aranan, Alan, 3, False)
Label3.Caption = Application.VLookup(Aranan, Alan, 4, False)
End Sub
Private Sub UserForm_Initialize()
On Error Resume Next
ReDim Alan1(10000, 4)
For i = 0 To (10000 - 1)
Alan1(i, 0) = "Adı" & (i + 1)
Alan1(i, 1) = "Soyadı" & (i + 1)
Alan1(i, 2) = "Yaşı" & (i + 1)
Alan1(i, 3) = "Okulu" & (i + 1)
Next i
ListBox1.List() = Alan1
Alan = Alan1
End Sub

1 Eylül 2006 Cuma

Computer Name by GetComputerName Function


'Module1

Option Explicit
Private Declare Function GetComputerName& Lib "kernel32" Alias "GetComputerNameA" (ByVal lbbuffer As String, nsize As Long)
Dim BilgiAdı As String * 64

Sub Bilgisayar_Adı()

On Error Resume Next
Call GetComputerName(BilgiAdı, 64)
MsgBox "Bilgisayar Adı= " & BilgiAdı
End Sub

20 Ağustos 2006 Pazar

FileSystem Property



'Module1
Option Explicit
Dim fs, d, s

Sub ShowFileSystemType()
'Available return types include FAT, NTFS, and CDFS.
Set fs = CreateObject("Scripting.FileSystemObject")
Set d = fs.GetDrive("c:") 'a,b,c,d,e,f,g...
s = d.FileSystem
MsgBox "Dosyalama Sisteminiz: " & s & Chr(13) & Chr(13) & "Mustafa ULUSARAÇ" & Chr(13) & "01ulusarac@superonline.com", vbInformation, "[PBİD®] Available return types inculude FAT, NTFS and CDFS"
End Sub

10 Ağustos 2006 Perşembe

ComboBox Cntrl 2




'UserForm1

Option Explicit
Dim No

Private Sub ComboBox1_Change()
On Error Resume Next
Sheets("Sayfa1").Cells(ComboBox1.ListIndex + 1, 1).Select
End Sub
Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
On Error Resume Next
No = ActiveWindow.ScrollRow
If KeyCode = 13 Then Cells(No, 1).Activate
End Sub
Private Sub UserForm_Initialize()
On Error Resume Next
Sheets("Sayfa1").Rows("1:20").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom ComboBox1.RowSource = "Sayfa1!A1:A20"
ComboBox1.ListIndex = -1
End Sub

1 Ağustos 2006 Salı

ComboBox Cntrl 1



'UserForm1

Private Sub UserForm_Initialize()
On Error Resume Next
MyForm = Me.Name
ComboBox1.RowSource = "Sayfa1!A1:A20"
Call OrganizeComboBox
End Sub

 'Module1

Dim MyForm As Variant
Option Base 1

Sub OrganizeComboBox()
On Error Resume Next
Dim noData, i, j, k, m As Integer
Dim MyComboArray()
Dim MyRevizedComboArray()
Dim MyData As Range
Dim SortedColl As New Collection
Dim Swap1, Swap2 As Variant
For Each MyControl In UserForms(MyForm).Controls
i = 0
j = 0
k = 0
If TypeName(MyControl) = "ComboBox" Then
noData = MyControl.ListCount
ReDim MyComboArray(noData)
For Each MyData In Range(MyControl.RowSource)
i = i + 1
MyComboArray(i) = MyData
Next MyData
For m = 1 To UBound(MyComboArray)
If Not WorksheetFunction.IsNumber(MyComboArray(m)) Then
MyComboArray(m) = UCase(MyComboArray(m))
MyComboArray(m) = Replace(MyComboArray(m), "Ç", "Ç")
MyComboArray(m) = Replace(MyComboArray(m), "İ", "İ")
MyComboArray(m) = Replace(MyComboArray(m), "Ğ", "Ğ")
MyComboArray(m) = Replace(MyComboArray(m), "Ş", "Ş")
MyComboArray(m) = Replace(MyComboArray(m), "Ü", "Ü")
MyComboArray(m) = Replace(MyComboArray(m), "Ö", "Ö")
End If
Next m
For i = 1 To UBound(MyComboArray)
For j = i + 1 To UBound(MyComboArray) - 1
If MyComboArray(i) = MyComboArray(j) Then
MyComboArray(i) = ""
End If
Next j
Next i
MyControl.RowSource = ""
For i = 1 To UBound(MyComboArray)
If MyComboArray(i) <> "" Then
k = k + 1
ReDim Preserve MyRevizedComboArray(k)
MyRevizedComboArray(k) = MyComboArray(i)
End If
Next i
i = 0
j = 0
For i = 1 To UBound(MyRevizedComboArray)
SortedColl.Add MyRevizedComboArray(i)
Next i
'On Error Resume Next
'For i = 1 To UBound(MyRevizedComboArray)
'MyRevizedComboArray(i) = WorksheetFunction.Small(MyRevizedComboArray, i)
'Next

For i = 1 To SortedColl.Count - 1
For j = i + 1 To SortedColl.Count
If SortedColl(i) > SortedColl(j) Then
Swap1 = SortedColl(i)
Swap2 = SortedColl(j)
SortedColl.Add Swap1, before:=j
SortedColl.Add Swap2, before:=i
SortedColl.Remove i + 1
SortedColl.Remove j + 1
End If
Next j
Next i
For i = 1 To SortedColl.Count
MyControl.AddItem SortedColl(i)
Next i
For i = SortedColl.Count To 1 Step -1
SortedColl.Remove i
Next i
End If
Erase MyComboArray
Erase MyRevizedComboArray
Next MyControl
End Sub

20 Temmuz 2006 Perşembe

FileName Property




'Module1

Sub FileName_Property()
On Error Resume Next
Dim Rapor As String
Set fs = Application.FileSearch
Rapor = Empty
With fs
.LookIn = "C:\windows\system32"
.Filename = "cmd*.*"
If (.Execute > 0) Then
MsgBox "C:\windows\system32" & " klasörüde " & .FoundFiles.Count & " dosya(s) bulundu." & VBA.Chr(13) & VBA.Chr(13) & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbInformation, "[PBİD®] FileName Proıperty..."
For i = 1 To .FoundFiles.Count
Rapor = Rapor & VBA.Chr(13) & .FoundFiles(i)
Next i
MsgBox Rapor & VBA.Chr(13) & VBA.Chr(13) & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbInformation, "[PBİD®] FileName Property.."
Else
MsgBox "Herhangi bir dosya bulunamadı."
End If
End With
End Sub

10 Temmuz 2006 Pazartesi

FileType Property


'UserForm1

Option Explicit
Dim i As Single
Dim DosyaSeçimi

Private Sub UserForm_Initialize()
On Error Resume Next
Me.Caption = "[PBİD®] MsoFileType Arşivi..."
Call MsoFileTypeArşivi
ListBox1.ListIndex = 0
End Sub
Private Sub ListBox1_Change()
On Error Resume Next
Set DosyaSeçimi = Application.FileSearch
With DosyaSeçimi
.LookIn = "C:\Windows"
.FileType = ListBox1.List(ListBox1.ListIndex, 0)
If .Execute > 0 Then
Label4.Caption = .FoundFiles.Count
For i = 1 To .FoundFiles.Count
ListBox2.AddItem .FoundFiles(i)
Next i
Else
ListBox2.Clear
Label4.Caption = 0
End If
End With
End Sub
Sub MsoFileTypeArşivi()
On Error Resume Next
ListBox1.AddItem msoFileTypeAllFiles: ListBox1.List(0, 1) = "msoFileTypeAllFiles"
ListBox1.AddItem msoFileTypeBinders: ListBox1.List(1, 1) = "msoFileTypeBinders"
ListBox1.AddItem msoFileTypeCalendarItem: ListBox1.List(2, 1) = "msoFileTypeCalendarItem"
ListBox1.AddItem msoFileTypeContactItem: ListBox1.List(3, 1) = "msoFileTypeContactItem"
ListBox1.AddItem msoFileTypeDatabases: ListBox1.List(4, 1) = "msoFileTypeDatabases"
ListBox1.AddItem msoFileTypeDataConnectionFiles: ListBox1.List(5, 1) = "msoFileTypeDataConnectionFiles"
ListBox1.AddItem msoFileTypeDesignerFiles: ListBox1.List(6, 1) = "msoFileTypeDesignerFiles"
ListBox1.AddItem msoFileTypeDocumentImagingFiles: ListBox1.List(7, 1) = "msoFileTypeDocumentImagingFiles"
ListBox1.AddItem msoFileTypeExcelWorkbooks: ListBox1.List(8, 1) = "msoFileTypeExcelWorkbooks"
ListBox1.AddItem msoFileTypeJournalItem: ListBox1.List(9, 1) = "msoFileTypeJournalItem"
ListBox1.AddItem msoFileTypeMailItem: ListBox1.List(10, 1) = "msoFileTypeMailItem"
ListBox1.AddItem msoFileTypeNoteItem: ListBox1.List(11, 1) = "msoFileTypeNoteItem"
ListBox1.AddItem msoFileTypeOfficeFiles: ListBox1.List(12, 1) = "msoFileTypeOfficeFiles"
ListBox1.AddItem msoFileTypeOutlookItems: ListBox1.List(13, 1) = "msoFileTypeOutlookItems"
ListBox1.AddItem msoFileTypePhotoDrawFiles: ListBox1.List(14, 1) = "msoFileTypePhotoDrawFiles"
ListBox1.AddItem msoFileTypePowerPointPresentations: ListBox1.List(15, 1) = "msoFileTypePowerPointPresentations"
ListBox1.AddItem msoFileTypeProjectFiles: ListBox1.List(16, 1) = "msoFileTypeProjectFiles"
ListBox1.AddItem msoFileTypePublisherFiles: ListBox1.List(17, 1) = "msoFileTypePublisherFiles"
ListBox1.AddItem msoFileTypeTaskItem: ListBox1.List(18, 1) = "msoFileTypeTaskItem"
ListBox1.AddItem msoFileTypeTemplates: ListBox1.List(19, 1) = "msoFileTypeTemplates"
ListBox1.AddItem msoFileTypeVisioFiles: ListBox1.List(20, 1) = "msoFileTypeVisioFiles"
ListBox1.AddItem msoFileTypeWebPages: ListBox1.List(21, 1) = "msoFileTypeWebPages"
ListBox1.AddItem msoFileTypeWordDocuments: ListBox1.List(22, 1) = "msoFileTypeWordDocuments"
End Sub

1 Temmuz 2006 Cumartesi

Using the Graphic object




'Module1

Sub PageSetup_LeftFooterPicture()
On Error Resume Next
ActiveSheet.PageSetup.LeftFooterPicture.Filename = "C:\Documents and Settings\PC\Belgelerim\Resimlerim\Excel.jpg"
ActiveSheet.PageSetup.PrintArea = "$A$1:$D$21"
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = "&G"
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.75)
.RightMargin = Application.InchesToPoints(0.75)
.TopMargin = Application.InchesToPoints(1)
.BottomMargin = Application.InchesToPoints(1)
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.5)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 100
.PrintErrors = xlPrintErrorsDisplayed
End With
End Sub

20 Haziran 2006 Salı

Data Rate and Group Names and Group Opened a New Page.




'Module1

Option Explicit
Dim Sayfa As Worksheet
Dim Hücre As Range
Dim SonSayfa As Worksheet
Dim Alan As Range
Dim Satır As Variant

Sub VerileriKendiİsmindekiSayfalaraAktar()
On Error Resume Next
Application.DisplayAlerts = False
ActiveSheet.Move Before:=Sheets(1)
Application.DisplayAlerts = True
ActiveSheet.Copy After:=Sheets(Worksheets.Count)
Durak:
If [A2] = "" Then Exit Sub
Set Sayfa = ActiveSheet
Columns("A:D").EntireColumn.AutoFit
Sayfa.Name = [A2]
Set Hücre = [A2].CurrentRegion.Columns(1).ColumnDifferences([A2])
Set Hücre = Application.Intersect(Hücre.EntireRow, [A:D])
If Hücre.Address = "" Then Exit Sub
Worksheets.Add After:=Sheets(Worksheets.Count)
Set SonSayfa = Sheets(Worksheets.Count)
Sheets(SonSayfa.Name).Tab.ColorIndex = (Worksheets.Count - 1)
Sayfa.Select
For Each Alan In Hücre.Areas
Alan.Copy
Satır = SonSayfa.[a65536].End(3).Row + 1
SonSayfa.Cells(Satır, 1).Insert shift:=xlDown
Alan.Delete shift:=xlUp
Next
Set Hücre = Nothing
SonSayfa.Select
GoTo Durak
End Sub

Blog Arşivi

Gadget

Bu içerik henüz şifreli bağlantı üzerinden kullanılamıyor.

Bu Blogda Ara

Contributor

Contributor
Mustafa ULUSARAÇ İstanbul, TÜRKİYE
free counters
T. C. Central Bank Indicative Exchange Rates
Currency Exchange Rate Widget,Currency Converter Widget
Borsa İstanbul
Anadolu Üniversitesi Açık Öğretim Fakültesi