Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

10 Eylül 2012 Pazartesi

Create Excel Menus With The UserForm

'UserForm1

'A References List
'1) Name: VBA, Description: Visual Basic For Applications, FullPath: C:\Program Files (x86)\Common Files\Microsoft Shared\VBA\VBA6\VBE6.DLL
'2) Name: Excel, Description: Microsoft Excel 11.0 Object Library, FullPath: C:\Program Files (x86)\Microsoft Office\OFFICE11\EXCEL.EXE
'3) Name: stdole, Description: OLE Automation, FullPath: C:\Windows\SysWOW64\stdole2.tlb
'4) Name: Office, Description: Microsoft Office 11.0 Object Library, FullPath: C:\Program Files (x86)\Common Files\Microsoft Shared\OFFICE11\MSO.DLL
'5) Name: MSForms, Description: Microsoft Forms 2.0 Object Library, FullPath: C:\Windows\SysWOW64\FM20.DLL
'6) Name: MSComctlLib, Description: Microsoft Windows Common Controls 6.0 (SP6), FullPath: C:\Windows\SysWOW64\MSCOMCTL.OCX
'B Additional Tolls List
'1) Image1, Label1, label2
'2) TreeView1
'3) ComboBox1, Label3, Label4, Label5, Label6
Private i As Single
Private ii As Single
Private iii As Single
Private CB As CommandBar
Private CBC1 As CommandBarControl
Private CBC2 As CommandBarControl
Private CBC3 As CommandBarControl
Private cbID As CommandBar
Private cbcID As CommandBarControl
Private hType As Variant
Private hID As Variant
Private hAct1 As Variant
Private hKey1 As String
Private hTag1 As String
Private hAct2 As Variant
Private hKey2 As String
Private hTag2 As String
Private hAct3 As Variant
Private hKey3 As String
Private hTag3 As String
Private Sub UserForm_Initialize()
On Error Resume Next
Me.Caption = "[PBİD®] Create Excel Menus With The UserForm"
Call Ekran_Kur
Call CB_Kur
End Sub
Private Sub TreeView1_NodeClick(ByVal Node As MSComctlLib.Node)
On Error Resume Next
Label3.Picture = LoadPicture("")
hID = VBA.Val(VBA.Right(TreeView1.SelectedItem.Key, VBA.Len(TreeView1.SelectedItem.Key) - 1))
hType = VBA.Val(TreeView1.SelectedItem.Tag)
Label4.Caption = hID
Label6.Caption = hType
Set cbID = Application.CommandBars.Add("", msoBarPopup, , True)
Set cbcID = cbID.Controls.Add(hType, hID, , , True)
Label3.Picture = cbcID.Picture
cbID.ShowPopup
cbID.Delete
Set cbID = Nothing
Set cbcID = Nothing
End Sub
Private Sub ComboBox1_Change()
On Error Resume Next
Set CB = Application.CommandBars(ComboBox1.Value)
i = 0
With TreeView1
.Nodes.Clear
For Each hAct1 In CB.Controls
i = i + 1
Set CBC1 = CB.Controls(i)
hAct1 = CBC1.Caption
hKey1 = "K" & CBC1.ID
hTag1 = CBC1.Type
.Nodes.Add , , hKey1, hAct1
.Nodes(hKey1).Tag = hTag1
If CBC1.Type = 10 Then
ii = 0
For Each hAct2 In CBC1.Controls
ii = ii + 1
Set CBC2 = CBC1.Controls(ii)
hAct2 = CBC2.Caption
hKey2 = "K" & CBC2.ID
hTag2 = CBC2.Type
.Nodes.Add hKey1, 4, hKey2, hAct2
.Nodes(hKey2).Tag = hTag2
If CBC2.Type = 10 Then
iii = 0
For Each hAct3 In CBC2.Controls
iii = iii + 1
Set CBC3 = CBC2.Controls(iii)
hAct3 = CBC3.Caption
hKey3 = "K" & CBC3.ID
hTag3 = CBC3.Type
.Nodes.Add hKey2, 4, hKey3, hAct3
.Nodes(hKey3).Tag = hTag3
Next hAct3
End If
Next hAct2
End If
Next hAct1
For i = 1 To .Nodes.Count
If .Nodes(i).Children > 0 Then
.Nodes(i).Bold = True
.Nodes(i).Expanded = True
Else
.Nodes(i).Bold = False
.Nodes(i).Expanded = False
End If
.Nodes(i).ForeColor = &H808000
Next i
.Nodes(1).EnsureVisible
End With
End Sub
Private Sub Ekran_Kur()
On Error Resume Next
With Me
.BackColor = vbWhite
.Height = 284
.Width = 370
.Picture = Resim(URL1)
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = True
With Image1
.Top = 6
.Left = 6
.Height = 24
.Width = 24
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleSingle
.BorderColor = vbBlue
.Picture = Resim(URL2)
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = False
End With
With Label1
.Left = 36
.Top = 6
.Height = 12
.Width = 318
.Caption = "Mustafa ULUSARAÇ"
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.Font.Name = "Arial"
.ForeColor = vbBlue
End With
With Label2
.Left = 36
.Top = 18
.Height = 12
.Width = 318
.Caption = "01ulusarac@superonline.com"
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.Font.Name = "Arial"
.ForeColor = vbBlue
End With
With TreeView1
.Left = 6
.Top = 36
.Height = 198
.Width = 354
.Appearance = ccFlat
.LineStyle = tvwRootLines
End With
With ComboBox1
.Left = 6
.Top = 240
.Height = 18
.Width = 192
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.ForeColor = &H808000
End With
With Label3
.Left = 204
.Top = 240
.Height = 18
.Width = 36
.Caption = " ID"
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.ForeColor = &H808000
.PicturePosition = fmPicturePositionLeftCenter
End With
With Label4
.Left = 240
.Top = 240
.Height = 18
.Width = 42
.Caption = ""
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.ForeColor = &H808000
.TextAlign = fmTextAlignCenter
End With
With Label5
.Left = 282
.Top = 240
.Height = 18
.Width = 36
.Caption = " Type"
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.ForeColor = &H808000
End With
With Label6
.Left = 318
.Top = 240
.Height = 18
.Width = 42
.Caption = ""
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.ForeColor = &H808000
.TextAlign = fmTextAlignCenter
End With
End With
End Sub
Private Sub CB_Kur()
On Error Resume Next
For Each CB In Application.CommandBars
ComboBox1.AddItem CB.Name
Next CB
ComboBox1.ListIndex = 0
End Sub

'Module1

Option Explicit
Public Declare Function CLSIDFromString Lib "ole32" (ByVal lpstrCLSID As Long, lpCLSID As Any) As Long
Public Declare Function OleLoadPicturePath Lib "oleaut32" (ByVal szURLorPath As Long, ByVal punkCaller As Long, ByVal dwReserved As Long, ByVal clrReserved As OLE_COLOR, ByRef riid As Any, ByRef ppvRet As Any) As Long
Public IPic(15) As Byte
Public Const ClsID As Variant = "{7BF80980-BF32-101A-8BBB-00AA00300CAB}"
Public Const URL1 As String = "http://2.bp.blogspot.com/-G3KDFVP7V0Q/TcUhtYtMifI/AAAAAAAACw0/Ta6mFpFJtZ8/s1600/39.bmp"
Public Const URL2 As String = "http://2.bp.blogspot.com/_hsHTxo_5L8E/S78EbvJyhRI/AAAAAAAACS0/txbOQ1qubg8/s1600/PB%C4%B0D_jpg.jpg"
Public URL As String
Sub Form_Aç() 'Open UserForm
On Error Resume Next
UserForm1.Show 0
End Sub
Public Function Resim(URL) As Picture 'Picture load frome web address...
On Error Resume Next
CLSIDFromString StrPtr(ClsID), IPic(0)
OleLoadPicturePath StrPtr(URL), 0&, 0&, 0&, IPic(0), Resim
End Function
'Sub References_List()
'On Error Resume Next
'Dim Eleman, No
'No = 1
'For Each Eleman In ThisWorkbook.VBProject.References
'Sheets(1).Cells(No, 1) = No & ") Name: "
'Sheets(1).Cells(No, 2) = Eleman.Name
'Sheets(1).Cells(No, 3) = ", Description: "
'Sheets(1).Cells(No, 4) = Eleman.Description
'Sheets(1).Cells(No, 5) = ", FullPath: "
'Sheets(1).Cells(No, 6) = Eleman.FullPath
'No = No + 1
'Next Eleman
'End Sub

Hiç yorum yok:

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