Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

20 Kasım 2011 Pazar

GetSystemMenu Options For Excel, WorkBook And UserForm


'UserForm1

'A. Available 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
'B. Available Tools List
'1) Image1, Label1, Label2
'2) Label3, Label4, Label5, Label6, Label7, Label8
'3) ToggleButton1, ToggleButton2, ToggleButton3
'4) ToggleButton4, ToggleButton5, ToggleButton6
'5) ToggleButton7, ToggleButton8, ToggleButton9
Private i As Single
Private Const GWL_STYLE = -16&
Private Const SC_CLOSE = &HF060
Private Const MF_BYCOMMAND = &H0
Private Const WS_MAXIMIZEBOX = &H10000
Private Const WS_MINIMIZEBOX = &H20000
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function 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 FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal myHwnd As Long) As Long
Private Declare Function GetSystemMenu Lib "user32" (ByVal myHwnd As Long, ByVal bRevert As Long) As Long
Private Declare Function DeleteMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Private hMenu As Long
Private hWndStyle As Long
Private UFhWnd As Long
Private XLhWnd As Long
Private WBhWnd As Long
Private Sub UserForm_Initialize()
On Error Resume Next
Me.Caption = "[PBİD®] GetSystemMenu Options For Excel, WorkBook And UserForm"
Call Ekran_Duzenle
Call Find_hWnd
Call Open_Buttons
End Sub
Private Sub UserForm_Terminate()
On Error Resume Next
Call Open_Buttons
End Sub
Private Sub ToggleButton1_Click()
On Error Resume Next
With Me.ToggleButton1
If .Value Then
Call AddMinButton(UFhWnd)
.Caption = "ON"
.ForeColor = VBA.ColorConstants.vbBlue
Else
Call DelMinButton(UFhWnd)
.Caption = "OFF"
.ForeColor = VBA.ColorConstants.vbRed
End If
End With
End Sub
Private Sub ToggleButton2_Click()
On Error Resume Next
With Me.ToggleButton2
If .Value Then
Call AddMaxButton(UFhWnd)
.Caption = "ON"
.ForeColor = VBA.ColorConstants.vbBlue
Else
Call DelMaxButton(UFhWnd)
.Caption = "OFF"
.ForeColor = VBA.ColorConstants.vbRed
End If
End With
End Sub
Private Sub ToggleButton3_Click()
On Error Resume Next
With Me.ToggleButton3
If .Value Then
Call AddCloseButton(UFhWnd)
.Caption = "ON"
.ForeColor = VBA.ColorConstants.vbBlue
Else
Call DelCloseButton(UFhWnd)
.Caption = "OFF"
.ForeColor = VBA.ColorConstants.vbRed
End If
End With
End Sub
Private Sub ToggleButton4_Click()
On Error Resume Next
With Me.ToggleButton4
If .Value Then
Call AddMinButton(WBhWnd)
.Caption = "ON"
.ForeColor = VBA.ColorConstants.vbBlue
Else
Call DelMinButton(WBhWnd)
.Caption = "OFF"
.ForeColor = VBA.ColorConstants.vbRed
End If
End With
With Application.Windows(ThisWorkbook.Name)
.WindowState = xlMaximized
.WindowState = xlNormal
End With
End Sub
Private Sub ToggleButton5_Click()
On Error Resume Next
With Me.ToggleButton5
If .Value Then
Call AddMaxButton(WBhWnd)
.Caption = "ON"
.ForeColor = VBA.ColorConstants.vbBlue
Else
Call DelMaxButton(WBhWnd)
.Caption = "OFF"
.ForeColor = VBA.ColorConstants.vbRed
End If
End With
With Application.Windows(ThisWorkbook.Name)
.WindowState = xlMaximized
.WindowState = xlNormal
End With
End Sub
Private Sub ToggleButton6_Click()
On Error Resume Next
With Me.ToggleButton6
If .Value Then
Call AddCloseButton(WBhWnd)
.Caption = "ON"
.ForeColor = VBA.ColorConstants.vbBlue
Else
Call DelCloseButton(WBhWnd)
.Caption = "OFF"
.ForeColor = VBA.ColorConstants.vbRed
End If
End With
With Application.Windows(ThisWorkbook.Name)
.WindowState = xlMaximized
.WindowState = xlNormal
End With
End Sub
Private Sub ToggleButton7_Click()
On Error Resume Next
With Me.ToggleButton7
If .Value Then
Call AddMinButton(XLhWnd)
.Caption = "ON"
.ForeColor = VBA.ColorConstants.vbBlue
Else
Call DelMinButton(XLhWnd)
.Caption = "OFF"
.ForeColor = VBA.ColorConstants.vbRed
End If
End With
End Sub
Private Sub ToggleButton8_Click()
On Error Resume Next
With Me.ToggleButton8
If .Value Then
Call AddMaxButton(XLhWnd)
.Caption = "ON"
.ForeColor = VBA.ColorConstants.vbBlue
Else
Call DelMaxButton(XLhWnd)
.Caption = "OFF"
.ForeColor = VBA.ColorConstants.vbRed
End If
End With
End Sub
Private Sub ToggleButton9_Click()
On Error Resume Next
With Me.ToggleButton9
If .Value Then
Call AddCloseButton(XLhWnd)
.Caption = "ON"
.ForeColor = VBA.ColorConstants.vbBlue
Else
Call DelCloseButton(XLhWnd)
.Caption = "OFF"
.ForeColor = VBA.ColorConstants.vbRed
End If
End With
End Sub
Private Sub Find_hWnd()
On Error Resume Next
UFhWnd = FindWindow(vbNullString, UserForm1.Caption)
XLhWnd = FindWindow("XLMAIN", Application.Caption)
WBhWnd = FindWindowEx(XLhWnd, 0&, "XLDESK", vbNullString)
WBhWnd = FindWindowEx(WBhWnd, 0&, "EXCEL7", vbNullString)
End Sub
Private Sub AddMinButton(ByVal hWndTipi As Long)
On Error Resume Next
hWndStyle = GetWindowLong(hWndTipi, GWL_STYLE)
hWndStyle = hWndStyle Or WS_MINIMIZEBOX
SetWindowLong hWndTipi, GWL_STYLE, hWndStyle
DrawMenuBar hWndTipi
End Sub
Private Sub DelMinButton(ByVal hWndTipi As Long)
On Error Resume Next
hWndStyle = GetWindowLong(hWndTipi, GWL_STYLE)
hWndStyle = hWndStyle And Not WS_MINIMIZEBOX
SetWindowLong hWndTipi, GWL_STYLE, hWndStyle
DrawMenuBar hWndTipi
End Sub
Private Sub AddMaxButton(ByVal hWndTipi As Long)
On Error Resume Next
hWndStyle = GetWindowLong(hWndTipi, GWL_STYLE)
hWndStyle = hWndStyle Or WS_MAXIMIZEBOX
SetWindowLong hWndTipi, GWL_STYLE, hWndStyle
DrawMenuBar hWndTipi
End Sub
Private Sub DelMaxButton(ByVal hWndTipi As Long)
On Error Resume Next
hWndStyle = GetWindowLong(hWndTipi, GWL_STYLE)
hWndStyle = hWndStyle And Not WS_MAXIMIZEBOX
SetWindowLong hWndTipi, GWL_STYLE, hWndStyle
DrawMenuBar hWndTipi
End Sub
Private Sub AddCloseButton(ByVal hWndTipi As Long)
On Error Resume Next
hMenu = GetSystemMenu(hWndTipi, 1&)
DrawMenuBar hWndTipi
End Sub
Private Sub DelCloseButton(ByVal hWndTipi As Long)
On Error Resume Next
hMenu = GetSystemMenu(hWndTipi, 0&)
DeleteMenu hMenu, SC_CLOSE, MF_BYCOMMAND
DrawMenuBar hWndTipi
End Sub
Private Sub Open_Buttons()
On Error Resume Next
For i = 1 To 9
Me("ToggleButton" & i).Value = True
Next i
Application.WindowState = xlMaximized
Windows(ThisWorkbook.Name).WindowState = xlMaximized
End Sub
Private Sub Ekran_Duzenle()
On Error Resume Next
With Me
.BackColor = vbWhite
.Height = 160
.Width = 258
.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 Label3
.Left = 6
.Top = 60
.Height = 24
.Width = 60
.Caption = " UserForm"
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.Font.Name = "Arial"
.ForeColor = &H404000
.TextAlign = fmTextAlignLeft
End With
With Label4
.Left = 6
.Top = 84
.Height = 24
.Width = 60
.Caption = " WorkBook"
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.Font.Name = "Arial"
.ForeColor = &H404000
.TextAlign = fmTextAlignLeft
End With
With Label5
.Left = 6
.Top = 108
.Height = 24
.Width = 60
.Caption = " Excel"
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.Font.Name = "Arial"
.ForeColor = &H404000
.TextAlign = fmTextAlignLeft
End With
With Label6
.Left = 66
.Top = 36
.Height = 24
.Width = 60
.Caption = "Minumum"
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.Font.Name = "Arial"
.ForeColor = &H404000
.TextAlign = fmTextAlignCenter
End With
With ToggleButton1
.Left = 66
.Top = 60
.Height = 24
.Width = 60
.Caption = ""
.Alignment = fmAlignmentLeft
.BackStyle = fmBackStyleTransparent
.Enabled = True
.SpecialEffect = fmButtonEffectFlat
.TextAlign = fmTextAlignCenter
.WordWrap = False
End With
With ToggleButton4
.Left = 66
.Top = 84
.Height = 24
.Width = 60
.Caption = ""
.Alignment = fmAlignmentLeft
.BackStyle = fmBackStyleTransparent
.Enabled = True
.SpecialEffect = fmButtonEffectFlat
.TextAlign = fmTextAlignCenter
.WordWrap = False
End With
With ToggleButton7
.Left = 66
.Top = 108
.Height = 24
.Width = 60
.Caption = ""
.Alignment = fmAlignmentLeft
.BackStyle = fmBackStyleTransparent
.Enabled = True
.SpecialEffect = fmButtonEffectFlat
.TextAlign = fmTextAlignCenter
.WordWrap = False
End With
With Label7
.Left = 126
.Top = 36
.Height = 24
.Width = 60
.Caption = "Maximum"
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.Font.Name = "Arial"
.ForeColor = &H404000
.TextAlign = fmTextAlignCenter
End With
With ToggleButton2
.Left = 126
.Top = 60
.Height = 24
.Width = 60
.Caption = ""
.Alignment = fmAlignmentLeft
.BackStyle = fmBackStyleTransparent
.Enabled = True
.SpecialEffect = fmButtonEffectFlat
.TextAlign = fmTextAlignCenter
.WordWrap = False
End With
With ToggleButton5
.Left = 126
.Top = 84
.Height = 24
.Width = 60
.Caption = ""
.Alignment = fmAlignmentLeft
.BackStyle = fmBackStyleTransparent
.Enabled = True
.SpecialEffect = fmButtonEffectFlat
.TextAlign = fmTextAlignCenter
.WordWrap = False
End With
With ToggleButton8
.Left = 126
.Top = 108
.Height = 24
.Width = 60
.Caption = ""
.Alignment = fmAlignmentLeft
.BackStyle = fmBackStyleTransparent
.Enabled = True
.SpecialEffect = fmButtonEffectFlat
.TextAlign = fmTextAlignCenter
.WordWrap = False
End With
With Label8
.Left = 186
.Top = 36
.Height = 24
.Width = 60
.Caption = "Close"
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.Font.Name = "Arial"
.ForeColor = &H404000
.TextAlign = fmTextAlignCenter
End With
With ToggleButton3
.Left = 186
.Top = 60
.Height = 24
.Width = 60
.Caption = ""
.Alignment = fmAlignmentLeft
.BackStyle = fmBackStyleTransparent
.Enabled = True
.SpecialEffect = fmButtonEffectFlat
.TextAlign = fmTextAlignCenter
.WordWrap = False
End With
With ToggleButton6
.Left = 186
.Top = 84
.Height = 24
.Width = 60
.Caption = ""
.Alignment = fmAlignmentLeft
.BackStyle = fmBackStyleTransparent
.Enabled = True
.SpecialEffect = fmButtonEffectFlat
.TextAlign = fmTextAlignCenter
.WordWrap = False
End With
With ToggleButton9
.Left = 186
.Top = 108
.Height = 24
.Width = 60
.Caption = ""
.Alignment = fmAlignmentLeft
.BackStyle = fmBackStyleTransparent
.Enabled = True
.SpecialEffect = fmButtonEffectFlat
.TextAlign = fmTextAlignCenter
.WordWrap = False
End With
End With
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

10 Kasım 2011 Perşembe

Clipboard Functions

'UserForm1


'A. Available 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
'B. Available Tools List
'1) İmage1, Label1, Label2
'2) ListBox1
Option Explicit
Private i As Integer
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Veriler As GUID
Private Type uPicDesc
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type
Private Resimler As uPicDesc
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Private OC As Long
Private OCPI As Long
Private hAvail As Long
Private hPtr As Long
Private hPal As Long
Private hCopy As Long
Private lType As Long
Private IPic As IPicture
Private Sub UserForm_Initialize()
On Error Resume Next
Me.Caption = "[PBİD®] Clipboard Functions"
Call Ekran_Duzenle
Call Shape_Create
End Sub
Private Sub Listbox1_Click()
On Error Resume Next
ActiveSheet.Shapes(ListBox1).Copy
Me.Picture = Get_Picture
End Sub
Function Get_Picture(Optional lXlPicType As Long = xlPicture) As IPicture
On Error GoTo Hata
lType = IIf(lXlPicType = xlBitmap, 2, 14)
hAvail = IsClipboardFormatAvailable(lType)
If hAvail <> 0 Then
OC = OpenClipboard(0&)
If OC > 0 Then
hPtr = GetClipboardData(lType)
If lType = 2 Then
hCopy = CopyImage(hPtr, 0, 0, 0, &H4)
Else
hCopy = CopyEnhMetaFile(hPtr, vbNullString)
End If
OC = CloseClipboard
If hPtr <> 0 Then Set Get_Picture = Create_Picture(hCopy, 0, lType)
End If
End If
Exit Function
Hata:
MsgBox VBA.Err.Description, vbCritical, "[PBİD®]"
End Function
Private Function Create_Picture(ByVal hPic As Long, ByVal hPal As Long, ByVal lType) As IPicture
On Error GoTo Hata
With Veriler
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
With Resimler
.Size = Len(Resimler)
.Type = IIf(lType = 2, 1, 4)
.hPic = hPic
.hPal = IIf(lType = 2, hPal, 0)
End With
OCPI = OleCreatePictureIndirect(Resimler, Veriler, True, IPic)
Set Create_Picture = IPic
Exit Function
Hata:
MsgBox VBA.Err.Description, vbCritical, "[PBİD®]"
End Function
Private Sub Ekran_Duzenle()
On Error Resume Next
With Me
.BackColor = vbWhite
.Height = 356
.Width = 408
.Picture = Nothing
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = False
.SpecialEffect = fmSpecialEffectFlat
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 = 270
.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 = 270
.Caption = "01ulusarac@superonline.com"
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.Font.Name = "Arial"
.ForeColor = vbBlue
End With
With ListBox1
.Left = 312
.Top = 6
.Height = 24
.Width = 86
.ColumnCount = 1
.ColumnWidths = "74"
.SpecialEffect = fmSpecialEffectEtched
End With
End With
End Sub
Private Sub Shape_Create()
On Error Resume Next
ActiveSheet.DrawingObjects.Select
Selection.Delete
Range("A1").Select: ActiveSheet.Shapes.AddShape(msoShapeRectangularCallout, 15#, 5.25, 64.5, 31.5).Select
Range("C1").Select: ActiveSheet.Shapes.AddShape(msoShapeFlowchartMultidocument, 97.5, 3#, 91.5, 41.25).Select
Range("E1").Select: ActiveSheet.Shapes.AddShape(msoShapeNoSymbol, 197.25, 3#, 42#, 43.5).Select
Range("A6").Select: ActiveSheet.Shapes.AddShape(msoShapeSun, 5.25, 50.25, 66.75, 73.5).Select
Range("C6").Select: ActiveSheet.Shapes.AddShape(msoShapeDownRibbon, 95.25, 62.25, 142.5, 60#).Select
Range("A12").Select: ActiveSheet.Shapes.AddShape(msoShapeRectangle, 0.75, 140.25, 84.75, 12.75).Select
With Selection.ShapeRange
With .Line
.Weight = 0.75
.DashStyle = msoLineSolid
.Style = msoLineSingle
.Transparency = 0#
.Visible = msoTrue
.ForeColor.SchemeColor = 64
.BackColor.RGB = RGB(255, 255, 255)
End With
With .Fill
.Transparency = 0#
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 0, 0)
.BackColor.SchemeColor = 40
.Patterned msoPattern50Percent
End With
End With
Range("C14").Select: ActiveSheet.Shapes.AddShape(msoShapeRectangle, 96.75, 167.25, 95.25, 10.5).Select
With Selection.ShapeRange
With .Line
.Weight = 0.75
.DashStyle = msoLineSolid
.Style = msoLineSingle
.Transparency = 0#
.Visible = msoTrue
.ForeColor.SchemeColor = 64
.BackColor.RGB = RGB(255, 255, 255)
End With
With .Fill
.Transparency = 0#
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 0, 0)
.BackColor.SchemeColor = 40
.Patterned msoPattern50Percent
End With
End With
ActiveSheet.Shapes.AddConnector(msoConnectorElbow, 85.5, 147#, 60.75, 20).Select
Range("A16").Select: ActiveSheet.Shapes.AddShape(msoShapeStripedRightArrow, 6#, 192.75, 235.5, 26.25).Select
With Selection.ShapeRange
With .Line
.Weight = 0.75
.DashStyle = msoLineSolid
.Style = msoLineSingle
.Transparency = 0#
.Visible = msoTrue
.ForeColor.SchemeColor = 64
.BackColor.RGB = RGB(255, 255, 255)
End With
With .Fill
.Transparency = 0#
.Visible = msoTrue
.ForeColor.SchemeColor = 65
.OneColorGradient msoGradientVertical, 1, 0.23
End With
End With
For i = 1 To ActiveSheet.Shapes.Count
ListBox1.AddItem ActiveSheet.Shapes(i).Name
Next i
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ç()
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

1 Kasım 2011 Salı

Add Classic Excel Menu

'Module1

'Available References List
'1) Name: VBA, Description: Visual Basic For Applications
'2) Name: Excel, Description: Microsoft Excel 14.0 Object Library
'3) Name: stdole, Description: OLE Automation
'4) Name: Office, Description: Microsoft Office 14.0 Object Library



Sub Add_Excel2003_Menus_ToolBars()
    On Error Resume Next
    Dim i As Integer
    Dim CB As CommandBar
    Dim CBC As CommandBarControl
    Const Menu2003 As String = "Excel 2003 Menu"
    Const ToolBar2003 As String = "Excel 2003 Toolbar"
    With Application
        .CommandBars(Menu2003).Delete
        .CommandBars(ToolBar2003).Delete
        Set CB = CommandBars.Add(Menu2003, , , True)
    End With
    With CB
        .Visible = True
        For i = 1 To 10
            Set CBC = .Controls.Add(Type:=msoControlPopup, ID:=30001 + i)
        Next i
        Set CBC = .Controls.Add(Type:=msoControlPopup, ID:=30022) 'Chart
        Set CBC = .Controls.Add(Type:=msoControlPopup, ID:=30177) 'AutoShapes
    End With
    Set CB = CommandBars.Add(ToolBar2003, , , True)
    With CB
        .Visible = True
        With .Controls
            Set CBC = .Add(Type:=msoControlButton, ID:=2520) 'New
            Set CBC = .Add(Type:=msoControlButton, ID:=23) 'Open
            Set CBC = .Add(Type:=msoControlButton, ID:=3) 'Save
            Set CBC = .Add(Type:=msoControlButton, ID:=4) 'Print
            Set CBC = .Add(Type:=msoControlButton, ID:=109) 'Print Preview
            Set CBC = .Add(Type:=msoControlButton, ID:=2) 'Spelling
            Set CBC = .Add(Type:=msoControlButton, ID:=21) 'Cut
            Set CBC = .Add(Type:=msoControlButton, ID:=19) 'Copy
            Set CBC = .Add(Type:=msoControlButton, ID:=22) 'Paste
            Set CBC = .Add(Type:=msoControlButton, ID:=108) 'Format Painter
            Set CBC = .Add(Type:=msoControlButton, ID:=210) 'Sort Ascending
            Set CBC = .Add(Type:=msoControlButton, ID:=211) 'Sort Descending
            Set CBC = .Add(Type:=msoControlButton, ID:=984) 'Help
            Set CBC = .Add(Type:=msoControlComboBox, ID:=1728) 'Font
            Set CBC = .Add(Type:=msoControlComboBox, ID:=1731) 'Font Size
            Set CBC = .Add(Type:=msoControlButton, ID:=113) 'Bold
            Set CBC = .Add(Type:=msoControlButton, ID:=114) 'Italic
            Set CBC = .Add(Type:=msoControlButton, ID:=115) 'Underline
            Set CBC = .Add(Type:=msoControlButton, ID:=120) 'Align Left
            Set CBC = .Add(Type:=msoControlButton, ID:=122) 'Center
            Set CBC = .Add(Type:=msoControlButton, ID:=121) 'Align Right
            Set CBC = .Add(Type:=msoControlButton, ID:=402) 'Merge and Center
            Set CBC = .Add(Type:=msoControlButton, ID:=395) 'Accounting Number Format
            Set CBC = .Add(Type:=msoControlButton, ID:=396) 'Percent Style
            Set CBC = .Add(Type:=msoControlButton, ID:=397) 'Comma Style
            Set CBC = .Add(Type:=msoControlButton, ID:=398) 'Increase Decimal
            Set CBC = .Add(Type:=msoControlButton, ID:=399) 'Decrease Decimal
            Set CBC = .Add(Type:=msoControlButton, ID:=3162) 'Decrease Indent
            Set CBC = .Add(Type:=msoControlButton, ID:=3161) 'Increase Indent
        End With
    End With
    Set CB = Nothing
    Set CBC = Nothing
    On Error GoTo 0
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