Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

20 Aralık 2005 Salı

MS Office 2003® CommandBar Buttons



'UserForm1

'AddTools on UserForm1: Frame1, Label1, ComboBox1, Label2, ComboBox2, ProgressBar1, ProgressBar2, Label3, CommandButton1, Image1, Label4
Option Explicit
Dim ÖzelMenü As Office.CommandBar
Dim ÖzelKomut As Office.CommandBarButton
Dim Resim As MSForms.Image, Resimlik(12000) As MSForms.Image
Dim i As Single, ii As Single, Sayaç As Single, No As Single
Dim Adet As Double, Başlama As Double, Bitiş As Double, Satır As Double, Sütun As Double

Private Sub UserForm_Initialize()
On Error GoTo Hata
Me.Caption = "[PBİD®] Micro Soft Office ® CommandBar Buttons..."
For i = 1 To 10033
ComboBox1.AddItem i
ComboBox2.AddItem i
Next i
ComboBox1.ListIndex = 0
ComboBox2.ListIndex = (ComboBox2.ListCount - 1)
Hata:
End Sub
Private Sub CommandButton1_Click()
On Error GoTo Hata
Adet = Frame1.Controls.Count
If (Adet > 0) Then
Frame1.Controls.Clear
End If
Başlama = ComboBox1.Value
Bitiş = ComboBox2.Value
If (Bitiş > Başlama) Or (Başlama = Bitiş) Then
ResimlikDüzenle Başlama, Bitiş
Else
MsgBox "Bitiş; başlama numarasından küçük olamaz!" & vbCrLf & vbCrLf & "Musafa ULUSARAÇ 01ulusarac@superonline.com", vbInformation, "[PBİD®]Lütfen Dikkat"
End If
Hata:
End Sub
Private Function ResimlikDüzenle(ByVal Baş As Double, ByVal Son As Double)
On Error GoTo Hata:
No = Baş - 1
Sayaç = 0
Satır = Application.WorksheetFunction.RoundUp(((Son - Baş) + 1) / 16, 0)
Frame1.ScrollHeight = (24 * Satır + 6)
Set ÖzelMenü = Application.CommandBars.Add("", msoBarPopup, , True)
Set ÖzelKomut = ÖzelMenü.Controls.Add(1, , , , True)
For i = 1 To Satır
If i = Satır Then
Sütun = ((16 - ((Satır * 16) - Son)) - Baş + 1)
Else
Sütun = 16
End If
For ii = 1 To Sütun
No = No + 1
Sayaç = Sayaç + 1
Set Resimlik(No) = Me.Frame1.Controls.Add("Forms.Image.1")
With Resimlik(No)
ÖzelKomut.FaceId = No
.Name = No
.Picture = ÖzelKomut.Picture
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip
.Top = ((i - 1) * 24 + 6)
.Left = ((ii - 1) * 24 + 6)
.Width = 24
.Height = 24
.SpecialEffect = fmSpecialEffectEtched
.ControlTipText = No
End With
ProgressBar1.Value = ((ii / Sütun) * 100)
Label1.Caption = "%" & VBA.Round(100 * (Sayaç / ((Son - Baş) + 1)), 0)
DoEvents
Next ii
ProgressBar2.Value = ((i / Satır) * 100)
DoEvents
Next i
Exit Function
Hata:
MsgBox No
End Function

10 Aralık 2005 Cumartesi

Add Method


'1) As it applies to the AddIns object.

'This example inserts the add-in Myaddin.xla from drive A. When you run this example, Microsoft Excel copies the file A:\Myaddin.xla to the Library folder on your hard disk and adds the add-in title to the list in the Add-Ins dialog box.
Sub UseAddIn()


Set myAddIn = AddIns.Add(Filename:="A:\MYADDIN.XLA", CopyFile:=True)
MsgBox myAddIn.Title & " has been added to the list"

End Sub

'2) As it applies to the AllowEditRanges object.

'This example allows edits to range "A1:A4" on the active worksheet, notifies the user, then changes the password for this specified range and notifies the user of this change.

Sub UseChangePassword()

Dim wksOne As Worksheet
Set wksOne = Application.ActiveSheet
' Protect the worksheet.

wksOne.Protect
'
Establish a range that can allow edits
' on the protected worksheet.
wksOne.Protection.AllowEditRanges.Add Title:="Classified", Range:=Range("A1:A4"), Password:="secret"
MsgBox "Cells A1 to A4 can be edited on the protected worksheet."
'
Change the password.

wksOne.Protection.AllowEditRanges(1).ChangePassword Password:="moresecret"
MsgBox "The password for these cells has been changed."

End Sub

'3) As it applies to the CalculatedFields object.

'This example adds a calculated field to the first PivotTable report on worksheet one.
Worksheets(1).PivotTables(1).CalculatedFields.Add "PxS", "= Product * Sales"


'4) As it applies to the CalculatedMembers object.

'The following example adds a set to a PivotTable, assuming a PivotTable exists on the active worksheet.

Sub UseAddSet()

Dim pvtOne As PivotTable
Dim strAdd As String
Dim strFormula As String
Dim cbfOne As CubeField
Set pvtOne = ActiveSheet.PivotTables(1)
strAdd = "[MySet]"
strFormula = "'{[Product].[All Products].[Food].children}'"
' Establish connection with data source if necessary.
If Not pvtOne.PivotCache.IsConnected Then pvtOne.PivotCache.MakeConnection
' Add a calculated member titled "[MySet]"
pvtOne.CalculatedMembers.Add Name:=strAdd, Formula:=strFormula, Type:=xlCalculatedSet
' Add a set to the CubeField object.
Set cbfOne = pvtOne.CubeFields.AddSet(Name:="[MySet]", Caption:="My Set")

End Sub

'5) As it applies to the ChartObjects object.

'This example creates a new embedded chart..

Set co = Sheets("Sheet1").ChartObjects.Add(50, 40, 200, 100)
co.Chart.ChartWizard Source:=Worksheets("Sheet1").Range("A1:B2"), Gallery:=xlColumn, Format:=6, PlotBy:=xlColumns, CategoryLabels:=1, SeriesLabels:=0, HasLegend:=1


'6) As it applies to the Charts object.

'This example creates an empty chart sheet and inserts it before the last worksheet.

ActiveWorkbook.Charts.Add Before:=Worksheets(Worksheets.Count)

'7) As it applies to the CustomProperties object.

'This example adds identifier information to the active worksheet and returns the name and value to the user.

Sub CheckCustomProperties()

Dim wksSheet1 As Worksheet
Set wksSheet1 = Application.ActiveSheet
' Add metadata to worksheet.
wksSheet1.CustomProperties.Add Name:="Market", Value:="Nasdaq"
' Display metadata.
With wksSheet1.CustomProperties.Item(1)

MsgBox .Name & vbTab & .Value

End With

End Sub

'8) As it applies to the CustomViews object.

'This example creates a new custom view named "Summary" in the active workbook.

ActiveWorkbook.CustomViews.Add "Summary", True, True

'9) As it applies to the FormatConditions object.

'This example adds a conditional format to cells E1:E10.

With Worksheets(1)

.Range("e1:e10").FormatConditions.Add(xlCellValue, xlGreater, "=$a$1")

With .Borders

.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 6

End With
With .Font


.Bold = True
.ColorIndex = 3

End With

End With

'10) As it applies to the HPageBreaks object.

'This example adds a horizontal page break above cell F25 and adds a vertical page break to the left of this cell.

With Worksheets(1)

.HPageBreaks.Add .Range("F25")
.VPageBreaks.Add .Range("F25")

End With

'11) As it applies to the Hyperlinks object.

'This example adds a hyperlink to cell A5.

With Worksheets(1)

.Hyperlinks.Add Anchor:=.Range("a5"), Address:="http://example.microsoft.com", ScreenTip:="Microsoft Web Site", TextToDisplay:="Microsoft"

End With
'This example adds an email hyperlink to cell A5.
With Worksheets(1)


.Hyperlinks.Add Anchor:=.Range("a5"), Address:="mailto:someone@microsoft.com?subject=hello", ScreenTip:="Write us today", TextToDisplay:="Support"

End With

'12) As it applies to the ListColumns collection object.

'The following example adds a new column to the default ListObject object in the first worksheet of the workbook. Because no position is specified, a new rightmost column is added.
Set myNewColumn = ActiveWorkbook.Worksheets(1).ListObjects(1).ListColumns.Add
Note A name for the column is automatically generated. You can choose to change the name after the column has been added.


'13) As it applies to the ListObjects collection object.

'The following example adds a new ListObject object based on data from a Microsoft Windows SharePoint Services site to the default ListObjects collection and places the list in cell A1 in the first worksheet of the workbook.
Note The following code example assumes that you will substitute a valid server name and the list guid in the variables strServerName and strListGUID. Additionally, the server name must be followed by "/_vti_bin" or the sample will not work.


Set objListObject = ActiveWorkbook.Worksheets(1).ListObjects.Add(SourceType:= xlSrcExternal, Source:= Array(strServerName, StrListGUID), TRUE, XlGuess, Destination:= Range("A1")
Note If there is existing data at cell A1, the existing list data will be moved to the right to accommodate the new list.


'14) As it applies to the ListRows collection object.

'The following example adds a new row to the default ListObject object in the first worksheet of the workbook. Because no position is specified, the new row is added to the bottom of the list.

Set myNewColumn = ActiveWorkbook.Worksheets(1).ListObject(1).ListRows.Add

'15) As it applies to the Names object.

'This example defines a new name for the range A1:D3 on Sheet1 in the active workbook. Note Nothing is returned if Sheet1 does not exist.

Sub MakeRange()

ActiveWorkbook.Names.Add Name:="tempRange", RefersTo:="=Sheet1!$A$1:$D$3"

End Sub

'16) As it applies to the OLEObjects object.

'This example creates a new Microsoft Word OLE object on Sheet1.

ActiveWorkbook.Worksheets("Sheet1").OLEObjects.Add ClassType:="Word.Document"
'This example adds a command button to sheet one.


Worksheets(1).OLEObjects.Add ClassType:="Forms.CommandButton.1", Link:=False, DisplayAsIcon:=False, Left:=40, Top:=40, Width:=150, Height:=10

'17) As it applies to the Parameters object.

'This example changes the SQL statement for query table one. The clause "(city=?)" indicates that the query is a parameter query, and the value of city is set to the constant "Oakland."

Set qt = Sheets("sheet1").QueryTables(1)
qt.Sql = "SELECT * FROM authors WHERE (city=?)"
Set param1 = qt.Parameters.Add("City Parameter", xlParamTypeVarChar)
param1.SetParam xlConstant, "Oakland"
qt.Refresh


'18) As it applies to the Phonetics object.

'This example adds three phonetic text strings to the active cell. The example then sets the character type to Hiragana, sets the font color to blue, and sets the text to visible.

ActiveCell.FormulaR1C1 = ""
ActiveCell.Phonetics.Add Start:=1, Length:=3, Text:=""
ActiveCell.Phonetics.Add Start:=4, Length:=3, Text:=""
ActiveCell.Phonetics.CharacterType = xlHiragana
ActiveCell.Phonetics.Font.Color = vbBlue
ActiveCell.Phonetics.Visible = True


'19) As it applies to the PivotCaches object.

'This example creates a new PivotTable cache based on an OLAP provider and then it creates a new PivotTable report based on the cache, at cell A3 on the active worksheet.

Dim cnnConn As ADODB.Connection
Dim rstRecordset As ADODB.Recordset
Dim cmdCommand As ADODB.Command
' Open the connection.


Set cnnConn = New ADODB.Connection
With cnnConn


.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0"
.Open "C:\perfdate\record.mdb"

End With
' Set the command text.


Set cmdCommand = New ADODB.Command
Set cmdCommand.ActiveConnection = cnnConn
With cmdCommand


.CommandText = "Select Speed, Pressure, Time From DynoRun"
.CommandType = adCmdText
.Execute

End With
' Open the recordset.


Set rstRecordset = New ADODB.Recordset
Set rstRecordset.ActiveConnection = cnnConn
rstRecordset.Open cmdCommand
' Create a PivotTable cache and report.


Set objPivotCache = ActiveWorkbook.PivotCaches.Add(SourceType:=xlExternal)
Set objPivotCache.Recordset = rstRecordset
With objPivotCache


.CreatePivotTable TableDestination:=Range("A3"), TableName:="Performance"

End With
With ActiveSheet.PivotTables("Performance")


.SmallGrid = False
With .PivotFields("Pressure")

.Orientation = xlRowField
.Position = 1

End With
With .PivotFields("Speed")

.Orientation = xlColumnField
.Position = 1

End With
With .PivotFields("Time")

.Orientation = xlDataField
.Position = 1

End With

End With
' Close the connections and clean up.


cnnConn.Close
Set cmdCommand = Nothing
Set rstRecordset = Nothing
Set cnnConn = Nothing


'20) As it applies to the PivotFormulas object.

'This example creates a new PivotTable formula for the first PivotTable report on worksheet one.

Worksheets(1).PivotTables(1).PivotFormulas.Add "Year['1998'] Apples = (Year['1997'] Apples) * 2"

'21) As it applies to the PivotItems object.

'This example creates a new PivotTable item in the first PivotTable report on worksheet one.

Worksheets(1).PivotTables(1).PivotItems("Year").Add "1998"

'22) As it applies to the PivotTables object.

'This example creates a new PivotTable cache based on an OLAP provider, and then it creates a new PivotTable report based on the cache, at cell A1 on the first worksheet.

Dim cnnConn As ADODB.Connection
Dim rstRecordset As ADODB.Recordset
Dim cmdCommand As ADODB.Command
' Open the connection.


Set cnnConn = New ADODB.Connection
With cnnConn


.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0"
.Open "C:\perfdate\record.mdb"

End With
' Set the command text.Set cmdCommand = New ADODB.Command
Set cmdCommand.ActiveConnection = cnnConn
With cmdCommand


.CommandText = "Select Speed, Pressure, Time From DynoRun"
.CommandType = adCmdText
.Execute

End With
' Open the recordset.


Set rstRecordset = New ADODB.Recordset
Set rstRecordset.ActiveConnection = cnnConn
rstRecordset.Open cmdCommand
' Create PivotTable cache and report.


Set objPivotCache = ActiveWorkbook.PivotCaches.Add(SourceType:=xlExternal)
Set objPivotCache.Recordset = rstRecordset
ActiveSheet.PivotTables.Add PivotCache:=objPivotCache, TableDestination:=Range("A3"), TableName:="Performance"
With ActiveSheet


.PivotTables("Performance")

.SmallGrid = False
With .PivotFields("Pressure")

.Orientation = xlRowField
.Position = 1

End With
With .PivotFields("Speed")


.Orientation = xlColumnField
.Position = 1

End With
With .PivotFields("Time")

.Orientation = xlDataField
.Position = 1

End With

End With
' Close the connections and clean up.cnnConn.Close
Set cmdCommand = Nothing
Set rstRecordset = Nothing
Set cnnConn = Nothing


'23) As it applies to the PublishObjects object.

'This example saves the range D5:D9 on the First Quarter worksheet in the active workbook to a Web page called Stockreport.htm. You use the Spreadsheet component to add interactivity to the Web page.

ActiveWorkbook.PublishObjects.Add(SourceType:=xlSourceRange, Filename:="\\Server2\Q1\Stockreport.htm", Sheet:="First Quarter", Source:="D5:D9", HtmlType:=xlHtmlCalc).Publish

'24) As it applies to the QueryTables object.

'This example creates a query table based on an ADO recordset. The example preserves the existing column sorting and filtering settings and layout information for backward compatibility.

Dim cnnConnect As ADODB.Connection
Dim rstRecordset As ADODB.Recordset
Set cnnConnect = New ADODB.Connection
cnnConnect.Open "Provider=SQLOLEDB;" & "Data Source=srvdata;" & "User ID=testac;Password=4me2no;"
Set rstRecordset = New ADODB.Recordset
rstRecordset.Open Source:="Select Name, Quantity, Price From Products", ActiveConnection:=cnnConnect, CursorType:=adOpenDynamic, LockType:=adLockReadOnly, Options:=adCmdText
With ActiveSheet


.QueryTables.Add(Connection:=rstRecordset, Destination:=Range("A1"))

.Name = "Contact List"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = True
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.Refresh BackgroundQuery:=False

End With
'This example imports a fixed width text file into a new query table. The first column in the text file is five characters wide and is imported as text. The second column is four characters wide and is skipped. The remainder of the text file is imported into the third column and has the General format applied to it.


Set shFirstQtr = Workbooks(1).Worksheets(1)
Set qtQtrResults = shFirstQtr.QueryTables.Add(Connection:="TEXT;C:\My Documents\19980331.txt", Destination:=shFirstQtr.Cells(1, 1))
With qtQtrResults


.TextFileParsingType = xlFixedWidth
.TextFileFixedColumnWidths := Array(5,4)
.TextFileColumnDataTypes:= Array(xlTextFormat, xlSkipColumn, xlGeneralFormat)
.Refresh

End With
'This example creates a new query table on the active worksheet.

sqlstring = "select 96Sales.totals from 96Sales where profit < connstring = "ODBC;DSN=96SalesData;UID=Rep21;PWD=NUyHwYQI;Database=96Sales">

.Refresh

End With

'25) As it applies to the RecentFiles object.

'This example adds Oscar.xls to the list of recently used files.

Application.RecentFiles.Add Name:="Oscar.xls"

'26) As it applies to the Scenarios object.

'This example adds a new scenario to Sheet1.

Worksheets("Sheet1").Scenarios.Add Name:="Best Case", ChangingCells:=Worksheets("Sheet1").Range("A1:A4"), Values:=Array(23, 5, 6, 21), Comment:="Most favorable outcome."

'27) As it applies to the SeriesCollection object.

'This example creates a new series in Chart1. The data source for the new series is range B1:B10 on Sheet1.

Charts("Chart1").SeriesCollection.Add Source:=ActiveWorkbook.Worksheets("Sheet1").Range("B1:B10")
'This example creates a new series on the embedded chart on Sheet1.


Worksheets("Sheet1").ChartObjects(1).Activate
ActiveChart.SeriesCollection.Add Source:=Worksheets("Sheet1").Range("B1:B10")


'28) As it applies to the Sheets and WorkSheets objects.

'This example inserts a new worksheet before the last worksheet in the active workbook.ActiveWorkbook.Sheets.Add Before:=Worksheets(Worksheets.Count)

'29) As it applies to the SmartTags object.

'This example adds a smart tag titled MSFT to cell A1, then adds extra metadata called Market with the value of Nasdaq to the smart tag and then returns the value of the property to the user. This example assumes the host system is connected to the Internet.

Sub UseProperties()

Dim strLink As String
Dim strType As String
' Define smart tag variables.strLink = "urn:schemas-microsoft-com:smarttags#stocktickerSymbol"
strType = "stockview"
Range("A1").Formula = "MSFT"
' Add a property for MSFT smart tag and define its value.Range("A1").SmartTags.Add(strLink).Properties.Add Name:="Market", Value:="Nasdaq"
' Notify the user of the smart tag's value.

MsgBox Range("A1").SmartTags.Add(strLink).Properties("Market").Value

End Sub

'30) As it applies to the Styles object.

'This example defines a new style based on cell A1 on Sheet1.

With ActiveWorkbook

.Styles.Add(Name:="theNewStyle")

.IncludeNumber = False
.IncludeFont = True
.IncludeAlignment = False
.IncludeBorder = False
.IncludePatterns = False
.IncludeProtection = False
.Font.Name = "Arial"
.Font.Size = 18

End With

'31) As it applies to the Trendlines object.

'This example creates a new linear trendline in Chart1.

ActiveWorkbook.Charts("Chart1").SeriesCollection(1).Trendlines.Add

'32) As it applies to the Validation object.

'This example adds data validation to cell E5.

With Range("e5")

.Validation

.Add Type:=xlValidateWholeNumber, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="5", Formula2:="10"
.InputTitle = "Integers"
.ErrorTitle = "Integers"
.InputMessage = "Enter an integer from five to ten"
.ErrorMessage = "You must enter a number from five to ten"

End With

'33) As it applies to the VPageBreaks object.

'This example adds a horizontal page break above cell F25 and adds a vertical page break to the left of this cell.

With Worksheets(1)

.HPageBreaks.Add .Range("F25")
.VPageBreaks.Add .Range("F25")

End With

'34) As it applies to the Watches object.

'This example creates a summation formula in cell A3 and then adds this cell to the watch facility.

Sub AddWatch()
With Application

.Range("A1").Formula = 1
.Range("A2").Formula = 2
.Range("A3").Formula = "=Sum(A1:A2)"
.Range("A3").Select
.Watches.Add Source:=ActiveCell

End With
End Sub

'35) As it applies to the WorkBooks object.

'This example creates a new workbook.

Workbooks.Add

1 Aralık 2005 Perşembe

MS Office ® Word PopUp Menu



'MicroSoft® Word ThisDocument Module

Option Explicit
Dim CB As CommandBar
Dim CBP As CommandBarPopup
Dim CBB As CommandBarButton

Private Sub Document_Open()
On Error Resume Next
Call PopUpMenüYap
End Sub
Private Sub Document_Close()
On Error Resume Next
Call PopUpMenüBoz
End Sub
Sub PopUpMenüYap()
On Error Resume Next
Call PopUpMenüBoz
Set CB = CommandBars.Add(Name:="[PBİD®] PopUp Menü", Position:=msoBarFloating, temporary:=True)
With CB
Set CBP = .Controls.Add(Type:=msoControlPopup)
With CBP
.Caption = "[PBİD®] Popup 1"
.BeginGroup = True
Set CBB = .Controls.Add(Type:=msoControlButton)
With CBB
.Caption = "[PBİD®] Button 1a"
.Style = msoButtonIconAndCaption
.BeginGroup = True
.OnAction = "Macro1a"
.FaceId = 203
End With
Set CBB = .Controls.Add(Type:=msoControlButton)
With CBB
.Caption = "[PBİD®] Button 1b"
.Style = msoButtonIconAndCaption
.BeginGroup = False
.OnAction = "Macro1b"
.FaceId = 202
End With
End With
Set CBP = .Controls.Add(Type:=msoControlPopup)
With CBP
.Caption = "[PBİD®] Popup 2"
.BeginGroup = False
Set CBB = .Controls.Add(Type:=msoControlButton)
With CBB
.Caption = "[PBİD®] Button 2a"
.Style = msoButtonIconAndCaption
.BeginGroup = True
.OnAction = "Macro2a"
.FaceId = 201
End With
Set CBB = .Controls.Add(Type:=msoControlButton)
With CBB
.Caption = "[PBİD®] Button 2b"
.Style = msoButtonIconAndCaption
.BeginGroup = False
.OnAction = "Macro2b"
.FaceId = 180
End With
End With
.Top = 240
.Left = 240
.Width = 240
.Visible = True
End With
End Sub
Sub PopUpMenüBoz()
On Error Resume Next
CommandBars("[PBİD®] PopUp Menü").Delete
On Error GoTo 0
End Sub

20 Kasım 2005 Pazar

Another Of The Page In The Book Creating a Backup




'UserForm1

'AddTools on UserForm1: Image1, Label1, Label2, ListBox1, SpreadSheet1, CommandButton1
Option Explicit
Dim i As Single, ii As Single, No As Single
Dim Adet As Double
Dim Sayfa As Worksheet, Adı As String, Alan As Range, Adres As String

Private Sub UserForm_Initialize()
On Error Resume Next
With Me
.Caption = "[PBİD®]Another of the page in the book Creating a Backup"
.width = 491
.height = 296
End With
Application.Visible = True
End Sub
Private Sub UserForm_Activate()
On Error Resume Next
Call SayfalarıListele
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
On Error Resume Next
Application.Visible = True
End Sub
Private Sub ListBox1_Click()
On Error Resume Next
No = ListBox1.ListIndex
Adı = ListBox1.List(No, 0)
Set Sayfa = ThisWorkbook.Sheets(Adı)
Sayfa.Select
'Set Alan = Sayfa.UsedRange
Set Alan = Sayfa.Cells
Adres = Alan.Address
Alan.Copy
With Spreadsheet1.Sheets(1)
.Cells.ClearContents
'.Range(Adres).Paste
.Cells(1, 1).Paste
.Range("A1").Select
Application.CutCopyMode = False
End With
'With Spreadsheet1
          ‘ .Cells.ClearContents
          ' .Sheets(1).Range(Adres) = Alan.Value
'End With
End Sub
Private Sub CommandButton1_Click() '[Another of the page in the book Creating a Backup]
On Error Resume Next
ActiveSheet.Copy
Application.Dialogs(xlDialogSaveAs).Show
End Sub
Sub SayfalarıListele()
On Error Resume Next
For Each Sayfa In ThisWorkbook.Worksheets
ListBox1.AddItem Sayfa.Name
Next Sayfa
End Sub

10 Kasım 2005 Perşembe

Series to Date



'UserForum1

'AddTools on UserForm1: ListBox1, Label1

Option Explicit
Dim x, y, z As Single
Dim TMP1$, TMP2$
Dim Doğum As String

Private Sub UserForm_Initialize()
On Error Resume Next
Me.Caption = "[PBİD®] Tarih dizisi oluşturmak"
Application.Visible = False
ListBox1.Clear
For x = 1959 To 1965
For y = 1 To 12
For z = 1 To 31
TMP1$ = Format(DateSerial(x, y, z), "dd-mm-yyyy")
Doğum = ""
If TMP1$ = "04-03-1959" Then Doğum = " Mustafa ULUSARAÇ doğdu...": TMP2$ = TMP1$ & Doğum
ListBox1.AddItem TMP1$ & Doğum
Next z
Next y
Next x
ListBox1.Value = TMP2$
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
On Error Resume Next
Application.Visible = True
End Sub

1 Kasım 2005 Salı

Moving Data by Dragging



'UserForm1

'AddTools on UserForm1: ListBox1, ListBox2, ComboBox1, TextBox1, Label1, Label2
Option Explicit
Dim TaşınanVeri As DataObject
Dim i As Single
Dim FareResmi As Integer

Private Sub UserForm_Initialize()
On Error Resume Next
Me.Caption = "[PBİD®]ListBox dan sürükleyerek veri taşımak..."
Application.Visible = False
For i = 1 To 24
ListBox1.AddItem "Kayıt " & (ListBox1.ListCount + 1)
Next i
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
On Error Resume Next
Application.Visible = True
End Sub
Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
On Error Resume Next
If Button = 1 Then
Set TaşınanVeri = New DataObject
TaşınanVeri.SetText ListBox1.Value
FareResmi = TaşınanVeri.StartDrag
End If
End Sub
Private Sub ListBox2_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal DragState As Long, ByVal FareResmi As MSForms.ReturnEffect, ByVal Shift As Integer)
On Error Resume Next
Cancel = True
FareResmi = 1
End Sub
Private Sub ListBox2_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, ByVal Action As Long, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal FareResmi As MSForms.ReturnEffect, ByVal Shift As Integer)
On Error Resume Next
Cancel = True
FareResmi = 1
ListBox2.AddItem Data.GetText
End Sub
Private Sub ComboBox1_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal DragState As MSForms.fmDragState, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)
On Error Resume Next
Cancel = True
FareResmi = 1
End Sub
Private Sub ComboBox1_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, ByVal Action As MSForms.fmAction, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)
On Error Resume Next
Cancel = True
FareResmi = 1
ComboBox1.AddItem Data.GetText
ComboBox1.ListIndex = ComboBox1.LineCount - 1
End Sub
Private Sub TextBox1_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal DragState As MSForms.fmDragState, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)
On Error Resume Next
Cancel = True
FareResmi = 1
End Sub
Private Sub TextBox1_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, ByVal Action As MSForms.fmAction, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)
On Error Resume Next
Cancel = True
FareResmi = 1
TextBox1.Value = Data.GetText
End Sub
Private Sub Label2_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal DragState As MSForms.fmDragState, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)
On Error Resume Next
Cancel = True
FareResmi = 1
End Sub
Private Sub Label2_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, ByVal Action As MSForms.fmAction, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)
On Error Resume Next
Cancel = True
FareResmi = 1
Label2.Caption = Data.GetText
End Sub

20 Ekim 2005 Perşembe

Region Naming And Deletion

'Module1
Option Explicit
Dim Alan As Range, Sayfa As Worksheet

Sub AlanTanımıVeSilinmesi() '[Region naming and deletion]
On Error GoTo Hata
Set Sayfa = ThisWorkbook.Sheets("Sayfa1")
Set Alan = Sayfa.Range("A2:F6")
Sayfa.Names.Add Name:="Bölge1", RefersToR1C1:=Alan
Application.Goto Reference:="Bölge1"
Sayfa.Range("Bölge1").Value = 1
[A1].Value = Application.WorksheetFunction.Sum(Range("Bölge1"))
Sheets("Sayfa1").Names("Bölge1").Delete
Exit Sub
Hata:
End Sub

10 Ekim 2005 Pazartesi

The Cell Free / Full, And Signing Status



'Module1

Option Explicit
Dim i As Single
Dim X

Sub HücreBoşDoluVeSayısalOlmaDurumu() '[The Cell Free / Full, And Signing Status]
On Error GoTo Hata
For i = 2 To 18
X = Cells(i, 1).Value
If VBA.IsArray(X) = False Then Cells(i, 3) = "False"
If VBA.IsDate(X) = False Then Cells(i, 4) = "False"
If VBA.IsEmpty(X) = False Then Cells(i, 5) = "False"
If VBA.IsError(X) = False Then Cells(i, 6) = "False"
If VBA.IsMissing(X) = False Then Cells(i, 7) = "False"
If VBA.IsNull(X) = False Then Cells(i, 8) = "False"
If VBA.IsNumeric(X) = False Then Cells(i, 9) = "False"
If VBA.IsObject(X) = False Then Cells(i, 10) = "False"
If VBA.IsArray(X) = True Then Cells(i, 3) = "True"
If VBA.IsDate(X) = True Then Cells(i, 4) = "True"
If VBA.IsEmpty(X) = True Then Cells(i, 5) = "True"
If VBA.IsError(X) = True Then Cells(i, 6) = "True"
If VBA.IsMissing(X) = True Then Cells(i, 7) = "True"
If VBA.IsNull(X) = True Then Cells(i, 8) = "True"
If VBA.IsNumeric(X) = True Then Cells(i, 9) = "True"
If VBA.IsObject(X) = True Then Cells(i, 10) = "True"
Next i
Hata:
End Sub

1 Ekim 2005 Cumartesi

Field Marking



'Module1

Option Explicit
Dim Hücre As Range
Dim Aranan As String, Bulunan As String

Sub Alanİşaretleme() '[Field Marking]
On Error GoTo Hata
Aranan = Range("E2").Value
If Aranan = "" Then
GoTo Hata
Else
Set Hücre = Range("A1:A65536").Find(Aranan, , , , , xlNext)
Bulunan = Hücre.Address
Set Hücre = Range("A1:A65536").Find(Aranan, , , , , xlPrevious)
Bulunan = Bulunan & ":" & Hücre.Address
Range(Bulunan).Select
End If
Exit Sub
Hata:
Range("A1").Select
End Sub

20 Eylül 2005 Salı

UserForm Icon


'UserForm1
'AddTools on UserForm1: Image1, Label1
'Image1 Picture: Your *.ico file...
Option Explicit
Dim Ekran As New Class1

Private Sub UserForm_Initialize()
On Error Resume Next
Me.Caption = "[PBİD®] UserForm Icon..."
Application.Visible = False
End Sub
Private Sub UserForm_Activate()
On Error Resume Next
Set Ekran.Simge_Ekle = Me
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
On Error Resume Next
Application.Visible = True
End Sub
'Class1

Option Explicit
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 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 FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetActiveWindow Lib "user32.dll" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
Private Pencere As Long, Tercih As Long, FIcon As Long, Tarz As Long, Sonuç As Long

Public Property Set Simge_Ekle(ByVal Ekran As Object)
On Error Resume Next
FIcon = Ekran.Label1.Picture.Handle
Pencere = FindWindow(vbNullString, Ekran.Caption)
Tercih = SendMessage(Pencere, &H80, 0&, ByVal FIcon)
Tercih = SendMessage(Pencere, &H80, 1&, ByVal FIcon)
Tercih = DrawMenuBar(Pencere)
Tarz = GetWindowLong(Pencere, (-20))
Tarz = Tarz Or &H40000
Sonuç = SetWindowPos(Pencere, 0, 0, 0, 0, 0, &H2 Or &H1 Or &H10 Or &H80)
Sonuç = SetWindowLong(Pencere, (-20), Tarz)
Sonuç = SetWindowPos(Pencere, 0, 0, 0, 0, 0, &H2 Or &H1 Or &H10 Or &H40)
End Property

10 Eylül 2005 Cumartesi

Useful Class1

'Class1

Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowA Lib "user32" (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 GetWindowLongA Lib "user32" (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 SetWindowLongA Lib "user32" (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
Private Const WS_BORDER = &H800000
Private Const GWL_STYLE = (-16)
Dim hWndForm As Long
Dim hwnd As Long, FormStyle As Long
Dim StartTime As String
Dim frmStyle As Long
Dim i As Integer

Public Property Set Form1(objForm As Object)
hWndForm = FindWindow(vbNullString, objForm.Caption)
frmStyle = GetWindowLong(hWndForm, (-16)) Or &H80000 Or &H20000 Or &H10000
SetWindowLong hWndForm, (-16), frmStyle
ShowWindow hWndForm, 3
DrawMenuBar hWndForm
End Property
Public Property Set Form2(objForm As Object)
hwnd = FindWindowA(vbNullString, objForm.Caption)
frmStyle = GetWindowLong(hwnd, (-16)) Or &H80000 Or &H20000 Or &H10000
SetWindowLong hwnd, GWL_STYLE, GetWindowLong(hwnd, GWL_STYLE) And Not WS_BORDER
ShowWindow hwnd, 5
DrawMenuBar hwnd
End Property
Public Property Set Form3(objForm As Object)
Dim hwnd As Long
hwnd = FindWindowA("Thunder" & IIf(Application.Version Like "8*", "X", "D") & "Frame", İlerleme_Formu.Caption)
SetWindowLongA hwnd, -16, GetWindowLongA(hwnd, -16) And &HFFF7FFFF
End Property
Public Property Set Form4(objForm As Object) 'Kapat yok
hWndForm = FindWindow(vbNullString, objForm.Caption)
frmStyle = GetWindowLong(hWndForm, (-16)) And &HFFF7FFFF
SetWindowLong hWndForm, (-16), frmStyle
ShowWindow hWndForm, 5
DrawMenuBar hWndForm
End Property
Public Property Set Form5(objForm As Object) 'Kapat işlevsiz
hWndForm = FindWindow(vbNullString, objForm.Caption)
frmStyle = GetWindowLong(hWndForm, (-16)) And &HFFF7FFFF
SetWindowLong hWndForm, (-16), frmStyle
End Property

1 Eylül 2005 Perşembe

SENDKEY Method


'Module1

Sub SENDKEY_File()
On Error Resume Next
Application.SendKeys ("%fx")
End Sub
Sub SENDKEY_Edit()
On Error Resume Next
Application.SendKeys ("%ex")
End Sub
Sub SENDKEY_View()
On Error Resume Next
Application.SendKeys ("%vx")
End Sub
Sub SENDKEY_Insert()
On Error Resume Next
Application.SendKeys ("%ix")
End Sub
Sub SENDKEY_Format()
On Error Resume Next
Application.SendKeys ("%ox")
End Sub
Sub SENDKEY_Debug()
On Error Resume Next
Application.SendKeys ("%dx")
End Sub
Sub SENDKEY_Run()
On Error Resume Next
Application.SendKeys ("%rx")
End Sub
Sub SENDKEY_Tools()
On Error Resume Next
Application.SendKeys ("%tx")
End Sub
Sub SENDKEY_Add_Ins()
On Error Resume Next
Application.SendKeys ("%ax")
End Sub
Sub SENDKEY_Window()
On Error Resume Next
Application.SendKeys ("%wx")
End Sub
Sub SENDKEY_Help()
On Error Resume Next
Application.SendKeys ("%hx")
End Sub

20 Ağustos 2005 Cumartesi

Week Number Of Day Serial




'UserForm1

'AddTools on UserForm1: Image1, Label1, Label2, Label3, Label4, Label5, ListBox1, CommandButton1, TextBox1, Label6, TextBox2, Label7, Label8
Option Explicit
Dim i As Single
Dim Adet As Double
Dim Tarih As Date
Dim a, b, c, d, e, f, g, h

Private Sub UserForm_Initialize()
On Error Resume Next
With Me
.Caption = "[PBİD®]Week Number Of Day Serial"
.width = 281
.height = 289
.BackColor = &H80000016
End With
With ListBox1
.ColumnCount = 4
.ColumnWidths = "42;42;42;126"
.Font.Size = 8
End With
Application.Visible = True
End Sub
Private Sub UserForm_Activate()
On Error Resume Next
TextBox1.Value = VBA.Format("1/9/2008", "dd.mm.yyyy")
TextBox2.Value = VBA.Format(VBA.DateValue("1/1/2009") + 90, "dd.mm.yyyy")
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() '[Week Number]
On Error Resume Next
ListBox1.Clear
If VBA.IsDate(VBA.DateValue(TextBox1.Value)) = True And VBA.IsDate(VBA.DateValue(TextBox2.Value)) = True Then
Adet = VBA.DateValue(TextBox2.Value) - VBA.DateValue(TextBox1.Value) + 1
For i = 1 To Adet
Tarih = (i - 1) + VBA.DateValue(TextBox1.Value)
With ListBox1
.AddItem
.List((i - 1), 3) = VBA.Format(Tarih, "dd.mmmm.yyyy dddd")
a = Tarih
'Dönem Sonu tarih
b = VBA.Weekday(Tarih, 2) 'Dönem Sonunun Hafta İçi Gün No
c = VBA.DateSerial(VBA.Year(Tarih) - 1, 12, 31)
'Dönem Sonu Tarihten Önceki Yılın Son Günü
d = VBA.Weekday(c, 2) 'Dönem Başının Hafta İçi Gün No
e = (a + (7 - b))
'Dönem Sonu Haftasının Son Günü
f = (c + (7 - d))
'Dönem Başı Haftasının Son Günü
g = e - f
'İki Hafta Sonu tarih Arasında Geçen Tam Haftalara Ait Gün Sayısı
h = g / 7 'İki Hafta Sonu Tarih Arasında Geçen Hafta Sayısı
If h = 0 Then h = 52
.List((i - 1), 1) = h
.List((i - 1), 2) = b
a = (i - 1) + VBA.DateValue(TextBox1.Value)
'Dönem Sonu tarih
b = VBA.Weekday(Tarih, 2) 'Dönem Sonunun Hafta İçi Gün No
c = VBA.DateValue(TextBox1.Value)
'Dönem Başı Tarih
d = VBA.Weekday(c, 2) 'Dönem Başının Hafta İçi Gün No
e = (a + (7 - b))
'Dönem Sonu Haftasının Son Günü
f = (c + (7 - d))
'Dönem Başı Haftasının Son Günü
g = e - f 'İki Hafta Sonu tarih Arasında Geçen Tam Haftalara Ait Gün Sayısı
h = g / 7 'İki Hafta Sonu Tarih Arasında Geçen Hafta Sayısı
.List((i - 1), 0) = h + 1
DoEvents
End With
Next i
Label1.Caption = ListBox1.List(0, 1)
Label2.Caption = ListBox1.List((Adet - 1), 1)
a = VBA.DateValue(TextBox2.Value) 'Dönem Sonu tarih
b = VBA.Weekday(Tarih, 2)
'Dönem Sonunun Hafta İçi Gün No
c = VBA.DateValue(TextBox1.Value) 'Dönem Başı Tarih
d = VBA.Weekday(c, 2) 'Dönem Başının Hafta İçi Gün No
e = (a + (7 - b)) 'Dönem Sonu Haftasının Son Günü
f = (c + (7 - d)) 'Dönem Başı Haftasının Son Günü
g = e - f 'İki Hafta Sonu tarih Arasında Geçen Tam Haftalara Ait Gün Sayısı
h = g / 7
'İki Hafta Sonu Tarih Arasında Geçen Hafta Sayısı
Label3.Caption = h + 1
End If
End Sub

10 Ağustos 2005 Çarşamba

Ongoing Search



'Module1

Option Explicit
Dim i As Single, No As Double
Dim Hücre As Range, Sayfa As Worksheet
Dim Adres As String, Aranan As String, Bulunan As String, ÖncekiBulunan As String, Bilgi As String

Sub DevamEdenArama() '[Ongoing search]
On Error Resume Next
Set Sayfa = ThisWorkbook.Sheets(1)
No = Sayfa.Range("A65536").End(xlUp).Row
i = 1
Aranan = Sayfa.Range("E2").Value
Bulunan = ""
ÖncekiBulunan = ""
Bilgi = ""
Durak1:
Set Hücre = Nothing
Adres = "A" & i & ":A" & No
Set Hücre = Range(Adres).Find(Aranan, , , , , xlNext)
Bulunan = Hücre.Address
If Bulunan = ÖncekiBulunan Then
GoTo Durak2
Else
If i = 1 Then
Bilgi = Bulunan
i = Hücre.Row
Range(Bilgi).Select
Else
Bilgi = Bilgi & "," & Bulunan
i = Hücre.Row
Range(Bilgi).Select
End If
ÖncekiBulunan = Bulunan
End If
GoTo Durak1
Durak2:
MsgBox "Bulunan Kayıtlar:" & Bilgi & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbExclamation, "[PBİD®] Devam Eden Arama..."
End Sub

Blog Arşivi

Bu gadget'ta bir hata oluştu

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