• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

XLS - XLSM Problemi

R

ridvan2111

Katılım
14 Ekim 2007
Mesajlar
173
Excel Vers. ve Dili
xp tr
Merhaba Arkadaşlar, 2 Problemim var

1. Başka bir formda bulduğum bu kodlar xls uzantılı dosyalardan veri alıyor.
Bu kodları xlsm uzantısında çalışacak şekilde düzenlenebilirmi.?

Kodlar "guitarra035" a aittir.

2. Yine bu kodlar ağ üzerinde bi bilgisayara bağlanamadı çalışmadı.
"Invalid procedure call or argument" hatası veriyor
Kendi bilgisayarımda yol gösterdiğimde problem yok..

Dosya ekte.
 

Ekli dosyalar

evet.

"xlsm için" demeyelim de, "yeni versiyonlarda yeni uygulamaların, yeni yöntemlerin devreye girmesi nedeniyle" diyelim.

Microsoft.ACE.OLEDB.12.0 ve Excel 12.0 olarak.
 
Son düzenleme:
mancubus' Alıntı:
evet:

Microsoft.ACE.OLEDB.12.0 ve Excel 12.0 olarak.
Genişletmek için tıkla ...


Private Sub ComboBox1_Change()
'If ComboBox1.Text <> Empty Then
'Me.Height = 79
'Else
'Me.Height = 49
'End If
dosya$ = yol & Application.PathSeparator & ComboBox1.Text & ".xlsm"
Set cat = CreateObject("adox.catalog")
Set tbl = CreateObject("adox.table")
Set con = CreateObject("adodb.connection")
Set col = New Collection
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & dosya & ";extended properties=excel 12.0"
cat.activeconnection = con
col.Add "excelvba.net"
For Each tbl In cat.tables
tablo = Mid(tbl.Name, 1, InStrRev(tbl.Name, "$", -1, vbTextCompare) - 1)
If col.Item(1) <> tbl.Name Then
col.Add tablo$, , 1
End If
Next
ComboBox2.Clear
col.Remove col.Count
For i = 1 To col.Count
ComboBox2.AddItem col(i)
Next i
Set cat = Nothing
Set tbl = Nothing
Set con = Nothing
Set col = Nothing
i = Empty
tablo = vbNullString
End Sub
Genişletmek için tıkla ...


tablo = Mid(tbl.Name, 1, InStrRev(tbl.Name, "$", -1, vbTextCompare) - 1)
Genişletmek için tıkla ...

Burada hata veriyor.
 
aynı kodlar xls dosya ile çalışıyor muydu?
tam olarak hata mesajı nedir?

hata veren kod tbl nesnesinin isminin bir bölümünü döndüren metin fonksiyonu. fikrime göre, hata vermesi için tbl'nin ne olduğunu anlayamamış olması lazım gelir.
 
mancubus' Alıntı:
aynı kodlar xls dosya ile çalışıyor muydu?
tam olarak hata mesajı nedir?

hata veren kod tbl nesnesinin isminin bir bölümünü döndüren metin fonksiyonu. fikrime göre, hata vermesi için tbl'nin ne olduğunu anlayamamış olması lazım gelir.
Genişletmek için tıkla ...

evet xls dosyasında hatasız çalışıyor.

dosya$ = yol & Application.PathSeparator & ComboBox1.Text & ".xlsm"
Set cat = CreateObject("adox.catalog")
Set tbl = CreateObject("adox.table")
Set con = CreateObject("adodb.connection")
Set col = New Collection
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & dosya & ";extended properties=excel 12.0"
cat.activeconnection = con
col.Add "excelvba.net"
For Each tbl In cat.tables
tablo = Mid(tbl.Name, 1, InStrRev(tbl.Name, "$", -1, vbTextCompare) - 1)
If col.Item(1) <> tbl.Name Then
col.Add tablo$, , 1
End If
Next
Genişletmek için tıkla ...

xlsm de adox olarak çekmiyor olabilir mi ? güncel tablo çekmek için excelde hangi kod kullanılabilir ?

Ekteki dosya xls den hatasız veri çekiyor.
Dosya açılışında hata verebilir. Listview1 eklenmeli ve dosya yolu değiştirilmeli.
 
Son düzenleme:
vbaexpress'ten bulduğum aşağıdaki kod, aynı yöntemle, kapalı dosyadaki sayfa isimlerini mesaj kutusunda listeliyor.

buradan çalıştığı sonucuna ulaşabiliriz.

Kod: 
Sub GetSheetNames()
'http://www.vbaexpress.com/forum/showthread.php?t=34460

    Dim oConn As Object
    Const sFilename As String = "C:\raporlar\test.xlsm"
    Dim oCat As Object
    Dim tbl As Object
    Dim iRow As Long
    Dim sConnString As String
    Dim sTableName As String
    Dim msg As String
    Dim cLength As Integer
    Dim iTestPos As Integer
    Dim iStartpos As Integer
     
    sConnString = "Provider=Microsoft.Ace.OLEDB.12.0;" & _
    "Data Source=" & sFilename & ";" & _
    "Extended Properties=Excel 12.0;"
     
    Set oConn = CreateObject("ADODB.Connection")
    oConn.Open sConnString
    Set oCat = CreateObject("ADOX.Catalog")
    Set oCat.ActiveConnection = oConn
     
    iRow = 1
    For Each tbl In oCat.Tables
        sTableName = tbl.Name
        cLength = Len(sTableName)
        iTestPos = 0
        iStartpos = 1
         'Worksheet name with embedded spaces enclosed by single quotes
        If Left(sTableName, 1) = "'" And Right(sTableName, 1) = "'" Then
            iTestPos = 1
            iStartpos = 2
        End If
         'Worksheet names always end in the "$" character
        If Mid$(sTableName, cLength - iTestPos, 1) = "$" Then
            msg = msg & Mid$(sTableName, iStartpos, cLength - (iStartpos + iTestPos)) & vbCr
            iRow = iRow + 1
        End If
    Next tbl
         
    MsgBox msg
     
    oConn.Close
    Set oCat = Nothing
     
End Sub
 
mancubus' Alıntı:
vbaexpress'ten bulduğum aşağıdaki kod, aynı yöntemle, kapalı dosyadaki sayfa isimlerini mesaj kutusunda listeliyor.

buradan çalıştığı sonucuna ulaşabiliriz.

Kod: 
Sub GetSheetNames()
'http://www.vbaexpress.com/forum/showthread.php?t=34460

    Dim oConn As Object
    Const sFilename As String = "C:\raporlar\test.xlsm"
    Dim oCat As Object
    Dim tbl As Object
    Dim iRow As Long
    Dim sConnString As String
    Dim sTableName As String
    Dim msg As String
    Dim cLength As Integer
    Dim iTestPos As Integer
    Dim iStartpos As Integer
     
    sConnString = "Provider=Microsoft.Ace.OLEDB.12.0;" & _
    "Data Source=" & sFilename & ";" & _
    "Extended Properties=Excel 12.0;"
     
    Set oConn = CreateObject("ADODB.Connection")
    oConn.Open sConnString
    Set oCat = CreateObject("ADOX.Catalog")
    Set oCat.ActiveConnection = oConn
     
    iRow = 1
    For Each tbl In oCat.Tables
        sTableName = tbl.Name
        cLength = Len(sTableName)
        iTestPos = 0
        iStartpos = 1
         'Worksheet name with embedded spaces enclosed by single quotes
        If Left(sTableName, 1) = "'" And Right(sTableName, 1) = "'" Then
            iTestPos = 1
            iStartpos = 2
        End If
         'Worksheet names always end in the "$" character
        If Mid$(sTableName, cLength - iTestPos, 1) = "$" Then
            msg = msg & Mid$(sTableName, iStartpos, cLength - (iStartpos + iTestPos)) & vbCr
            iRow = iRow + 1
        End If
    Next tbl
         
    MsgBox msg
     
    oConn.Close
    Set oCat = Nothing
     
End Sub
Genişletmek için tıkla ...


Sayın, mancubus teşekkür ederim. Bu örnek işime yaradı.

Fakat ağ üzerinden bir yol gösterdiğimde
"run time error "5":
"invalid procedure call or argument" hatası veriyor.
 
pc'de çalışıp network'te çalışmıyor. belki network güvenlik yetkileri ile ilgilidir.
 
dim con as object, rs as object, cat as object, fld as object
dim evn as object, klasor as object
dim dosya as string, sorgu as string, tablo as string
dim a as long, s as byte, r
private col as collection
private const yol$ = "c:\documents and settings\belında\desktop"
Genişletmek için tıkla ...


private sub combobox1_change()
dosya$ = yol & application.pathseparator & combobox1.text & ".xlsm"
set cat = createobject("adox.catalog")
set tbl = createobject("adox.table")
set con = createobject("adodb.connection")
set col = new collection
con.open "provider=microsoft.ace.oledb.12.0;data source=" & dosya & ";extended properties=excel 12.0"
cat.activeconnection = con
col.add "excelvba.net"
for each tbl ın cat.tables
tablo = mid(tbl.name, 1, ınstrrev(tbl.name, "$", -1, vbtextcompare) - 1)
ıf col.ıtem(1) <> tbl.name then
col.add tablo$, , 1
end ıf
next
combobox2.clear
col.remove col.count
for i = 1 to col.count
combobox2.addıtem col(i)
next i
set cat = nothing
set tbl = nothing
set con = nothing
set col = nothing
i = empty
tablo = vbnullstring
end sub
Genişletmek için tıkla ...


Yukarıda kırmızı işaretli yere buradaki ağ yolunu eklemeliyim.
Bu ağ yolu nasıl düzenlenebilir?

\\Planlama-a6b4d4\planlama c\Documents and Settings\planlama\Desktop
Genişletmek için tıkla ...
 
hangi kod olursa olsun dosyayı farklı olarak kaydetin ve kayıt türünüde "Makro içeren " olarak kaydedin
 
ilgili klasöre boş bir dosya kaydet.

bu dosyanın içinden Msgbox ActiveWorkbook.FullName kodunu çalıştır.

eğer A, G, L vs bir harf döndürüyorsa aşağıdaki fonksiyonu kullanabilirsin.


Kod: 
Declare Function WNetGetConnectionA Lib "mpr.dll" _
(ByVal lpszLocalName As String, _
ByVal lpszRemoteName As String, _
cbRemoteName As Long) As Long


Function GetUNCPath(myDriveLetter As String) As String

Dim lReturn As Long
Dim szBuffer As String

myDriveLetter = Left(myDriveLetter, 1) & ":"
szBuffer = String$(256, vbNullChar)
lReturn = WNetGetConnectionA(myDriveLetter, szBuffer, 256)

If lReturn = 0 Then
    GetUNCPath = Left$(szBuffer, InStr(szBuffer, vbNullChar))
Else
    GetUNCPath = "Invalid drive"
End If

End Function


kullanım:
Kod: 
MsgBox GetUNCPath("G")
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst