Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

10 Ağustos 2007 Cuma

ActiveX Control (OCX) File Registration





'UserForm1

'A) VBProject References List

'Visual Basic For Application
'Microsoft Excel 11.0 Object Library
'OLE Automation
'Microsoft Office 11.0 Object Library
'Microsoft Forms 2.0 Object Library
'Microsoft Windows Common Control 6.0 (SP6)
'B) Addition Tools on UserForm1
'Frame1
'Frame1\Image1, Label1, Label2
'TreeView1, Listbox1,CommandButton1, CommandButton2
Option Explicit
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Any, ByVal wParam As Any, ByVal lParam As Any) As Long
Private Ekleyici As Long
Private i As Single
Private Dosyalama As Object, oDosya As Object, sDosya As Object
Private Klasör As Object, oKlasör As Object, sKlasör As Object, dKlasör As Object
Private No, Bilgi, Klasörlenen, Satır
Private Dal, DalAnahtarı, DalAdı, OkunanDosya, EklenenDosya, DosyaBilgisi() As String, Bulgu As String
Private ÖzelMenü, ÖzelKomut
Private Resimlik As New ImageList
Private Sub UserForm_Initialize()

On Error Resume Next
Me.Caption = "[PBİD®] ActiveX Control (OCX) File Registration"
Call EkranDüzenle
Call KlasörDüzeniKur
End Sub
Private Sub TreeView1_NodeClick(ByVal Node As MSComctlLib.Node)

If Node.Image = 1 Then
Call AğaçKur(Node.Key)
End If
End Sub
Sub KlasörDüzeniKur()

Set Dosyalama = VBA.CreateObject("Scripting.FileSystemObject")
For Each Klasör In Dosyalama.Drives
Bilgi = Klasör.DriveLetter & ":\"
If Bilgi = "K:\" Then
Exit For
Else
Set Dal = TreeView1.Nodes.Add(, , Bilgi, Bilgi, 1)
Dal.Expanded = True
AğaçKur (Bilgi)
End If
Next
End Sub
Sub AğaçKur(rKlasör As String)

Set Dosyalama = VBA.CreateObject("Scripting.FileSystemObject")
On Error GoTo Mevcut
Set oKlasör = Dosyalama.GetFolder(rKlasör)
Set sKlasör = oKlasör.subfolders
For Each dKlasör In sKlasör
Klasörlenen = dKlasör.ParentFolder
DalAnahtarı = dKlasör.Path
DalAdı = dKlasör.Name
Set Dal = TreeView1.Nodes.Add(Klasörlenen, 4, DalAnahtarı, DalAdı, 1)
Dal.Expanded = True
Next dKlasör
OkunanDosya = DosyaBilgisiGetir(rKlasör)
For EklenenDosya = 1 To UBound(OkunanDosya)
If OkunanDosya(EklenenDosya, 1) = "" Then
Else
Set Dal = TreeView1.Nodes.Add(OkunanDosya(EklenenDosya, 3), 4, OkunanDosya(EklenenDosya, 2), OkunanDosya(EklenenDosya, 1), 2)
Dal.Expanded = True
On Error Resume Next
If VBA.UCase(VBA.Right(OkunanDosya(EklenenDosya, 1), 3)) = "OCX" Then
If ListBox1.ListCount = 0 Then
ListBox1.AddItem OkunanDosya(EklenenDosya, 1)
No = ListBox1.ListCount
ListBox1.List(No - 1, 1) = OkunanDosya(EklenenDosya, 3)
Ekleyici = GetProcAddress(LoadLibrary(OkunanDosya(EklenenDosya, 2)), "DllRegisterServer")
If CallWindowProc(Ekleyici, ByVal 0&, ByVal 0&, ByVal 0&, ByVal 0&) = &H0 Then
ListBox1.List(No - 1, 2) = "Registrated"
Else
ListBox1.List(No - 1, 2) = "Un Registrated"
End If
Else
For i = 0 To (ListBox1.ListCount - 1)
Bulgu = ListBox1.List(i, 1) & "\" & ListBox1.List(i, 0)
If Bulgu = OkunanDosya(EklenenDosya, 2) Then GoTo Devam
Next i
ListBox1.AddItem OkunanDosya(EklenenDosya, 1)
No = ListBox1.ListCount
ListBox1.List(No - 1, 1) = OkunanDosya(EklenenDosya, 3)
Ekleyici = GetProcAddress(LoadLibrary(OkunanDosya(EklenenDosya, 2)), "DllRegisterServer")
If CallWindowProc(Ekleyici, ByVal 0&, ByVal 0&, ByVal 0&, ByVal 0&) = &H0 Then
ListBox1.List(No - 1, 2) = "Registrated"
Else
ListBox1.List(No - 1, 2) = "Un Registrated"
End If
End If
End If
On Error GoTo Mevcut
End If
Devam:
Next EklenenDosya
Mevcut:
End Sub
Function DosyaBilgisiGetir(rFolder As String)

Set Dosyalama = VBA.CreateObject("Scripting.FileSystemObject")
Set oKlasör = Dosyalama.GetFolder(rFolder)
Set oDosya = oKlasör.Files
ReDim DosyaBilgisi(oDosya.Count, 3)
No = 0
For Each sDosya In oDosya
No = No + 1
If sDosya.ParentFolder = rFolder And VBA.UCase(VBA.Right(sDosya.Name, 3)) = "OCX" Then
DosyaBilgisi(No, 1) = sDosya.Name
DosyaBilgisi(No, 2) = sDosya.Path
DosyaBilgisi(No, 3) = sDosya.ParentFolder
End If
Next
DosyaBilgisiGetir = DosyaBilgisi
End Function
Private Sub CommandButton1_Click() 'Registration

On Error Resume Next
No = ListBox1.ListIndex
Bulgu = ListBox1.List(No, 1) & "\" & ListBox1.List(No, 0)
If VBA.Dir(Bulgu) = Empty Then
MsgBox Bulgu & " bulunamadı, liste üzerinden seçiminizi kontrol ediniz!"
Else
Call KaydetmeSunucusu(Bulgu, True, No)
End If
End Sub
Private Sub CommandButton2_Click() 'Un Registration

On Error Resume Next
No = ListBox1.ListIndex
Bulgu = ListBox1.List(No, 1) & "\" & ListBox1.List(No, 0)
If VBA.Dir(Bulgu) = Empty Then
MsgBox Bulgu & " bulunamadı, liste üzerinden seçiminizi kontrol ediniz!"
Else
Call KaydetmeSunucusu(Bulgu, False, No)
End If
End Sub
Function KaydetmeSunucusu(BulguYolu As String, Kaydetmek As Boolean, No) 'Register Server

On Error Resume Next
If Kaydetmek = True Then
Ekleyici = GetProcAddress(LoadLibrary(BulguYolu), "DllRegisterServer")
If CallWindowProc(Ekleyici, ByVal 0&, ByVal 0&, ByVal 0&, ByVal 0&) = &H0 Then ListBox1.List(No, 2) = "Registration"
Else
Ekleyici = GetProcAddress(LoadLibrary(BulguYolu), "DllUnregisterServer")
If CallWindowProc(Ekleyici, ByVal 0&, ByVal 0&, ByVal 0&, ByVal 0&) = &H0 Then ListBox1.List(No, 2) = "Un Registration"
End If
FreeLibrary LoadLibrary(BulguYolu)
End Function
Sub EkranDüzenle()

On Error Resume Next
With Me
.Height = 372
.Width = 680
With Frame1
.Caption = ""
.Left = -1
.Top = -1
.Height = 30
.Width = Me.Width + 12
.Picture = LoadPicture("D:\Mustafa ULUSARAÇ\Blogspot\ZarifVİSTA.bmp")
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeStretch
With Image1
.Left = 1.5
.Top = 1.5
.Height = 24
.Width = 24
.BorderColor = vbBlue
.BackStyle = fmBackStyleTransparent
.Picture = LoadPicture("D:\Mustafa ULUSARAÇ\Blogspot\Örnekİkonlar\PBİD.ico")
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip
End With
With Label1
.Left = 1.5 + 24 + 3
.Top = 1.5
.Caption = "Mustafa ULUSARAÇ"
.BackStyle = fmBackStyleTransparent
.SpecialEffect = fmSpecialEffectFlat
.BorderStyle = fmBorderStyleNone
.Height = 12
.Width = 180
.Font.Bold = True
.ForeColor = vbBlue
End With
With Label2
.Left = 1.5 + 24 + 3
.Top = 13.5
.Caption = "01ulusarac@superonline.com"
.BackStyle = fmBackStyleTransparent
.SpecialEffect = fmSpecialEffectFlat
.BorderStyle = fmBorderStyleNone
.Height = 12
.Width = 180
.Font.Bold = True
.ForeColor = vbBlue
End With
End With
With Resimlik
Set ÖzelMenü = Application.CommandBars.Add("", msoBarPopup, , True)
Set ÖzelKomut = ÖzelMenü.Controls.Add(1, , , , True)
ÖzelKomut.FaceId = 6496
.ListImages.Add 1, "K1", ÖzelKomut.Picture
ÖzelKomut.FaceId = 2585 '7166
.ListImages.Add 2, "K2", ÖzelKomut.Picture
End With
With TreeView1
.ImageList = Resimlik
.Appearance = ccFlat
.BorderStyle = ccNone
.Indentation = 14
.LineStyle = tvwRootLines
.Top = 30
.Left = 0
.Height = Me.Height - .Top - 24
.Width = 240
End With
With ListBox1
.Top = TreeView1.Top
.Left = TreeView1.Left + TreeView1.Width
.Height = TreeView1.Height - Label1.Height - 12
.Width = Me.Width - .Left - 12
.ColumnCount = 3
.ColumnWidths = "120;240;60"
.SpecialEffect = fmSpecialEffectEtched
.BackColor = &H80000001
.ForeColor = &HFF00&
End With
With CommandButton1
.Left = ListBox1.Left
.Top = ListBox1.Top + ListBox1.Height + 6
.Height = 18
.Width = ListBox1.Width / 2
.Caption = "Registration"
End With
With CommandButton2
.Left = CommandButton1.Left + CommandButton1.Width
.Top = CommandButton1.Top
.Height = 18
.Width = CommandButton1.Width
.Caption = "Un Registration"
End With
End With
End Sub

'ThisWorkBook Module
Option Explicit
Private Sub Workbook_Open()

On Error Resume Next
UserForm1.Show 0
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