Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

31 Mart 2010 Çarşamba

UserForm Skins in VBA




'UserForm1

'A) Windows XP® Office 2003® Normal Referance List
    'Name: VBA , Description: Visual Basic For Applications 

    'Name: Excel , Description: Microsoft Excel 11.0 Object Library 
    'Name: stdole , Description: OLE Automation 
    'Name: Office , Description: Microsoft Office 11.0 Object Library
    'Name: MSForms , Description: Microsoft Forms 2.0 Object Library 
    'Name: MSComctlLib , Description: Microsoft Windows Common Controls 6.0 (SP6) 
    'Name: ACTIVESKINLib , Description: ActiveSkin 4.0 Type Library
'B) Additional Controls
    'Alt + F11; Microsoft Visual Basic VBE Editor
    'Tools\Additional Controls\ActiveSkin Control= OK
    'Skin1 Object to move on UserForm1 from ToolBox
'C) UserForm1'e Eklenen Araçlar (Add Tools)
    'ComboBox1
    'Skin1
'D) Macro Security Options
    'Araçlar [Tools] \ Makro [Macro] \ Güvenlik [Security] \ Güvenlik Düzeyi [Security Level]= Düşük [Low]
    'Araçlar [Tools] \ Makro [Macro] \ Güvenlik [Security] \ Güvenilen Yayımcılar [Trusted Publishers] \ Tüm yüklü eklentilere ve şablonlara güven [Trust all installed add-ins and templates]= OK
    'Araçlar [Tools] \ Makro [Macro] \ Güvenlik [Security] \ Güvenilen Yayımcılar [Trusted Publishers] \ Visual Basic Projesine erişime güven [Trust access to Visual Basic project]= OK
'E) Download Free *.skn Files Web Source
    'http://www.recursosvisualbasic.com.ar/htm/ocx-componentes-activex-dll/zip/207-skins-morpheus.zip

Option Explicit
Private No As Double
Private FSO As Object, Klasör As Object, Dosya As Object
Private SeçilenDosya As String
Private Const Hwnd As Long = &H0
Private Sub UserForm_Initialize()
    On Error Resume Next
    Application.Visible = False
    With Me
        .Caption = "[PBİD®]UserForm Skin"
        .Height = 226
        .Width = 358
    End With
    With ComboBox1
        .Left = 6
        .Top = 6
        .Height = 18
        .Width = 114
    End With
    Call SkinDosyaListele
End Sub
Private Sub UserForm_Terminate()

    On Error Resume Next
    Skin1.Empty
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)

    On Error Resume Next
    Application.Visible = True
End Sub
Private Sub ComboBox1_Change()

    On Error Resume Next
    SeçilenDosya = ComboBox1.List(ComboBox1.ListIndex, 1)
    With Skin1
        .LoadSkin SeçilenDosya
        .ApplySkin Hwnd
        .ZOrder 1
    End With
    DoEvents
End Sub
Sub SkinDosyaListele()

    On Error Resume Next
    No = 0
    Set FSO = VBA.CreateObject("Scripting.FileSystemObject")
    Set Klasör = FSO.GetFolder("C:\Documents and Settings\PC\Belgelerim\Mustafa ULUSARAÇ\Skins\")
    For Each Dosya In Klasör.Files
        ComboBox1.AddItem Dosya.Name
        ComboBox1.List(No, 1) = Dosya
        No = No + 1
    Next Dosya
End Sub

20 Mart 2010 Cumartesi

Associates a ProgID with a CLSID (GUID Number)



'UserForm1


'A) Windows XP® Office 2003® Normal Referance List

'Visual Basic For Aplication
'Microsoft Excel 11.0 Object Library
'OLE Automation
'Microsoft Office 11.0 Object Library
'Microsoft Forms 2.0 Object Library

'B) UserForm1'e Eklenen Araçlar (Add Tools)
'Frame1
'Frame1\Image1, Label1, Label2
'Image2
Option Explicit
Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpstrCLSID As Long, lpCLSID As Any) As Long
Private 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
Private IPic(15) As Byte
Private Const ClsID As Variant = "{7BF80980-BF32-101A-8BBB-00AA00300CAB}"
'It may take a few seconds, please wait.

Private Const URL1 As String = "http://1.bp.blogspot.com/_hsHTxo_5L8E/S7qBVjh2ifI/AAAAAAAACRc/gcQP-MPAaW8/s1600/Bant.JPG" 'Microsoft Office Excel® Kod Kılavuzu
Private Const URL2 As String = "http://nachbelichtet.com/wp-content/uploads/2008/01/TAPFS.jpg"
'Pink Floyd Concert


Private Sub UserForm_Initialize()
On Error Resume Next
Me.Caption = "[PBİD®] Associates a ProgID with a CLSID (GUID Number)"
Call EkranDüzenle
End Sub
Private Function Resim(URL) As Picture

On Error Resume Next
CLSIDFromString StrPtr(ClsID), IPic(0)
OleLoadPicturePath StrPtr(URL), 0&, 0&, 0&, IPic(0), Resim
End Function
Private Sub EkranDüzenle()

On Error Resume Next
With Me
.Height = 360
.Width = 456
.BackColor = vbWhite
With Frame1
.Caption = ""
.Top = 0
.Left = 0
.Height = 36
.Width = Me.InsideWidth
.Picture = Resim(URL1)
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeStretch
.PictureTiling = False
.SpecialEffect = fmSpecialEffectFlat
.BackColor = vbWhite
With Image1
.BackStyle = fmBackStyleTransparent
.BorderColor = &HFF0000
.BorderStyle = fmBorderStyleSingle
.Top = 6
.Left = 6
.Height = 24
.Width = 24
.Picture = LoadPicture("C:\Documents and Settings\ULUSARAÇ\Belgelerim\Mustafa ULUSARAÇ\PBİD.ico")
End With
With Label1
.Caption = " " & "Mustafa ULUSARAÇ"
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.Left = 30
.Top = 6
.Height = 12
.Width = 198
.Font.Bold = True
.ForeColor = &HFF0000
End With
With Label2
.Caption = " " & "01ulusarac@superonline.com"
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.Left = 30
.Top = 18
.Height = 12
.Width = 198
.Font.Bold = True
.ForeColor = &HFF0000
End With
End With
With Image2
.Left = 0
.Top = 30
.Height = Me.InsideHeight - 30
.Width = Me.InsideWidth
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeStretch
.PictureTiling = False
.Picture = Resim(URL2)
.SpecialEffect = fmSpecialEffectFlat
End With
End With
End Sub

12 Mart 2010 Cuma

System Error Message Text


'UserForm1

'A) Windows XP® Office 2003® Normal Referance List

'Visual Basic For Aplication
'Microsoft Forms 2.0 Object Library
'Microsoft Excel 11.0 Object Library
'OLE Automation
'Microsoft Office 11.0 Object Library
'Microsoft Common Controls 6.0 (SP6)

'B) UserForm1'e Eklenen Araçlar (Add Tools)

'Frame1
'Frame1\Image1, Label1, Label2
'ListView1

Option Explicit
Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, ByVal lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, ByRef Arguments As Long) As Long
Private No As Long, Tip As Long
Private HataMetni As String
Private i As Single
Private Albüm As New ImageList
Private Sub UserForm_Initialize()

On Error Resume Next
Me.Caption = "[PBİD®] System Error Message Text"
Call EkranDüzenle
Call HataMesajListesi

End Sub
Private Sub HataMesajListesi()

On Error Resume Next
i = 1
For No = 1 To 100000

If HataBildirSistemi(No) <> "" Then

ListView1.ListItems.Add i, "Key" & No, No, "Im1", "Im2"
ListView1.ListItems(i).ListSubItems.Add 1, "Key1" & No, No
ListView1.ListItems(i).ListSubItems.Add 2, "Key2" & No, HataBildirSistemi(No)
i = i + 1

End If

Next No

End Sub
Private Function HataBildirSistemi(HataNo As Long) As String

On Error Resume Next
HataMetni = VBA.String$(&HA0, VBA.vbNullChar)
Tip = FormatMessage(dwFlags:=&H1000 Or &H200, lpSource:=0&, dwMessageId:=HataNo, dwLanguageId:=0&, lpBuffer:=HataMetni, nSize:=&HA0, Arguments:=0&)
If Tip = 0& Then HataBildirSistemi = VBA.CStr(VBA.Err.LastDllError)
HataMetni = VBA.Left$(HataMetni, Tip)
HataBildirSistemi = VBA.Replace(HataMetni, VBA.vbCrLf, "", 1, 1, vbBinaryCompare)

End Function
Private Sub EkranDüzenle()

On Error Resume Next
With Me

.Height = 276
.Width = 480
.BackColor = vbWhite
With Albüm

.ListImages.Clear
.ImageHeight = 16
.ImageWidth = 16
.ListImages.Add , "Im1", LoadPicture("C:\Program Files\Microsoft Office\OFFICE11\FORMS\1055\POSTL.ico")
.ListImages.Add , "Im2", LoadPicture("C:\Program Files\Microsoft Office\OFFICE11\FORMS\1055\NOTEL.ico")
.ListImages.Add , "Im3", LoadPicture("C:\Program Files\Microsoft Office\OFFICE11\FORMS\1055\RESENDL.ico")

End With
With Frame1

.Caption = ""
.Top = -1
.Left = -1
.Height = 30
.Width = Me.Width + 12
.Picture = LoadPicture("D:\Mustafa ULUSARAÇ\BLOGSPOT\zarifVİSTA.bmp")
.PictureAlignment = fmPictureAlignmentTopLeft
.PictureSizeMode = fmPictureSizeModeZoom
.PictureTiling = False
.SpecialEffect = fmSpecialEffectFlat
.BackColor = vbWhite
With Image1

.BackStyle = fmBackStyleTransparent
.BorderColor = &HFF0000
.BorderStyle = fmBorderStyleSingle
.Top = 6
.Left = 6
.Height = 24
.Width = 24
.Picture = LoadPicture("D:\Mustafa ULUSARAÇ\BLOGSPOT\Örnekİkonlar\PBİD.ico")

End With
With Label1

.Caption = " " & "Mustafa ULUSARAÇ"
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.Left = 30
.Top = 6
.Height = 12
.Width = 198
.Font.Bold = True
.ForeColor = &HFF0000

End With
With Label2

.Caption = " " & "01ulusarac@superonline.com"
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.Left = 30
.Top = 18
.Height = 12
.Width = 198
.Font.Bold = True
.ForeColor = &HFF0000

End With

End With
With ListView1

.Left = 6
.Top = 36
.Height = Me.InsideHeight - 30 - 12
.Width = Me.InsideWidth - 6 - 6
Set .SmallIcons = Albüm
Set .Icons = Albüm
.FullRowSelect = True
.Gridlines = True
.HideColumnHeaders = False
.MultiSelect = False
.TextBackground = lvwOpaque
.View = lvwReport
.Appearance = cc3D
.BorderStyle = ccNone
.FlatScrollBar = False
.LabelEdit = lvwManual
.BackColor = vbWhite
.ColumnHeaders.Add 1, "Bas1", "No", 48, 0
.ColumnHeaders.Add 2, "Bas2", "Error ID", 48, 0
.ColumnHeaders.Add 3, "Bas3", "System Error Message Text", 360, 0

End With

End With

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