Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

20 Aralık 2012 Perşembe

MS Office Excel® workbook information by the ADODB.Connection


'UserForm1
 
'A. Available References List
     '1) Name: VBA, Description: Visual Basic For Applications, FullPath: C:\PROGRA~2\COMMON~1\MICROS~1\VBA\VBA7\VBE7.DLL
     '2) Name: Excel, Description: Microsoft Excel 14.0 Object Library, FullPath: C:\Program Files (x86)\Microsoft Office\Office14\EXCEL.EXE
     '3) Name: stdole, Description: OLE Automation, FullPath: C:\Windows\SysWOW64\stdole2.tlb
     '4) Name: Office, Description: Microsoft Office 14.0 Object Library, FullPath: C:\Program Files (x86)\Common Files\Microsoft Shared\OFFICE14\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) CommandButton1, Label3, Label4, Label5
     '3) ListBox1, Image2, ListBox2
Option Explicit
Dim i As Long
Dim ii As Long
Dim Bilgi As Variant
Dim hCat As Object
Dim hCon As Object
Dim hRec As Object
Dim hPage As Object
Dim hRow As Integer
Dim hFile As String
Dim hPath As String
Dim hName As String
Dim hSayfa As String
Dim hAdres As String
Dim hYol As String
Dim Bellek
Dim Eleman As Worksheet
Private Sub UserForm_Initialize()
     On Error Resume Next
     Me.Caption = "[PBİD®] MS Office Excel® workbook information by the ADODB.Connection"
     Call Ekran_Kur
End Sub
Private Sub UserForm_Terminate()
     On Error Resume Next
     Application.DisplayAlerts = False
     Application.ScreenUpdating = False
     Sheets("MSO_Verileri").Visible = True
     Sheets("MSO_Verileri").Select
     ActiveWindow.SelectedSheets.Delete
     Application.ScreenUpdating = True
End Sub
Private Sub CommandButton1_Click()
     On Error GoTo Hata
     Call Temizle
     hFile = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks, *.xls; *.xlsx; *.xlsm", Title:="Open Workbook", ButtonText:="Open", MultiSelect:=False)
     If VBA.IsNull(hFile) = False Then
          Application.ScreenUpdating = False
          Label3.Caption = " " & hFile
          Set hCon = CreateObject("ADODB.Connection")
          Set hCat = CreateObject("ADOX.Catalog")
          hCon.Open "Driver={Microsoft Excel Driver (*.xls)};DBQ=" & hFile
          hCat.ActiveConnection = hCon
          For Each hPage In hCat.Tables
               If hPage.Type = "SYSTEM TABLE" Then '"TABLE" alan isimlerini bulur.
                     ListBox1.AddItem VBA.Left$(hPage.Name, Len(hPage.Name) - 1)
               End If
          Next hPage
          Set hCon = Nothing
          Set hCat = Nothing
          Application.ScreenUpdating = True
     End If
     Exit Sub
     Hata:
     MsgBox "MSO EXCEL® *.xls DOSYA SEÇİMİ HATA TANIMI" & VBA.Constants.vbCrLf & VBA.Constants.vbCrLf & "Hata No" & VBA.Constants.vbTab & ":" & VBA.Err.Number & VBA.Constants.vbCrLf & "Hata Adı" & VBA.Constants.vbTab & ":" & VBA.Err.Description
End Sub
Private Sub ListBox1_Click()
     On Error Resume Next
     If ListBox1.ListIndex > -1 Then
          Application.ScreenUpdating = False
          hName = VBA.Dir(hFile, vbNormal)
          hPath = VBA.Left(hFile, VBA.Len(hFile) - VBA.Len(hName))
          hSayfa = ListBox1.Value
          hAdres = "A1:IV65536"
          hYol = "'" & hPath & "[" & hName & "]" & hSayfa & "'!"
          Set hCon = CreateObject("ADODB.Connection")
          hCon.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & hPath & hName & ";Extended Properties=""Excel 8.0;HDR=NO"""
          Set hRec = CreateObject("ADODB.Recordset")
          hRec.Open "SELECT * FROM [" & hSayfa & "$" & hAdres & "]", hCon ', adOpenDynamic, adLockOptimistic
          With ThisWorkbook.Sheets("MSO_Verileri")
               .Range("A1").CopyFromRecordset hRec
               Bellek = .UsedRange
               With ListBox2
                    .List() = Bellek
                    .Left = 126
                    .Top = 84
                    .Height = 306
                    .Width = 558
               End With
               .Range("A1:IV65536").ClearContents
          End With
          Set hCon = Nothing
          Set hCat = Nothing        
          Set hRec = Nothing
          Erase Bellek
          Application.ScreenUpdating = True
     End If
End Sub
Private Sub Temizle()
     On Error Resume Next
     Label3.Caption = ""
     ListBox1.Clear
     ListBox2.Clear
End Sub
Private Sub Ekran_Kur()
     On Error Resume Next
     For Each Eleman In ThisWorkbook.Worksheets
          If Eleman.Name = "MSO_Verileri" Then Exit Sub
     Next Eleman
     Application.DisplayAlerts = False
     Application.ScreenUpdating = False
     ThisWorkbook.Worksheets.Add
     With ActiveSheet
          .Name = "MSO_Verileri"
          .Visible = xlHidden
     End With
     Application.ScreenUpdating = True
     With Me
          .BackColor = &HE0E0E0
          .Height = 418
          .Width = 694
          .Picture = Resim(URL1)
          .PictureAlignment = fmPictureAlignmentCenter
          .PictureSizeMode = fmPictureSizeModeStretch
          .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 = 208
               .Caption = "Mustafa ULUSARAÇ"
               .BorderStyle = fmBorderStyleNone
               .SpecialEffect = fmSpecialEffectFlat
               .BackStyle = fmBackStyleTransparent
               .Font.Bold = True
               .Font.Name = "Arial Narrow"
               .ForeColor = vbBlue
          End With
          With Label2
               .Left = 36
               .Top = 18
               .Height = 12
               .Width = 208
               .Caption = "01ulusarac@superonline.com"
               .BorderStyle = fmBorderStyleNone
               .SpecialEffect = fmSpecialEffectFlat
               .BackStyle = fmBackStyleTransparent
               .Font.Bold = True
               .Font.Name = "Arial Narrow"
               .ForeColor = vbBlue
          End With
          With CommandButton1
               .Left = 6
               .Top = 36
               .Height = 24
               .Width = 114
               .Caption = "Choose xls File"
               .BackStyle = fmBackStyleTransparent
               .Font.Bold = True
               .Font.Name = "Arial Narrow"
               .ForeColor = vbBlue
               .Picture = Resim(URL3)
               .PicturePosition = fmPicturePositionLeftCenter
          End With
          With Label3
               .Left = 126
               .Top = 36
               .Height = 24
               .Width = 558
               .Caption = ""
               .BorderStyle = fmBorderStyleNone
               .SpecialEffect = fmSpecialEffectEtched
               .BackStyle = fmBackStyleTransparent
               .Font.Bold = False
               .Font.Name = "Arial Narrow"
               .ForeColor = vbBlack
               .TextAlign = fmTextAlignLeft
          End With
          With Label4
               .Left = 6
               .Top = 66
               .Height = 18
               .Width = 114
               .Caption = "Choose Sheet"
               .BorderStyle = fmBorderStyleNone
               .SpecialEffect = fmSpecialEffectEtched
               .BackStyle = fmBackStyleTransparent
               .Font.Bold = False
               .Font.Name = "Arial Narrow"
               .ForeColor = vbBlack
               .TextAlign = fmTextAlignCenter
          End With
          With Label5
               .Left = 126
               .Top = 66
               .Height = 18
               .Width = 558
               .Caption = "UsedRange Data of the Choosed Sheet"
               .BorderStyle = fmBorderStyleNone
               .SpecialEffect = fmSpecialEffectEtched
               .BackStyle = fmBackStyleTransparent
               .Font.Bold = False
               .Font.Name = "Arial Narrow"
               .ForeColor = vbBlack
               .TextAlign = fmTextAlignCenter
          End With
          With ListBox1
               .SpecialEffect = fmSpecialEffectEtched
               .BackColor = &H80000018
               .Font.Bold = False
               .Font.Name = "Arial Narrow"
               .ForeColor = vbBlue
               .ListStyle = fmListStylePlain
               .MultiSelect = fmMultiSelectSingle
               .ColumnCount = 1
               .Left = 6
               .Top = 84
               .Height = 306
               .Width = 114
          End With
          VBA.DoEvents
          With ListBox2
               .SpecialEffect = fmSpecialEffectEtched
               .BackColor = &H80000018
               .Font.Bold = False
               .Font.Name = "Arial Narrow"
               .ForeColor = vbBlack
               .ListStyle = fmListStyleOption
               .MultiSelect = fmMultiSelectMulti
               .ColumnCount = 256
               .Left = 126            
               .Top = 84
               .Height = 306
               .Width = 558
          End With
          .Repaint
     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://1.bp.blogspot.com/-atWv1jz_erE/ULnqrt3dUcI/AAAAAAAADHk/2Zl3L_8Rxso/s1600/GrafikAlt%25C4%25B1Logo_jpg_sa%25C4%259F%25C3%25BCst.jpg "
Public Const URL2 As String = "http://2.bp.blogspot.com/_hsHTxo_5L8E/S78EbvJyhRI/AAAAAAAACS0/txbOQ1qubg8/s1600/PB%C4%B0D_jpg.jpg "
Public Const URL3 As String = "http://3.bp.blogspot.com/-T8LAuWdsz_U/TcXIq0lIpPI/AAAAAAAACw4/UnomGxo3OEM/s1600/Dosya_A%25C3%25A7.gif "
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
          'ActiveSheet.Cells(No, 1) = No & ") Name: "
          'ActiveSheet.Cells(No, 2) = Eleman.Name
          'ActiveSheet.Cells(No, 3) = ", Description: "
          'ActiveSheet.Cells(No, 4) = Eleman.Description
          'ActiveSheet.Cells(No, 5) = ", FullPath: "
          'ActiveSheet.Cells(No, 6) = Eleman.FullPath
          'No = No + 1
     'Next Eleman
'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